sdpgsql.pas

SQLDirect Component Library is a light-weight Borland Database Engine replacement for Borland Delphi

  szErrMsg := PQerrorMessage( pgconn );
  sMsg := HelperPtrToString( szErrMsg );

  E := ESDPgSQLError.Create(-1, -1, sMsg, 0);
  raise E;
end;

procedure TIPgDatabase.CheckRes(pgres: PPGresult);
var
  E: ESDPgSQLError;
  szErrMsg: TSDCharPtr;
  sMsg: string;
  rs: Integer;
begin
  ResetIdleTimeOut;
  rs := PQresultStatus( pgres );
  if (rs = PGRES_EMPTY_QUERY) or (rs = PGRES_COMMAND_OK) or (rs = PGRES_TUPLES_OK) then
    Exit;
  ResetBusyState;

  szErrMsg := PQresultErrorMessage( pgres );
  sMsg := HelperPtrToString( szErrMsg );

  E := ESDPgSQLError.Create(-1, -1, sMsg, 0);
  raise E;
end;

procedure TIPgDatabase.ExecCmd(const sStmt: string; CheckRslt: Boolean);
var
  res: PPGresult;
  szCmd: TSDCharPtr;
begin
{$IFDEF SD_CLR}
  szCmd := Marshal.StringToHGlobalAnsi( sStmt );
{$ELSE}
  szCmd := TSDCharPtr( sStmt );
{$ENDIF}
  res := PQexec( PgConnPtr, szCmd );
  try
    if CheckRslt then
      CheckRes( res );
  finally
    PQclear( res );
{$IFDEF SD_CLR}
    if Assigned( szCmd ) then
      Marshal.FreeHGlobal( szCmd );
{$ENDIF}
  end;
end;

function TIPgDatabase.GetClientVersion: LongInt;
begin
  Result := dwLoadedFileVer;
end;

function TIPgDatabase.GetServerVersion: LongInt;
begin
  Result := VersionStringToDWORD( GetVersionString );
end;

function TIPgDatabase.GetVersionString: string;
var
  res: PPGresult;
  szVer: TSDCharPtr;
  szCmd: TSDCharPtr;
  sCmd: string;
begin
  sCmd := 'select version()';
{$IFDEF SD_CLR}
  szCmd := Marshal.StringToHGlobalAnsi( sCmd );
{$ELSE}
  szCmd := TSDCharPtr( sCmd );
{$ENDIF}
  res := PQexec( PgConnPtr, szCmd);
  try
    CheckRes( res );
    szVer := PQgetvalue( res, 0, 0 );

    Result := HelperPtrToString( szVer );
  finally
    PQclear( res );
{$IFDEF SD_CLR}
    if Assigned( szCmd ) then
      Marshal.FreeHGlobal( szCmd );
{$ENDIF}
  end;
end;

function TIPgDatabase.GetPgConnPtr: PPGconn;
begin
  ASSERT( Assigned(FHandle), 'TIPgDatabase.GetPgConn' );
{$IFDEF SD_CLR}
  Result := TIPgConnInfo( Marshal.PtrToStructure( FHandle, TypeOf(TIPgConnInfo) ) ).PgConnPtr;
{$ELSE}
  Result := TIPgConnInfo(FHandle^).PgConnPtr;
{$ENDIF}
end;

function TIPgDatabase.GetHandle: TSDPtr;
begin
  Result := FHandle;
end;

procedure TIPgDatabase.SetHandle(AHandle: TSDPtr);
{$IFDEF SD_CLR}
var
  r1, r2: TIPgConnInfo;
{$ENDIF}
begin
  LoadSqlLib;

  AllocHandle;
{$IFDEF SD_CLR}
  r1 := TIPgConnInfo( Marshal.PtrToStructure( FHandle, TypeOf(TIPgConnInfo) ) );
  r2 := TIPgConnInfo( Marshal.PtrToStructure( AHandle, TypeOf(TIPgConnInfo) ) );
  r1.PgConnPtr := r2.PgConnPtr;
  Marshal.StructureToPtr( r1, FHandle, False );
{$ELSE}
  TIPgConnInfo(FHandle^).PgConnPtr := TIPgConnInfo(AHandle^).PgConnPtr;
{$ENDIF}
end;

procedure TIPgDatabase.AllocHandle;
var
  rec: TIPgConnInfo;
begin
  ASSERT( not Assigned(FHandle), 'TIPgDatabase.AllocHandle' );

  FHandle := SafeReallocMem(nil, SizeOf(rec));
  SafeInitMem( FHandle, SizeOf(rec), 0 );

  rec.ServerType := Ord( istPostgreSQL );

{$IFDEF SD_CLR}
  Marshal.StructureToPtr( rec, FHandle, False );
{$ELSE}
  TIPgConnInfo(FHandle^) := rec;
{$ENDIF}
end;

procedure TIPgDatabase.FreeHandle;
begin
  if Assigned(FHandle) then
    FHandle := SafeReallocMem( FHandle, 0 );
end;

procedure TIPgDatabase.DoConnect(const sRemoteDatabase, sUserName, sPassword: string);
var
  sSrvName, sDbName, sPortNo: string;
  szUser, szPwd, szSrv, szDb, szPortNo: TSDCharPtr;
  rec: TIPgConnInfo;
begin
  LoadSqlLib;

  AllocHandle;
	// sRemoteDatabase can be equal 'srv:port:db'
  sSrvName := ExtractServerName(sRemoteDatabase);
  sDbName := ExtractDatabaseName(sRemoteDatabase);
	// gets the custom server port
  sPortNo := ExtractServerName(sDbName);
  if sPortNo = sDbName then
    sPortNo := Params.Values[szSERVERPORT];

{$IFDEF SD_CLR}
    rec := TIPgConnInfo( Marshal.PtrToStructure( FHandle, TypeOf(TIPgConnInfo) ) );
    szSrv := Marshal.StringToHGlobalAnsi( sSrvName );
    szDb  := Marshal.StringToHGlobalAnsi( sDbName );
    if Trim(sPortNo) <> '' then
      szPortNo := Marshal.StringToHGlobalAnsi( sPortNo );
    szUser:= Marshal.StringToHGlobalAnsi( sUserName );
    szPwd := Marshal.StringToHGlobalAnsi( sPassword );
{$ELSE}
    szSrv := TSDCharPtr( sSrvName );
    szDb  := TSDCharPtr( sDbName );
    szPortNo:=TSDCharPtr( sPortNo );
    szUser:= TSDCharPtr( sUserName );
    szPwd := TSDCharPtr( sPassword );
{$ENDIF}

  try
    rec.PgConnPtr := PQsetdblogin( szSrv, szPortNo, nil, nil, szDb, szUser, szPwd );
{$IFDEF SD_CLR}
    Marshal.StructureToPtr( rec, FHandle, False );
{$ELSE}
    TIPgConnInfo(FHandle^) := rec;
{$ENDIF}
    Check( PgConnPtr );
  finally
{$IFDEF SD_CLR}
    if Assigned( szSrv ) then
      Marshal.FreeHGlobal( szSrv );
    if Assigned( szDb ) then
      Marshal.FreeHGlobal( szDb );
    if Assigned( szPortNo ) then
      Marshal.FreeHGlobal( szPortNo );
    if Assigned( szUser ) then
      Marshal.FreeHGlobal( szUser );
    if Assigned( szPwd ) then
      Marshal.FreeHGlobal( szPwd );
{$ENDIF}
  end;
end;

procedure TIPgDatabase.DoDisconnect(Force: Boolean);
{$IFDEF SD_CLR}
var
  rec: TIPgConnInfo;
{$ENDIF}
begin
  if Assigned(FHandle) and Assigned( PgConnPtr ) then begin
    if InTransaction then
      ExecCmd( 'ROLLBACK', False );
    PQfinish( PgConnPtr );
{$IFDEF SD_CLR}
    rec := TIPgConnInfo( Marshal.PtrToStructure( FHandle, TypeOf(TIPgConnInfo) ) );
    rec.PgConnPtr := nil;
    Marshal.StructureToPtr( rec, FHandle, False );
{$ELSE}
    TIPgConnInfo(FHandle^).PgConnPtr := nil;
{$ENDIF}
  end;

  FreeHandle;
  FreeSqlLib;
end;

procedure TIPgDatabase.SetAutoCommitOption(Value: Boolean);
begin
end;

procedure TIPgDatabase.DoStartTransaction;
begin
  ExecCmd( 'BEGIN', True );
end;

procedure TIPgDatabase.DoCommit;
begin
  ExecCmd( 'COMMIT', True );
end;

procedure TIPgDatabase.DoRollback;
begin
  ExecCmd( 'ROLLBACK', True );
end;

procedure TIPgDatabase.SetTransIsolation(Value: TISqlTransIsolation);
var
  sStmt: string;
begin
  sStmt := 'SET SESSION CHARACTERISTICS AS TRANSACTION ISOLATION LEVEL ';

  if Value = itiRepeatableRead then
    sStmt := sStmt + 'SERIALIZABLE'
  else
    sStmt := sStmt + 'READ COMMITTED';
  ExecCmd( sStmt, True );
end;

function TIPgDatabase.TestConnected: Boolean;
var
  cmd: TISqlCommand;
begin
  Result := False;
  cmd := CreateSqlCommand;
  try
    cmd.ExecDirect( SDummySelect );
    if Assigned(cmd) then
      Result := True;
  finally
    cmd.Free;
  end;
end;

function TIPgDatabase.GetSchemaInfo(ASchemaType: TSDSchemaType; AObjectName: string): TISqlCommand;
const
  SQueryPgStoredProcNamesFmt =
  	'select '''' as '+CAT_NAME_FIELD+', usename as '+SCH_NAME_FIELD+
        ', proname as '+PROC_NAME_FIELD+', CASE WHEN prorettype = 0 THEN 1 ELSE 2 END as '+PROC_TYPE_FIELD+
        ', pronargs as '+PROC_IN_PARAMS+', pronargs as '+ PROC_OUT_PARAMS+
        ', typname as RET_TYPE, proargtypes as ARG_TYPES'+
        ' from pg_proc, pg_shadow, pg_type st where proowner = usesysid and prorettype = st.oid %s order by usename, proname';
  SQueryPgTableNamesFmt =
  	'select '''' as '+CAT_NAME_FIELD+', usename as '+SCH_NAME_FIELD+', relname as '+TBL_NAME_FIELD+
        ', CASE relkind WHEN ''r'' THEN 1 WHEN ''v'' THEN 2 END as '+TBL_TYPE_FIELD+
        ' from pg_class, pg_user where relowner = usesysid and relkind in (''r'', ''v'') %s order by usename, relname';
  SQueryPgTableFieldNamesFmt =
  	'select '''' as '+CAT_NAME_FIELD+', usename as '+SCH_NAME_FIELD+
        ', relname as '+TBL_NAME_FIELD+', attname as '+COL_NAME_FIELD+
        ', attnum as '+COL_POS_FIELD+', 0 as '+COL_TYPE_FIELD+
        ', typname as '+COL_TYPENAME_FIELD+
        ', CASE attlen WHEN -1 THEN (CASE atttypmod WHEN -1 THEN 0 ELSE atttypmod END) ELSE CAST(attlen as integer) END as '+COL_LENGTH_FIELD+
        ', CASE WHEN attnotnull THEN 0 ELSE 1 END as '+COL_NULLABLE_FIELD+', '''' as '+COL_DEFAULT_FIELD+
        ' from pg_class so, pg_user, pg_attribute, pg_type st '+
        'where relowner = usesysid and attrelid = so.oid and relkind in (''r'', ''v'') and'+
        '  attnum > 0 and UPPER(relname) like UPPER(''%s'') and atttypid = st.oid order by usename, relname, attnum';
	// Note, CREATE INDEX command does not have ASC/DESC sort conditions (v.7.3.2)