zdirpgsql.pas

控件名称：WINZEOS.ZIP 2002年08月03日 作者：CapellaDevelopment Zeos系列构件套件包含一组可直接存取Linux知名的免费数据库MySQL、Postgre

  else
    Result := PQgetvalue(FHandle, TempRecno, FieldNum);
end;

{ Is field null }
function TDirPgSqlQuery.FieldIsNull(FieldNum: Integer): Boolean;
var
  TempRecno: Integer;
begin
  if FCursorName = '' then TempRecno := Recno
  else TempRecno := 0;

  if not Assigned(FHandle) or Eof or Bof then
    Result := True
  else
    Result := PQgetisnull(FHandle, TempRecno, FieldNum) <> 0;
end;

{ Showes databases }
procedure TDirPgSqlQuery.ShowDatabases(DatabaseName: ShortString);
begin
  if Active then Close;
  Sql := 'SELECT datname as DatabaseName FROM pg_database';
  if DatabaseName <> '' then
    Sql := Sql + ' WHERE datname LIKE '''+DatabaseName+'''';
  Sql := Sql + ' ORDER BY datname';
  Open;
end;

{ Showes tables of the database }
procedure TDirPgSqlQuery.ShowTables(TableName: ShortString);
begin
  if Active then Close;
  Sql := 'SELECT pg_class.oid as Index, relname as TableName FROM pg_class WHERE'
    +' relkind = ''r'' AND relname !~''^pg_''';
  if TableName <> '' then
    Sql := Sql + ' AND lower(relname) LIKE '''+LowerCase(TableName)+'''';
  Sql := Sql + ' ORDER BY relname';
  Open;
end;

{ Showes columns of the table }
procedure TDirPgSqlQuery.ShowColumns(TableName, ColumnName: ShortString);
begin
  if Active then Close;
  { Select all columns with defaults }
  Sql := 'SELECT pg_attribute.attnum AS index, attname AS field,'
    +' typname AS type, atttypmod-4 as length, NOT attnotnull AS "null",'
    +' adsrc AS def FROM pg_attribute, pg_class, pg_type, pg_attrdef WHERE'
    +' pg_class.oid=attrelid AND pg_type.oid=atttypid AND attnum>0'
    +' AND pg_class.oid=adrelid AND adnum=attnum AND atthasdef=''t'''
    +' AND lower(relname)='''+LowerCase(TableName)+'''';
  if ColumnName <> '' then
    Sql := Sql + ' AND lower(attname) LIKE '''+LowerCase(ColumnName)+'''';

  { Select all columns without defaults }
  Sql := Sql + ' UNION SELECT pg_attribute.attnum AS index, attname AS field,'
    +' typname AS type, atttypmod-4 as length, NOT attnotnull AS "null",'
    +' '''' AS def FROM pg_attribute, pg_class, pg_type WHERE'
    +' pg_class.oid=attrelid AND pg_type.oid=atttypid AND attnum>0'
    +' AND atthasdef=''f'' AND lower(relname)='''+LowerCase(TableName)+'''';
  if ColumnName <> '' then
    Sql := Sql + ' AND lower(attname) LIKE '''+LowerCase(ColumnName)+'''';
  Open;
end;

{ Showes indexes of the table }
procedure TDirPgSqlQuery.ShowIndexes(TableName: ShortString);
begin
  if Active then Close;
  Sql := 'SELECT i.oid AS index, t1.relname AS name, t2.relname AS table,'
    +' indisunique AS "unique", indkey AS fields'
    +' FROM pg_index AS i, pg_class AS t1, pg_class AS t2 WHERE'
    +' i.indexrelid=t1.oid AND i.indrelid=t2.oid'
    +' AND lower(t2.relname)='''+LowerCase(TableName)+'''';
  Open;
end;

{ Convert string to sql format }
function TDirPgSqlQuery.StringToSql(Value: string): string;
begin
  Result := ZSqlTypes.StringToSql(Value);
end;

{**************** TDirPgSqlBlob implementation *************}

{ Class constructor }
constructor TDirPgSqlBlob.Create(AConnect: TDirPgSqlConnect;
  ATransact: TDirPgSqlTransact; AHandle: TBlobHandle);
begin
  inherited Create(AConnect, ATransact, AHandle);
  FBlobHandle := -1;
end;

{ Get current position }
function TDirPgSqlBlob.GetPosition: LongInt;
begin
  SetStatus(bsFail);
  Result := 0;
  if not Assigned(Connect) or not Assigned(Transact)
    or not (Connect.Active and Transact.Active) then
    Exit;

  Result  := lo_tell(TDirPgSqlTransact(Transact).Handle, FBlobHandle);
  SetStatus(bsOk);
end;

{ Open large object }
procedure TDirPgSqlBlob.Open(Mode: Integer);
begin
  // force read only if mode is zero
  if Mode = 0 then Mode := INV_READ;
  inherited Open(Mode);
  SetStatus(bsFail);
  if not Assigned(Connect) or not Assigned(Transact)
    or not (Connect.Active and Transact.Active) then
    Exit;

  if Handle.Ptr <> 0 then
  begin
    FBlobHandle := lo_open(TDirPgSqlTransact(Transact).Handle,
      Handle.Ptr, Mode);
    if FBlobHandle >= 0 then
    begin
      SetStatus(bsOk);
      SetActive(True);
    end;
  end else
    CreateBlob;
end;

{ Close large object }
procedure TDirPgSqlBlob.Close;
begin
  inherited Close;
  SetStatus(bsFail);
  if not Assigned(Connect) or not Assigned(Transact)
    or not (Connect.Active and Transact.Active) then
    Exit;

  if FBlobHandle >= 0 then
  begin
    lo_close(TDirPgSqlTransact(Transact).Handle, FBlobHandle);
    SetStatus(bsOk);
    FBlobHandle := -1;
  end;
  SetActive(False);
end;

{ Read from large object }
function TDirPgSqlBlob.Read(Buffer: PChar; Length: Integer): Integer;
begin
  if Assigned(Transact) and (FBlobHandle >= 0) then
  begin
    Result  := lo_read(TDirPgSqlTransact(Transact).Handle,
      FBlobHandle, Buffer, Length);
    SetStatus(bsOk);
  end
  else
  begin
    Result  := 0;
    SetStatus(bsFail);
  end;
end;

{ Write to large object }
function TDirPgSqlBlob.Write(Buffer: PChar; Length: Integer): Integer;
begin
  if Assigned(Transact) and (FBlobHandle >= 0) then
  begin
    Result  := lo_write(TDirPgSqlTransact(Transact).Handle,
      FBlobHandle, Buffer, Length);
    SetStatus(bsOk);
  end
  else
  begin
    Result  := 0;
    SetStatus(bsFail);
  end;
end;

{ Seek new position }
procedure TDirPgSqlBlob.Seek(Offset: LongInt; Origin: Integer);
begin
  if Assigned(Transact) and (FBlobHandle >= 0) then
  begin
    lo_lseek(TDirPgSqlTransact(Transact).Handle, FBlobHandle, Offset, Origin);
    SetStatus(bsOk);
  end else
    SetStatus(bsFail);
end;

{ Create new large object }
procedure TDirPgSqlBlob.CreateBlob;
var
  TempHandle: TBlobHandle;
begin
  inherited CreateBlob;
  SetStatus(bsFail);
  if not Assigned(Connect) or not Assigned(Transact)
    or not (Connect.Active and Transact.Active) then
    Exit;

  FBlobHandle := -1;
  TempHandle.Ptr := lo_creat(TDirPgSqlTransact(Transact).Handle,
    INV_WRITE or INV_READ);
  Handle := TempHandle;
  if Handle.Ptr <> 0 then
    Open(INV_WRITE);
end;

{ Unlink large object }
procedure TDirPgSqlBlob.DropBlob;
begin
  inherited DropBlob;
  SetStatus(bsFail);
  if not Assigned(Connect) or not Assigned(Transact)
    or not (Connect.Active and Transact.Active) then
    Exit;

  if Handle.Ptr = 0 then Exit;
  lo_unlink(TDirPgSqlTransact(Transact).Handle, Handle.Ptr);
  SetStatus(bsOk);
end;

{ Import from file to large object }
procedure TDirPgSqlBlob.ImportFile(FileName: ShortString);
var
  TempHandle: TBlobHandle;
begin
  SetStatus(bsFail);
  if not Assigned(Connect) or not Assigned(Transact)
    or not (Connect.Active and Transact.Active) then
    Exit;

  TempHandle.Ptr := lo_import(TDirPgSqlTransact(Transact).Handle,
    PChar(string(FileName)));
  Handle := TempHandle;
  if Handle.Ptr <> 0 then
    SetStatus(bsOk);
end;

{ Export to file from large object }
procedure TDirPgSqlBlob.ExportFile(FileName: ShortString);
begin
  SetStatus(bsFail);
  if not Assigned(Connect) or not Assigned(Transact)
    or not (Connect.Active and Transact.Active) then
    Exit;

  if Handle.Ptr <> 0 then
  begin
    lo_export(TDirPgSqlTransact(Transact).Handle, Handle.Ptr, PChar(string(FileName)));
    SetStatus(bsOk);
  end;
end;

{ **************** TDirPgSqlArray implementation *************}
(*
function TDirPgSqlArray.GetAsString: string;
begin
  Result:=''
end;

procedure TDirPgSqlArray.SetAsString(Value: string);
begin
end;
*)

{**************** TDirPgSqlNotify implementation *************}

{ Class constructor }
constructor TDirPgSqlNotify.Create(AConnect: TDirPgSqlConnect;
  ATransact: TDirPgSqlTransact);
begin
  FConnect := AConnect;
  FTransact := FTransact;
  FHandle := nil;
  FQuery := TDirPgSqlQuery.Create(AConnect, ATransact)
end;

{ Class destructor }
destructor TDirPgSqlNotify.Destroy;
begin
  FQuery.Free;
  if Assigned(FHandle) then
     PQnotifyFree(FHandle);
  inherited Destroy;
end;

{ Execute a sql query }
procedure TDirPgSqlNotify.InternalExec(Sql: string);
begin
  FQuery.Connect := FConnect;
  FQuery.Transact := FTransact;
  FQuery.Sql := Sql;
  FQuery.Execute;
  if FQuery.Status <> qsCommandOk then
    SetStatus(nsFail)
  else SetStatus(nsOk);
end;

{ Listen to a specific event }
procedure TDirPgSqlNotify.ListenTo(Event: string);
begin
  Event := Trim(Event);
  { This check is needed because otherwise the string will be silently truncated } 
  if Length(Event) > NAMEDATALEN then
    DatabaseErrorFmt(SEventLength, [Length(Event), NAMEDATALEN]);
  if Event <> '' then
    InternalExec('LISTEN ' + Event);
end;

{ Stop listening to a specific event }
procedure TDirPgSqlNotify.UnlistenTo(Event: string);
begin
  Event := Trim(Event);
  if Event <> '' then
    InternalExec('UNLISTEN ' + Event);
end;

{ Generate a notify event }
procedure TDirPgSqlNotify.DoNotify(Event: string);
begin
  Event := Trim(Event);
  if Event <> '' then
    InternalExec('NOTIFY ' + Event);
end;

{ Checks for any pending events }
function TDirPgSqlNotify.CheckEvents: string;
begin
  SetStatus(nsFail);
  Result := '';

  if not Assigned(FTransact) or not FTransact.Active then
    Exit;

  if Assigned(FHandle) then
    PQnotifyFree(FHandle);

  { Collect any asynchronous backend messages }
  PQconsumeInput(TDirPgSqlTransact(FTransact).Handle);
  FHandle := PQnotifies(TDirPgSqlTransact(FTransact).Handle);

  if Assigned(FHandle) then
    Result := StrPas(FHandle^.relname);
  SetStatus(nsOK);  
end;

{*************** Extra functions implementation ****************}

{ Convert postgresql field types to delphi field types }
function PgSqlToDelphiType(Value: string; var Size: Integer;
  var ArraySubType: TFieldType; var BlobType: TBlobType): TFieldType;
var
  IsArray: Boolean;
begin
  BlobType := btInternal;
  IsArray := False;

  { If the field name starts with '_', should an array }
  if Value[1] = '_' then
  begin
    IsArray := True;
    Delete(Value, 1, 1);
  end;
  if Size < 0 then Size := 0;
  if (Value = 'interval') or (Value = 'char')
    or (Value = 'varchar') or ((Value = 'text') and (Size > 0)) then
    Result := ftString
  else if Value = 'text' then
    Result := ftMemo
  else if Value = 'oid' then
  begin
    Result := ftBlob;
    BlobType := btExternal;
  end
  else if Value = 'int2' then
    Result := ftInteger
  else if Value = 'int4' then
    Result := ftInteger
  else if Value = 'int8' then
{$IFNDEF VER100}
    Result := ftLargeInt
{$ELSE}
    Result := ftInteger
{$ENDIF}
  else if (Value = 'float4') or (Value = 'float8')
    or (Value = 'decimal') or (Value = 'numeric') then
    Result := ftFloat
  else if Value = 'money' then
    Result := ftCurrency
  else if Value = 'bool' then
    Result := ftBoolean
  else if (Value = 'datetime') or (Value = 'timestamp') or (Value = 'abstime') then
    Result := ftDateTime
  else if Value = 'date' then
    Result := ftDate
  else if (Value = 'time') then
    Result := ftTime
  else if Value = 'name' then
  begin
    Result := ftString;
    Size := 32;
  end else if Value = 'regproc' then
  begin
    Result := ftString;
    Size := 10;
  end
  else
  begin
    Result := ftString;
    if Size <= 0 then
      Size := DEFAULT_STRING_SIZE;
  end;
  { Fixing array type and subtype }
  if IsArray then
  begin
    ArraySubType := Result;
{$IFNDEF VER100}
    Result := ftArray
{$ENDIF}
  end;
  if (Result = ftString) and (Size = 0) then
    Size := DEFAULT_STRING_SIZE;
  if Result <> ftString then Size := 0;
end;

initialization
  MonitorList := TZMonitorList.Create;
finalization
  MonitorList.Free;
end.