unit uDbErrorHandler;

interface

uses
  System.SysUtils, System.Classes, Data.DB, FireDAC.Stan.Error, FireDAC.Comp.Client;

type
  TDbErrorType = (
    detDuplicateKey,
    detForeignKey,
    detNotNull,
    detDataTruncation,
    detConnectionLost,
    detDeadlock,
    detPermissionDenied,
    detStructureError,
    detOther
  );

  TDbErrorDetails = record
    ErrorType: TDbErrorType;
    SqlState: string;
    ConstraintName: string;
    TableName: string;
    FieldName: string;
    FriendlyMessage: string;
    OriginalMessage: string;
    SqlText: string;
    ModuleName: string;
    ProcedureName: string;
  end;

  TDbErrorHandler = class
  public
    /// <summary>
    /// Analiza una excepción (general o de FireDAC) y genera una estructura estructurada de detalles.
    /// </summary>
    class function ParseException(const AException: Exception; const ASqlText: string = ''; const AModuleName: string = ''; const AProcedureName: string = ''): TDbErrorDetails; static;

    /// <summary>
    /// Captura un error de base de datos, lo parsea y abre el diálogo visual premium.
    /// </summary>
    class procedure HandleException(const AException: Exception; const ASqlText: string = ''; const AModuleName: string = ''; const AProcedureName: string = ''); static;

    /// <summary>
    /// Manejador de excepciones global para Application.OnException
    /// </summary>
    class procedure GlobalExceptionHandler(Sender: TObject; E: Exception);

    /// <summary>
    /// Registra el manejador global en el objeto Application de la VCL.
    /// </summary>
    class procedure RegisterGlobalHandler; static;
  end;

implementation

uses
  Vcl.Forms, Vcl.Controls, System.TypInfo, System.Variants, frm_DbErrorDialog;

{ TDbErrorHandler }

class function TDbErrorHandler.ParseException(const AException: Exception; const ASqlText: string = ''; const AModuleName: string = ''; const AProcedureName: string = ''): TDbErrorDetails;
var
  LFDException: EFDDBEngineException;
  LFDError: TFDDBError;
  LMsgLower: string;
  LStartPos, LEndPos: Integer;
begin
  // Inicialización de la estructura de retorno
  Result.ErrorType := detOther;
  Result.SqlState := '';
  Result.ConstraintName := '';
  Result.TableName := '';
  Result.FieldName := '';
  Result.OriginalMessage := AException.Message;
  Result.SqlText := ASqlText;
  Result.FriendlyMessage := AException.Message;

  // Deducción automática del módulo/formulario emisor
  if Trim(AModuleName) <> '' then
    Result.ModuleName := Trim(AModuleName)
  else if Assigned(Screen) and Assigned(Screen.ActiveForm) then
  begin
    if Screen.ActiveForm.Caption <> '' then
      Result.ModuleName := Format('%s (%s)', [Screen.ActiveForm.Caption, Screen.ActiveForm.ClassName])
    else
      Result.ModuleName := Screen.ActiveForm.ClassName;
  end
  else
    Result.ModuleName := 'Módulo del Sistema';

  if Trim(AProcedureName) <> '' then
    Result.ProcedureName := Trim(AProcedureName);

  // Si no es un error de motor de base de datos de FireDAC, salimos con detOther
  if not (AException is EFDDBEngineException) then
  begin
    // Intentar clasificar algunos errores estándar de red o timeouts por texto
    LMsgLower := LowerCase(AException.Message);
    if (Pos('timeout', LMsgLower) > 0) or (Pos('socket', LMsgLower) > 0) or 
       (Pos('connection', LMsgLower) > 0) or (Pos('lost connection', LMsgLower) > 0) or
       (Pos('no se pudo conectar', LMsgLower) > 0) then
    begin
      Result.ErrorType := detConnectionLost;
      Result.FriendlyMessage := 'No se ha podido establecer conexión con el servidor de base de datos. ' +
        'Por favor, compruebe su conexión de red o la disponibilidad del servidor.';
    end;
    Exit;
  end;

  LFDException := EFDDBEngineException(AException);
  if LFDException.ErrorCount = 0 then
    Exit;

  // Tomamos el primer error de la colección devuelta por FireDAC
  LFDError := LFDException.Errors[0];
  Result.SqlState := IntToStr(LFDError.ErrorCode);
  Result.ConstraintName := LFDError.ObjName;
  Result.OriginalMessage := LFDError.Message;
  
  LMsgLower := LowerCase(LFDError.Message);

  // Intentar extraer el SQLSTATE alfanumérico si viene formateado en el mensaje
  LStartPos := Pos('sqlstate', LMsgLower);
  if LStartPos > 0 then
  begin
    LStartPos := LStartPos + 8; // saltar la palabra 'sqlstate'
    while (LStartPos <= Length(LMsgLower)) and not CharInSet(LMsgLower[LStartPos], ['a'..'z', '0'..'9']) do
      Inc(LStartPos);
    if LStartPos <= Length(LMsgLower) - 4 then
      Result.SqlState := UpperCase(Copy(LFDError.Message, LStartPos, 5));
  end;

  // Clasificación ultra-compatible usando SQLSTATE y códigos de error nativos (PostgreSQL / MySQL)
  if (Result.SqlState = '23505') or (LFDError.ErrorCode = 23505) or (LFDError.ErrorCode = 1062) or (LFDError.ErrorCode = 1169) then
    Result.ErrorType := detDuplicateKey
  else if (Result.SqlState = '23503') or (LFDError.ErrorCode = 23503) or (LFDError.ErrorCode = 1215) or (LFDError.ErrorCode = 1216) or (LFDError.ErrorCode = 1217) or (LFDError.ErrorCode = 1451) or (LFDError.ErrorCode = 1452) then
    Result.ErrorType := detForeignKey
  else if (Result.SqlState = '23502') or (LFDError.ErrorCode = 23502) or (LFDError.ErrorCode = 1048) or (LFDError.ErrorCode = 1364) then
    Result.ErrorType := detNotNull
  else if (Result.SqlState = '22001') or (LFDError.ErrorCode = 22001) or (LFDError.ErrorCode = 1265) or (LFDError.ErrorCode = 1406) then
    Result.ErrorType := detDataTruncation
  else if (Result.SqlState = '40001') or (Result.SqlState = '40P01') or (LFDError.ErrorCode = 1213) or (Pos('deadlock', LMsgLower) > 0) or (Pos('bloqueo', LMsgLower) > 0) then
    Result.ErrorType := detDeadlock
  else if (Result.SqlState = '42501') or (LFDError.ErrorCode = 1044) or (LFDError.ErrorCode = 1045) or (LFDError.ErrorCode = 1142) or (LFDError.ErrorCode = 1143) or (Pos('permission', LMsgLower) > 0) or (Pos('privilege', LMsgLower) > 0) or (Pos('acceso denegado', LMsgLower) > 0) then
    Result.ErrorType := detPermissionDenied
  else if (Result.SqlState = '42703') or (Result.SqlState = '42P01') or (LFDError.ErrorCode = 1054) or (LFDError.ErrorCode = 1146) or (LFDError.ErrorCode = 1072) or (Pos('columna', LMsgLower) > 0) or (Pos('tabla', LMsgLower) > 0) then
    Result.ErrorType := detStructureError
  else if (Result.SqlState = '08001') or (Result.SqlState = '08004') or (Result.SqlState = '08006') or (LFDError.ErrorCode = 2002) or (LFDError.ErrorCode = 2003) or (LFDError.ErrorCode = 2006) or (LFDError.ErrorCode = 2013) or 
          (Pos('connection', LMsgLower) > 0) or (Pos('lost connection', LMsgLower) > 0) or (Pos('no se pudo conectar', LMsgLower) > 0) then
    Result.ErrorType := detConnectionLost;

  // Si no se clasificó por SQLSTATE, intentamos clasificar por contenido del texto del error
  if Result.ErrorType = detOther then
  begin
    if (Pos('unique', LMsgLower) > 0) or (Pos('duplicado', LMsgLower) > 0) or (Pos('duplicate key', LMsgLower) > 0) then
      Result.ErrorType := detDuplicateKey
    else if (Pos('foreign key', LMsgLower) > 0) or (Pos('integridad', LMsgLower) > 0) or (Pos('referencia', LMsgLower) > 0) then
      Result.ErrorType := detForeignKey
    else if (Pos('not null', LMsgLower) > 0) or (Pos('no puede ser nulo', LMsgLower) > 0) or (Pos('violates not-null', LMsgLower) > 0) then
      Result.ErrorType := detNotNull
    else if (Pos('too long', LMsgLower) > 0) or (Pos('truncation', LMsgLower) > 0) or (Pos('demasiado largo', LMsgLower) > 0) then
      Result.ErrorType := detDataTruncation
    else if (Pos('deadlock', LMsgLower) > 0) or (Pos('bloqueo', LMsgLower) > 0) or (Pos('concurrencia', LMsgLower) > 0) then
      Result.ErrorType := detDeadlock
    else if (Pos('permiso', LMsgLower) > 0) or (Pos('privilege', LMsgLower) > 0) or (Pos('acceso denegado', LMsgLower) > 0) then
      Result.ErrorType := detPermissionDenied
    else if (Pos('no existe la columna', LMsgLower) > 0) or (Pos('columna', LMsgLower) > 0) or (Pos('no existe la relación', LMsgLower) > 0) then
      Result.ErrorType := detStructureError;
  end;

  // Intentar parsear el nombre de la tabla de la cadena si PostgreSQL lo devuelve
  // Formato habitual: "... table "nombre_tabla" ..."
  LStartPos := Pos('table "', LMsgLower);
  if LStartPos > 0 then
  begin
    Inc(LStartPos, 7); // longitud de 'table "'
    LEndPos := Pos('"', Copy(LMsgLower, LStartPos, 200));
    if LEndPos > 0 then
      Result.TableName := Copy(LFDError.Message, LStartPos, LEndPos - 1);
  end;

  // Intentar parsear el constraint name si no vino en ObjName
  if Result.ConstraintName = '' then
  begin
    LStartPos := Pos('constraint "', LMsgLower);
    if LStartPos > 0 then
    begin
      Inc(LStartPos, 12); // longitud de 'constraint "'
      LEndPos := Pos('"', Copy(LMsgLower, LStartPos, 200));
      if LEndPos > 0 then
        Result.ConstraintName := Copy(LFDError.Message, LStartPos, LEndPos - 1);
    end;
  end;

  // Formular mensajes amigables y legibles en español según el tipo de error
  case Result.ErrorType of
    detDuplicateKey:
      begin
        Result.FriendlyMessage := 'Ya existe un registro con los mismos datos en el sistema (Clave Duplicada).';
        
        // Mapeo inteligente de constraints conocidos para ser ultra precisos
        if Result.ConstraintName <> '' then
        begin
          if (SameText(Result.ConstraintName, 'uk_articulos_codigo')) or (Pos('articulos_codigo', LowerCase(Result.ConstraintName)) > 0) then
            Result.FriendlyMessage := 'El código del artículo introducido ya está registrado para otro artículo. Por favor, introduzca un código diferente.'
          else if (SameText(Result.ConstraintName, 'lotes_codigo_key')) or (Pos('lotes_codigo', LowerCase(Result.ConstraintName)) > 0) then
            Result.FriendlyMessage := 'El código de lote generado o introducido ya existe en el sistema. Debe ser único.'
          else if (SameText(Result.ConstraintName, 'albaranes_empresa_id_serie_numero_key')) or (Pos('albaranes_numero', LowerCase(Result.ConstraintName)) > 0) then
            Result.FriendlyMessage := 'Ya existe un albarán con la misma Serie y Número para esta empresa.'
          else if (SameText(Result.ConstraintName, 'empresas_cif_nif_key')) or (Pos('empresas_cif', LowerCase(Result.ConstraintName)) > 0) then
            Result.FriendlyMessage := 'El CIF/NIF introducido ya pertenece a otra empresa registrada en la base de datos.'
          else if (SameText(Result.ConstraintName, 'clientes_cif_nif_key')) or (Pos('clientes_cif', LowerCase(Result.ConstraintName)) > 0) then
            Result.FriendlyMessage := 'El CIF/NIF introducido ya pertenece a otro cliente registrado.';
        end;
      end;

    detForeignKey:
      begin
        // Determinar si es de eliminación o inserción/actualización
        if (Pos('still referenced', LMsgLower) > 0) or (Pos('delete', LowerCase(ASqlText)) > 0) then
        begin
          Result.FriendlyMessage := 'No se puede eliminar el registro porque tiene información relacionada vinculada en el sistema (ej. albaranes, líneas, lotes o movimientos asociados).';
          
          if Result.ConstraintName <> '' then
          begin
            if Pos('fk_lotes_articulos', LowerCase(Result.ConstraintName)) > 0 then
              Result.FriendlyMessage := 'No se puede eliminar este artículo porque existen lotes registrados que hacen referencia a él.'
            else if Pos('fk_lineas_albaranes', LowerCase(Result.ConstraintName)) > 0 then
              Result.FriendlyMessage := 'No se puede eliminar este albarán o artículo porque contiene líneas de detalle registradas.'
            else if Pos('fk_albaranes_clientes', LowerCase(Result.ConstraintName)) > 0 then
              Result.FriendlyMessage := 'No se puede eliminar este cliente porque ya tiene albaranes o facturas creadas.';
          end;
        end
        else
        begin
          Result.FriendlyMessage := 'No se puede guardar el registro porque hace referencia a un elemento (artículo, cliente, empresa, etc.) que no existe en el sistema.';
        end;
      end;

    detNotNull:
      begin
        Result.FriendlyMessage := 'Hay datos obligatorios requeridos por la base de datos que no se han introducido.';
        
        // Intentar obtener el nombre del campo que viola el not-null
        LStartPos := Pos('column "', LMsgLower);
        if LStartPos > 0 then
        begin
          Inc(LStartPos, 8); // longitud de 'column "'
          LEndPos := Pos('"', Copy(LMsgLower, LStartPos, 200));
          if LEndPos > 0 then
          begin
            Result.FieldName := Copy(LFDError.Message, LStartPos, LEndPos - 1);
            Result.FriendlyMessage := Format('El campo obligatorio "%s" no puede dejarse en blanco. Por favor, introduzca un valor válido.', [Result.FieldName]);
          end;
        end;
      end;

    detDataTruncation:
      begin
        Result.FriendlyMessage := 'Ha introducido un texto demasiado largo. Supera el límite de caracteres permitido para ese campo en la base de datos.';
      end;

    detConnectionLost:
      begin
        Result.FriendlyMessage := 'Se ha perdido o no se ha podido establecer la conexión con el servidor central de la base de datos.' + #13#10 +
          'Por favor, verifique que tiene acceso a Internet o a la red local y vuelva a intentarlo.';
      end;

    detDeadlock:
      begin
        Result.FriendlyMessage := 'Conflicto de concurrencia: El registro que intenta modificar está bloqueado temporalmente por otro usuario.' + #13#10 +
          'Por favor, espere unos segundos e intente guardar de nuevo.';
      end;

    detPermissionDenied:
      begin
        Result.FriendlyMessage := 'Acceso denegado: Su usuario no tiene los privilegios necesarios en la base de datos para realizar esta acción.';
      end;

    detStructureError:
      begin
        Result.FriendlyMessage := 'Error técnico de estructura: Se ha detectado una discrepancia entre la aplicación y la estructura actual de la base de datos.' + #13#10 +
          'Por favor, contacte con el servicio de asistencia técnica para actualizar el software.';
      end;

    detOther:
      begin
        Result.FriendlyMessage := 'Ha ocurrido un error inesperado al procesar la operación en la base de datos.' + #13#10 +
          AException.Message;
      end;
  end;
end;

class procedure TDbErrorHandler.HandleException(const AException: Exception; const ASqlText: string; const AModuleName: string; const AProcedureName: string);
var
  LDetails: TDbErrorDetails;
begin
  // Analizar la excepción
  LDetails := ParseException(AException, ASqlText, AModuleName, AProcedureName);
  
  // Mostrar el diálogo VCL Premium
  TfrmDbErrorDialog.ShowError(LDetails);
end;

function GetComponentInfo(AComp: TComponent): string;
var
  LName, LCaption: string;
begin
  if AComp = nil then
    Exit('');

  LName := AComp.Name;
  if LName = '' then
    LName := '<SinNombre>';

  Result := Format('%s (%s)', [LName, AComp.ClassName]);

  // Si tiene propiedad Caption o Text legible, incluirla entre comillas
  if IsPublishedProp(AComp, 'Caption') then
  begin
    LCaption := Trim(VarToStr(GetPropValue(AComp, 'Caption', False)));
    if LCaption <> '' then
      Result := Result + Format(' [Caption: "%s"]', [LCaption]);
  end
  else if IsPublishedProp(AComp, 'Text') then
  begin
    LCaption := Trim(VarToStr(GetPropValue(AComp, 'Text', False)));
    if (LCaption <> '') and (Length(LCaption) <= 60) then
      Result := Result + Format(' [Text: "%s"]', [LCaption]);
  end;
end;

class procedure TDbErrorHandler.GlobalExceptionHandler(Sender: TObject; E: Exception);
var
  LSenderModule: string;
  LSenderProc: string;
  LSqlFromSender: string;
  LComp, LActiveCtrl: TComponent;
  LCompInfo, LParentInfo, LActiveCtrlInfo: string;
begin
  LSenderModule := '';
  LSenderProc := '';
  LSqlFromSender := '';

  if Assigned(Sender) then
  begin
    if Sender is TCustomForm then
    begin
      if TCustomForm(Sender).Caption <> '' then
        LSenderModule := Format('%s (%s)', [TCustomForm(Sender).Caption, TCustomForm(Sender).ClassName])
      else
        LSenderModule := TCustomForm(Sender).ClassName;
      LSenderProc := Format('Formulario: %s', [TCustomForm(Sender).ClassName]);
    end
    else if Sender is TComponent then
    begin
      LComp := TComponent(Sender);
      LCompInfo := GetComponentInfo(LComp);

      // Si es un TControl, obtener información de su contenedor padre
      LParentInfo := '';
      if (LComp is TControl) and (TControl(LComp).Parent <> nil) then
        LParentInfo := Format(' en Contenedor: %s', [GetComponentInfo(TControl(LComp).Parent)]);

      // Si el Sender es un DataSet, extraer la SQL automáticamente
      if (LComp is TFDQuery) then
        LSqlFromSender := TFDQuery(LComp).SQL.Text;

      // Detectar si el control con foco es un control hijo diferente al contenedor
      LActiveCtrlInfo := '';
      if Assigned(Screen) and Assigned(Screen.ActiveControl) and (Screen.ActiveControl <> LComp) then
      begin
        LActiveCtrl := Screen.ActiveControl;
        LActiveCtrlInfo := Format(' | Control Activo: %s', [GetComponentInfo(LActiveCtrl)]);
      end;

      LSenderProc := Format('Componente: %s%s%s', [LCompInfo, LParentInfo, LActiveCtrlInfo]);

      // Buscar el formulario propietario
      while (LComp <> nil) and not (LComp is TCustomForm) do
        LComp := LComp.Owner;

      if (LComp <> nil) and (LComp is TCustomForm) then
      begin
        if TCustomForm(LComp).Caption <> '' then
          LSenderModule := Format('%s (%s)', [TCustomForm(LComp).Caption, TCustomForm(LComp).ClassName])
        else
          LSenderModule := TCustomForm(LComp).ClassName;
      end;
    end
    else
      LSenderProc := Format('Objeto: %s', [Sender.ClassName]);
  end;

  if (LSenderModule = '') and Assigned(Screen) and Assigned(Screen.ActiveForm) then
  begin
    if Screen.ActiveForm.Caption <> '' then
      LSenderModule := Format('%s (%s)', [Screen.ActiveForm.Caption, Screen.ActiveForm.ClassName])
    else
      LSenderModule := Screen.ActiveForm.ClassName;
  end;

  HandleException(E, LSqlFromSender, LSenderModule, LSenderProc);
end;

class procedure TDbErrorHandler.RegisterGlobalHandler;
begin
  Application.OnException := TDbErrorHandler.GlobalExceptionHandler;
end;

end.