asgsqlite3.pas

连接sqlite数据库控件

  {$L 'OBJ\hrdir_b.obj'}
  {$L 'OBJ\realloc.obj'}
  {$L 'OBJ\mbctype.obj'}
  {$L 'OBJ\xcvt.obj'}
  {$L 'OBJ\xcvtw.obj'}
  {$L 'OBJ\wcscpy.obj'}
  {$L 'OBJ\errno.obj'}
  {$L 'OBJ\ctrl87.obj'}
  {$L 'OBJ\timedata.obj'}
  {$L 'OBJ\int64toa.obj'}
  {$L 'OBJ\cvtentry.obj'}
  {$L 'OBJ\mbyte1.obj'}
  {$L 'OBJ\errormsg.obj'}
  {$L 'OBJ\exit.obj'}
  {$L 'OBJ\iswctype.obj'}
  {$L 'OBJ\heap.obj'}
  {$L 'OBJ\memmove.obj'}
  {$L 'OBJ\fxam.obj'}
  {$L 'OBJ\fuistq.obj'}
  {$L 'OBJ\qdiv10.obj'}
  {$L 'OBJ\wmemset.obj'}
  {$L 'OBJ\wcslen.obj'}
  {$L 'OBJ\_tzset.obj'}
  {$L 'OBJ\deflt87.obj'}
  {$L 'OBJ\mbschr.obj'}
  {$L 'OBJ\mbsrchr.obj'}
  {$L 'OBJ\ermsghlp.obj'}
  {$L 'OBJ\patexit.obj'}
  {$L 'OBJ\initexit.obj'}
  {$L 'OBJ\virtmem.obj'}
  {$L 'OBJ\tzset.obj'}
  {$L 'OBJ\mbisdgt.obj'}
  {$L 'OBJ\mbsnbcpy.obj'}
  {$L 'OBJ\platform.obj'}
  {$L 'OBJ\getenv.obj'}
  {$L 'OBJ\mbisalp.obj'}
  {$L 'OBJ\abort.obj'}
  {$L 'OBJ\signal.obj'}
  {$L 'OBJ\clear87.obj'}
  {$L 'OBJ\abort.obj'}
  {$L 'OBJ\handles.obj'}
  {$L 'OBJ\_cfinfo.obj'}
  {$L 'OBJ\__isatty.obj'}
  {$L 'OBJ\handles.obj'}  //duplicato
  {$L 'OBJ\perror.obj'}
  {$L 'OBJ\fputs.obj'}
  {$L 'OBJ\files2.obj'}
  {$L 'OBJ\handles.obj'}  //duplicato 2
  {$L 'OBJ\ioerror.obj'}
  {$L 'OBJ\perror.obj'}   //duplicato
  {$L 'OBJ\__write.obj'}
  {$L 'OBJ\_write.obj'}
  {$L 'OBJ\__lseek.obj'}
  {$L 'OBJ\ioerror.obj'}
  {$L 'OBJ\setenvp.obj'}
  {$L 'OBJ\calloc.obj'}
  {$L 'OBJ\mbsnbcmp.obj'}
  {$L 'OBJ\mbsnbicm.obj'}
  {$L 'OBJ\is.obj'}
  {$L 'OBJ\isctype.obj'}
  {$L 'OBJ\bigctype.obj'}
  {$L 'OBJ\globals.obj'}
  {$L 'OBJ\hrdir_mf.obj'}
  {$L 'OBJ\fpreset.obj'}
  {$L 'OBJ\ta.obj'}
  {$L 'OBJ\setexc.obj'}
  {$L 'OBJ\defhandl.obj'}
  //*)

  function _wsprintfA:integer; external 'user32.dll' name 'wsprintfA';
  procedure RtlUnwind; external 'NtDll.dll' name 'RtlUnwind';

  function  _sqlite3_open(dbname: PAnsiChar; var db: pointer): integer; cdecl; external;
  function  _sqlite3_close(db: pointer): integer; cdecl; external;

  //by lck
  function _sqlite3_key(db: pointer; Key : Pointer; nLen : integer): integer; cdecl; external;
  function _sqlite3_rekey(db: pointer; Key : Pointer; nLen : integer): integer; cdecl; external;
  function  _sqlite3_threadsafe: Integer; cdecl; external;
  //by lck

  function  _sqlite3_exec(DB: Pointer; SQLStatement: PAnsiChar; Callback: TSQLite3_Callback;
                          UserDate: Pointer; var ErrMsg: PAnsiChar): Integer; cdecl; external;
  function  _sqlite3_libversion: PAnsiChar; cdecl; external;
  function  _sqlite3_errmsg(db: pointer): PAnsiChar; cdecl; external;
  function  _sqlite3_get_table(db: Pointer; SQLStatement: PAnsiChar; var ResultPtr: Pointer;
                              var RowCount: cardinal; var ColCount: cardinal; var ErrMsg: PAnsiChar): integer; cdecl; external;
  procedure _sqlite3_free_table(Table: PAnsiChar); cdecl; external;
  procedure _sqlite3_free(P: PAnsiChar); cdecl; external;
  function  _sqlite3_complete(P: PAnsiChar): boolean; cdecl; external;
  function  _sqlite3_last_insert_rowid(db: Pointer): integer; cdecl; external;
  procedure _sqlite3_interrupt(db: Pointer); cdecl; external;
  procedure _sqlite3_busy_handler(db: Pointer; CallbackPtr: Pointer; Sender: TObject); cdecl; external;
  procedure _sqlite3_busy_timeout(db: Pointer; TimeOut: integer); cdecl; external;
  function  _sqlite3_changes(db: Pointer): integer; cdecl; external;
  function  _sqlite3_prepare(db: Pointer; SQLStatement: PAnsiChar; nBytes: integer;
                             var hstatement: pointer; var Tail: PAnsiChar): integer; cdecl; external;
  function  _sqlite3_finalize(hstatement: pointer): integer; cdecl; external;
  function  _sqlite3_reset(hstatement: pointer): integer; cdecl; external;
  function  _sqlite3_step(hstatement: pointer): integer; cdecl; external;
  function  _sqlite3_column_blob(hstatement: pointer; iCol: integer): pointer; cdecl; external;
  function  _sqlite3_column_bytes(hstatement: pointer; iCol: integer): integer; cdecl; external;
  function  _sqlite3_column_count(hstatement: pointer): integer; cdecl; external;
  function  _sqlite3_column_decltype(hstatement: pointer; iCol: integer): PAnsiChar; cdecl; external;
  function  _sqlite3_column_double(hstatement: pointer; iCol: integer): double; cdecl; external;
  function  _sqlite3_column_int(hstatement: pointer; iCol: integer): integer; cdecl; external;
  function  _sqlite3_column_int64(hstatement: pointer; iCol: integer): int64; cdecl; external;
  function  _sqlite3_column_name(hstatement: pointer; iCol: integer): PAnsiChar; cdecl; external;
  function  _sqlite3_column_text(hstatement: pointer; iCol: integer): PAnsiChar; cdecl; external;
  function  _sqlite3_column_type(hstatement: pointer; iCol: integer): integer; cdecl; external;
  function  _sqlite3_bind_blob(hstatement: pointer; iCol: integer; buf: PAnsiChar; n: integer; DestroyPtr: Pointer): integer; cdecl; external;

{$ENDIF}
// GPA - Static Link End


{$IFDEF DEBUG_ENABLED}
var
  DebugSpaces       : Integer = 0;
{$ENDIF}

procedure Debug(const S: string);
begin
{$IFDEF DEBUG_ENABLED}
  OutputDebugString(PAnsiChar(StringOfChar(' ', DebugSpaces) + S));
{$ENDIF}
end;

procedure DebugEnter(const S: string);
begin
{$IFDEF DEBUG_ENABLED}
  OutputDebugString(PAnsiChar(StringOfChar(' ', DebugSpaces) + 'Enter ' + S));
  inc(DebugSpaces);
{$ENDIF}
end;

procedure DebugLeave(const S: string);
begin
{$IFDEF DEBUG_ENABLED}
  dec(DebugSpaces);
  OutputDebugString(PAnsiChar(StringOfChar(' ', DebugSpaces) + 'Leave ' + S));
{$ENDIF}
end;

//==============================================================================
// SyntaxCheck. This routine is used to check if words match the sql syntax
//              It is called where sql statements are parsed and generated
//==============================================================================

function SyntaxCheck(LWord, RWord: string): boolean;
begin
  DebugEnter('SyntaxCheck');
  try
    if CompareText(LWord, RWord) <> 0 then begin
      SyntaxCheck := false;
      raise AsgError.Create('SQL macro syntax error on sql, expected ' + RWord)
    end else
      SyntaxCheck := true;
  finally
    DebugLeave('SyntaxCheck');
  end;
end;

//==============================================================================
// Parse the SQL fielddescription and return the Delphi Field types, length etc.
//==============================================================================

procedure GetFieldInfo(FieldInfo: string; var FieldType: TFieldType;
  var FieldLen, FieldDec: integer);
var
  p1, p2, pn        : integer;
  vt                : string;
begin
  DebugEnter('GetFieldInfo');
  FieldType := ftString;                // just a default;
  FieldLen := 255;
  FieldDec := 0;

  p1 := pos('(', FieldInfo);
  if p1 <> 0 then
  begin
    p2 := pos(')', FieldInfo);
    if p2 <> 0 then
    begin
      vt := LowerCase(Copy(FieldInfo, 1, p1 - 1));
      if (vt = 'varchar') or (vt = 'char') or (vt = 'varchar2') then begin
        FieldType := ftString;
        FieldLen := StrToInt(Copy(FieldInfo, p1 + 1, p2 - p1 - 1));
      end else if (vt = 'nvarchar') or (vt = 'nchar') or (vt = 'nvarchar2') then begin
        FieldType := ftWideString;
        FieldLen := StrToInt(Copy(FieldInfo, p1 + 1, p2 - p1 - 1)) * 2;
      end else if (vt = 'numeric') then begin
        vt := Copy(FieldInfo, p1 + 1, p2 - p1 - 1);
        pn := pos('.', vt); if pn = 0 then pn := pos(',', vt);
        FieldType := ftFloat;
        if pn = 0 then begin
          FieldLen := StrToInt(vt);
          FieldDec := 0;
        end else begin
          FieldLen := StrToInt(Copy(vt, 1, pn - 1));
          FieldDec := StrToInt(Copy(vt, pn + 1, 2));
        end;
      end;
    end
    else
      FieldLen := 256;
  end
  else
  begin
    vt := LowerCase(FieldInfo);
    if vt = 'date' then
    begin
      FieldType := ftDate;
      FieldLen := 10;
    end
    else if vt = 'datetime' then
    begin
      FieldType := ftDateTime;          // fpierce original ftDate
      FieldLen := 24;                   // aducom
    end
    else if vt = 'time' then
    begin
      FieldType := ftTime;
      FieldLen := 12;
    end
{$IFDEF ASQLITE_D6PLUS}
    else if vt = 'timestamp' then
    begin
      FieldType := ftTimeStamp;
      FieldLen := 12;
    end
{$ENDIF}
    else if (vt = 'integer') or (vt = 'int')  then
    begin
      FieldType := ftInteger;
      FieldLen := 12;
    end
    else if (vt = 'float') or (vt = 'real') then
    begin
      FieldType := ftFloat;
      FieldLen := 12;
    end
    else if (vt = 'boolean') or (vt = 'logical') then
    begin
      FieldType := ftBoolean;
      FieldLen := 2;
    end
    else if //(vt='text') or
    (vt = 'shorttext') or (vt = 'string') then
    begin
      FieldType := ftString;
      FieldLen := 255;
    end
    else if (vt = 'widetext') or (vt = 'widestring') then
    begin
      FieldType := ftWideString;
      FieldLen := 512;
    end
    else if (vt = 'currency') or (vt = 'financial') or (vt = 'money') then
    begin
      FieldType := ftCurrency;
      FieldLen := 10;
    end
    else if (vt = 'blob') then
    begin
      FieldType := ftBlob;
      FieldLen := SizeOf(Pointer);
    end
    else if (vt = 'graphic') then
    begin
      FieldType := ftGraphic;
      FieldLen := SizeOf(Pointer);
    end
    else if (vt = 'clob') or (