zdirpgsql.pas

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

  Temp: string;
begin
  SetStatus(csFail);
  if not Assigned(Connect) or not Connect.Active then
    Exit;

  if TransactSafe then
  begin
    Result := PQexec(Handle, 'BEGIN');
    PQclear(Result);
    { Set isolation level }
    if TransIsolation <> ptDefault then
    begin
      Temp := 'SET TRANSACTION ISOLATION LEVEL ';
      case TransIsolation of
        ptReadCommitted:
          Temp := Temp + 'READ COMMITED';
        ptRepeatableRead:
          Temp := Temp + 'SERIALIZABLE';
        else
          Temp := '';
      end;
      if Temp <> '' then
      begin
        Result := PQexec(Handle, PChar(Temp));
        PQclear(Result);
        MonitorList.InvokeEvent(Temp, Error, Error <> '');
      end;
    end;

    MonitorList.InvokeEvent('BEGIN', Error, Error <> '');
  end;
  SetStatus(csOk);
end;

{ End transaction and disconnect from database }
procedure TDirPgSqlTransact.EndTransaction;
var
  Result: PPGresult;
begin
  if Active and TransactSafe then
  begin
    Result := PQexec(Handle, 'END');
    PQclear(Result);
    MonitorList.InvokeEvent('END', Error, Error <> '');
  end;
  SetStatus(csOk);
end;

{ Commit transaction }
procedure TDirPgSqlTransact.Commit;
var
  Result: PPGresult;
begin
  SetStatus(csFail);
  if not Active or not Assigned(Handle) then Exit;
  SetStatus(csOk);
  if TransactSafe then
  begin
    Result := PQexec(Handle, 'COMMIT');
    PQclear(Result);
    MonitorList.InvokeEvent('COMMIT', Error, Error <> '');

    Result := PQexec(Handle, 'BEGIN');
    PQclear(Result);
    MonitorList.InvokeEvent('BEGIN', Error, Error <> '');
    if Error <> ''  then
      SetStatus(csFail);
  end;
end;

{ Rollback transaction }
procedure TDirPgSqlTransact.Rollback;
var
  Result: PPGresult;
begin
  SetStatus(csFail);
  if not Active or not Assigned(Handle) then Exit;
  SetStatus(csOk);
  if TransactSafe then
  begin
    Result := PQexec(Handle, 'ROLLBACK');
    PQclear(Result);
    MonitorList.InvokeEvent('ROLLBACK', Error, Error <> '');

    Result := PQexec(Handle, 'BEGIN');
    PQclear(Result);
    MonitorList.InvokeEvent('BEGIN', Error, Error <> '');
    if Error <> ''  then
      SetStatus(csFail);
  end;
end;

{ Reset the connection to the backend server, i.e., disconnects then }
{ reconnects using the same parameters                               }
procedure TDirPgSqlTransact.Reset;
begin
{$IFDEF PGSQL7}
  PQresetStart(Handle)
{$ELSE}
  PQreset(Handle);
{$ENDIF}
end;

{******************* TDirPgSqlQuery implementation **********************}

{ Class constructor }
constructor TDirPgSqlQuery.Create(AConnect: TDirPgSqlConnect;
  ATransact: TDirPgSqlTransact);
begin
  inherited Create;
  Connect := AConnect;
  Transact := ATransact;
  FHandle := nil;
end;

{ Get an error message }
function TDirPgSqlQuery.GetErrorMsg: ShortString;
begin
  Result := '';
  if not (Status in [qsTuplesOk, qsCommandOk]) and Assigned(Transact) and
    Assigned(Connect) then
    Result := Trim(StrPas(PQerrorMessage(TDirPgSqlTransact(Transact).Handle)));
end;

{ Close open query }
procedure TDirPgSqlQuery.Close;
begin
  inherited Close;
  { Closing the cursor, if there is come }
  if Active and (FCursorName <> '') and Assigned(Handle) then
  begin
    PQexec(TDirPgSqlTransact(Transact).Handle,
      PChar(Format('CLOSE %s', [FCursorName])));
    FCursorName := '';
  end;

  if Assigned(Handle) then
    PQclear(Handle);
  FHandle := nil;
  SetActive(False);
  SetStatus(qsCommandOk);
end;

{ Execute the query }
function TDirPgSqlQuery.Execute: LongInt;
begin
  Result := inherited Execute;
  SetStatus(qsFail);
  FLastInsertOid := 0;
  if not Assigned(Connect) or not Assigned(Transact)
    or not (Connect.Active and Transact.Active) then
    Exit;

  FHandle := PQexec(TDirPgSqlTransact(Transact).Handle,
    PChar(ClearSpaces(Trim(Sql))));
  if Assigned(Handle) and (Transact.Error = '')  then
  begin
    SetAffectedRows(StrToIntDef(StrPas(PQcmdTuples(Handle)),0));
    Result := AffectedRows;
    FLastInsertOid := PQoidValue(Handle);
    PQclear(Handle);
    FHandle := nil;
    SetStatus(qsCommandOk);
  end
  else
  begin
    PQclear(Handle);
    FHandle := nil;
  end;
  MonitorList.InvokeEvent(Sql, Transact.Error, Status <> qsCommandOk);
end;

{ Generate a 製rsor Number }
function CursorGenerator: string;
var
  I: Integer;

{$IFNDEF LINUX}
function CreateGUID: string;
var
  ClassID: TCLSID;
  P: PWideChar;
begin
  CoCreateGuid(ClassID);
  StringFromCLSID(ClassID, P);
  Result := P;
  CoTaskMemFree(P);
end;
{$ELSE}
function CreateGUID: string;
var
  Temp: TGUID;
begin
  CreateGUID(Temp);
  Result := GUIDToString(Temp);
end;
{$ENDIF}

begin
  Result := CreateGUID;
  Delete(Result, 1, 20);
  for I := Length(Result) downto 1 do
  begin
    if Result[I] = '-' then
      Result[I] := '_';
    if Result[I] in ['{', '}'] then
      Delete(Result, I, 1);
  end;
end;

{ Open the query with result set }
procedure TDirPgSqlQuery.Open;
var
  Temp: string;
begin
  inherited Open;
  SetStatus(qsFail);
  FLastInsertOid := 0;
  if not Assigned(Connect) then
    DatabaseError(SConnectNotDefined);
  if not Assigned(Transact) then
    DatabaseError(STransactNotDefined);
  if not (Connect.Active and Transact.Active) then
    Exit;

  { If it's a select query in Cursor mode, declare a new cursor }
  FCursorName := '';
  if UseCursor then
  begin
    Temp := Sql;
    if StrCaseCmp(StrTok(Temp, ' '#9#13#10), 'SELECT') then
      FCursorName := 'ZeosCursor_' + CursorGenerator;
  end;

  if FCursorName <> '' then
  begin
    Temp := ClearSpaces(Format('DECLARE %s CURSOR FOR %s', [FCursorName, Trim(Sql)]));
    FHandle := PQexec(TDirPgSqlTransact(Transact).Handle, PChar(Temp));
    MonitorList.InvokeEvent(Temp, Transact.Error, not Active);

    Temp := Format('FETCH FORWARD 1 FROM %s', [FCursorName]);
    FHandle := PQexec(TDirPgSqlTransact(Transact).Handle, PChar(Temp));
    MonitorList.InvokeEvent(Temp, Transact.Error, not Active);
  end
  else
  begin
    FHandle := PQexec(TDirPgSqlTransact(Transact).Handle,
      PChar(ClearSpaces(Trim(Sql))));
  end;

  if Assigned(FHandle) and (Transact.Error = '') then
  begin
    SetActive(True);
    SetStatus(qsTuplesOk);
    inherited First;
  end else
    PQclear(FHandle);
  MonitorList.InvokeEvent(Sql, Transact.Error, not Active);
end;

{ Go to the first row }
procedure TDirPgSqlQuery.First;
begin
  if FCursorName = '' then
    inherited First;
end;

{ Go to specified row }
procedure TDirPgSqlQuery.Go(Num: Integer);
begin
  if FCursorName = '' then
    inherited Go(Num);
end;

{ Go to the last row }
procedure TDirPgSqlQuery.Last;
begin
  if FCursorName = '' then
    inherited Last;
end;

{ Go to next row }
procedure TDirPgSqlQuery.Next;
var
  Temp: string;
begin
  if not Active or EOF then Exit;
  SetStatus(qsFail);
  if not Assigned(Connect) or not Assigned(Transact) then
    Exit;

  if FCursorName = '' then
    inherited Next
  else begin
    Temp := Format('FETCH FORWARD 1 FROM %s', [FCursorName]);
    FHandle := PQexec(TDirPgSqlTransact(Transact).Handle, PChar(Temp));
    MonitorList.InvokeEvent(Temp, Transact.Error, not Active);

    if Assigned(FHandle) and (PQntuples(FHandle) <> 0) then
      SetRecNo(RecNo + 1)
    else SetEOF(True);
    if Transact.Error = '' then
      SetStatus(qsTuplesOk);
  end;
end;

{ Go to prior row }
procedure TDirPgSqlQuery.Prev;
begin
  if FCursorName = '' then
    inherited Prev;
end;

{ Create linked blob object }
function TDirPgSqlQuery.CreateBlobObject: TDirBlob;
var
  TempHandle: TBlobHandle;
begin
  FillChar(TempHandle, SizeOf(TBlobHandle), 0);
  Result := TDirPgSqlBlob.Create(TDirPgSqlConnect(Connect),
    TDirPgSqlTransact(Transact), TempHandle);
end;

{ Get record quantity }
function TDirPgSqlQuery.RecordCount: Integer;
begin
  if not Assigned(FHandle) then Result := 0
  else begin
    if FCursorName = '' then
      Result := PQntuples(FHandle)
    else Result := RecNo + 1;
  end;
end;

{ Get fields quantity }
function TDirPgSqlQuery.FieldCount: Integer;
begin
  if not Assigned(FHandle) then Result := 0
  else Result := PQnfields(FHandle)
end;

{ Get field name }
function TDirPgSqlQuery.FieldName(FieldNum: Integer): ShortString;
begin
  if not Assigned(FHandle) then
    Result := ''
  else
    Result := StrPas(PQfname(FHandle, FieldNum));
end;

{ Get field size }
function TDirPgSqlQuery.FieldSize(FieldNum: Integer): Integer;
begin
  if Assigned(FHandle) and (PQntuples(FHandle) > 0) then
    Result := PQgetlength(FHandle, Recno, FieldNum)
  else Result := 0;
end;

{ Get maximum field size }
function TDirPgSqlQuery.FieldMaxSize(FieldNum: Integer): Integer;
begin
  if not Assigned(FHandle) then Result := 0
  else begin
    Result := Max(PQfmod(FHandle, FieldNum)-4, 0);
    if Result = 0 then
      Result := FieldMinSize(FieldNum);
  end;
end;

{ Get minumum accepted field size }
function TDirPgSqlQuery.FieldMinSize(FieldNum: Integer): Integer;
var
  I: Integer;
begin
  Result := 0;
  if not Assigned(FHandle) then Exit;
  for I := 0 to PQntuples(FHandle)-1 do
    if PQgetlength(FHandle, I, FieldNum) > Result then
      Result := PQgetlength(FHandle, I, FieldNum);
end;

{ Get field type }
function TDirPgSqlQuery.FieldType(FieldNum: Integer): Integer;
begin
  if not Assigned(FHandle) then Result := 0
  else Result := PQftype(FHandle, FieldNum);
end;

{ Get field type name }
function TDirPgSqlQuery.FieldTypeName(FieldNum: Integer): ShortString;
begin
  if not Assigned(Transact) then
    Result := ''
  else
    Result := TDirPgSqlTransact(Transact).GetTypeName(FieldType(FieldNum));
end;

{ Define field type }
function TDirPgSqlQuery.FieldDataType(FieldNum: Integer): TFieldType;
var
  Size: Integer;
  BlobType: TBlobType;
  ArraySubType: TFieldType;
begin
  Size := 0;
  Result := PgSqlToDelphiType(FieldTypeName(FieldNum), Size, ArraySubType, BlobType);
end;

{ Get field value }
function TDirPgSqlQuery.Field(FieldNum: Integer): string;
var
  TempRecno: Integer;
begin
  if FCursorName = '' then TempRecno := Recno
  else TempRecno := 0;

  if not Assigned(FHandle) or Eof or Bof then
    Result := ''
  else begin
    Result := StrPas(PQgetvalue(FHandle, TempRecno, FieldNum));
    if FieldType(FieldNum) = 1042 then
      Result := TrimRight(Result);
  end;
end;

{ Get field buffer }
function TDirPgSqlQuery.FieldBuffer(FieldNum: Integer): PChar;
var
  TempRecno: Integer;
begin
  if FCursorName = '' then TempRecno := Recno
  else TempRecno := 0;

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