zdirorasql.pas

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

      Result := FloatToStr(PDouble(SqlVar.Data)^);
    SQLT_STR:
      Result := StrPas(SqlVar.Data);
    SQLT_LVB, SQLT_LVC:
      Result := MemPas(SqlVar.Data + SizeOf(Integer), PInteger(SqlVar.Data)^);
    SQLT_DAT:
      Result := DateTimeToSqlDate(OraDateToDateTime(SqlVar.Data));
    SQLT_BLOB, SQLT_CLOB:
      begin
        with TDirOraSqlBlob.Create(Connect, Transact,
          PBlobHandle(SqlVar.Data)^) do
        try
          Result := Value;
        finally
          Free;
        end;
      end;
  end;
  DecimalSeparator := OldSep;
end;

{ Check if field is null }
function TDirOraSqlQuery.FieldIsNull(FieldNum: Integer): Boolean;
var
  SqlVar: PSqlVar;
begin
  Result := True;
  if not Active or (FieldNum >= FOutSqlVars.ActualNum) then Exit;
  SqlVar := @FOutSqlVars.Variables[FieldNum];
  Result := (SqlVar.Indicator < 0);
end;

{ Get field buffer }
function TDirOraSqlQuery.FieldBuffer(FieldNum: Integer): PChar;
var
  SqlVar: PSqlVar;
begin
  Result := nil;
  if not Active or (FieldNum >= FOutSqlVars.ActualNum) then Exit;
  SqlVar := @FOutSqlVars.Variables[FieldNum];
  if SqlVar.Indicator >= 0 then
    Result := SqlVar.Data;
end;

{ Get field type }
function TDirOraSqlQuery.FieldType(FieldNum: Integer): Integer;
begin
  Result := 0;
  if not Active or (FieldNum >= FOutSqlVars.ActualNum) then Exit;
  Result := FOutSqlVars.Variables[FieldNum].TypeCode;
end;

{ Get field delphi compatible type }
function TDirOraSqlQuery.FieldDataType(FieldNum: Integer): TFieldType;
begin
  Result := ftUnknown;
  if not Active or (FieldNum >= FOutSqlVars.ActualNum) then Exit;
  Result := FOutSqlVars.Variables[FieldNum].ColType;
end;

{ Get field count }
function TDirOraSqlQuery.FieldCount: Integer;
begin
  Result := 0;
  if Active then
    Result := FOutSqlVars.ActualNum;
end;

{ Get field maximum size }
function TDirOraSqlQuery.FieldMaxSize(FieldNum: Integer): Integer;
begin
  Result := 0;
  if not Active or (FieldNum >= FOutSqlVars.ActualNum) then Exit;
  Result := FOutSqlVars.Variables[FieldNum].DataSize;
end;

{ Get fields decimals }
function TDirOraSqlQuery.FieldDecimals(FieldNum: Integer): Integer;
begin
  Result := 0;
  if not Active or (FieldNum >= FOutSqlVars.ActualNum) then Exit;
  Result := 0;
end;

{ Get field name }
function TDirOraSqlQuery.FieldName(FieldNum: Integer): ShortString;
var
  SqlVar: PSqlVar;
  Temp: PChar;
  TempLen: Integer;
begin
  Result := '';
  if not Active or (FieldNum >= FOutSqlVars.ActualNum) then Exit;

  SqlVar := @FOutSqlVars.Variables[FieldNum];
  Temp := nil;
  OCIAttrGet(SqlVar.Handle, OCI_DTYPE_PARAM, @Temp, @TempLen,
    OCI_ATTR_NAME, FErrorHandle);
  if Temp <> nil then
    Result := MemPas(Temp, TempLen);

  if Result = '' then Result := 'Field' + IntToStr(FieldNum+1);
end;

{ Get field size }
function TDirOraSqlQuery.FieldSize(FieldNum: Integer): Integer;
begin
  Result := 0;
end;

{ Go to the first row }
procedure TDirOraSqlQuery.First;
begin
end;

{ Go to specified row }
procedure TDirOraSqlQuery.Go(Num: Integer);
begin
end;

{ Go to the last row }
procedure TDirOraSqlQuery.Last;
begin
end;

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

  Status := OCIStmtFetch(FHandle, FErrorHandle, 1, OCI_FETCH_NEXT, OCI_DEFAULT);
  case Status of
    OCI_SUCCESS:
      begin
        SetStatus(qsTuplesOk);
        SetRecNo(RecNo + 1);
        SetEOF(False);
      end;
    OCI_NO_DATA:
      begin
        SetStatus(qsTuplesOk);
        SetEOF(True);
      end;
    else
      begin
        SetEOF(True);
        TDirOraSqlTransact(Transact).CheckError(FErrorHandle, Status, FError);
      end;
  end;
end;

{ Go to prior row }
procedure TDirOraSqlQuery.Prev;
begin
end;

{ Get rows number }
function TDirOraSqlQuery.RecordCount: Integer;
begin
  if Active then
    Result := RecNo
  else Result := 0;
end;

{ Showes table columns }
procedure TDirOraSqlQuery.ShowColumns(TableName, ColumnName: ShortString);
begin
  if Active then Close;
  SQL := 'SELECT COLUMN_ID AS Idx, COLUMN_NAME AS Fld,'
    +' DATA_TYPE AS Typ, DATA_LENGTH AS Len,'
    +' NULLABLE AS Nul, DATA_DEFAULT AS Def,'
    +' DATA_SCALE AS Scale'
    +' FROM ALL_TAB_COLUMNS WHERE'
    +' TABLE_NAME='''+UpperCase(TableName)+'''';
  if ColumnName <> '' then
    SQL := SQL + ' AND COLUMN_NAME LIKE '''+UpperCase(ColumnName)+'''';
  SQL := SQL + ' ORDER BY COLUMN_ID';
  Open;
end;

{ Show existed databases }
procedure TDirOraSqlQuery.ShowDatabases(DatabaseName: ShortString);
begin
  inherited;
end;

{ Showes tables indices of database }
procedure TDirOraSqlQuery.ShowIndexes(TableName: ShortString);
begin
  if Active then Close;
  SQL := 'SELECT A.INDEX_NAME AS Name, A.TABLE_NAME AS Tbl,'
    +' A.UNIQUENESS AS Uni, A.GENERATED AS Gen, B.COLUMN_NAME AS Fld'
    +' FROM USER_INDEXES A, USER_IND_COLUMNS B'
    +' WHERE A.INDEX_NAME=B.INDEX_NAME AND A.TABLE_NAME=B.TABLE_NAME';
  if TableName <> '' then
    SQL := SQL + ' AND A.TABLE_NAME LIKE '''+ UpperCase(TableName)+'''';
  Open;
end;

{ Showes tables of database }
procedure TDirOraSqlQuery.ShowTables(TableName: ShortString);
begin
  if Active then Close;
  Sql := 'SELECT TABLE_NAME FROM ALL_TABLES WHERE';
  if TableName <> '' then
    Sql := Sql + ' TABLE_NAME LIKE '''+UpperCase(TableName)+''''
  else
    Sql := Sql + ' OWNER <> ''SYS'' AND OWNER <> ''SYSTEM''';
  Sql := Sql + ' ORDER BY TABLE_NAME';
  Open;
end;

{*************** TDirOraSqlBlob implementation ****************}

{ Class constructor }
constructor TDirOraSqlBlob.Create(AConnect: TDirConnect; ATransact: TDirTransact;
  AHandle: TBlobHandle);
begin
  inherited Create(AConnect, ATransact, AHandle);
end;

{ Get current blob position }
function TDirOraSqlBlob.GetPosition: LongInt;
begin
  Result := FPosition;
end;

{ Get blob error message }
function TDirOraSqlBlob.GetErrorMsg: ShortString;
begin
  Result := '';
  if Status <> bsOk then
    Result := FError;
end;

{ Open a blob }
procedure TDirOraSqlBlob.Open(Mode: Integer);
begin
  SetStatus(bsFail);
  if not Assigned(Connect) or not Assigned(Transact) then Exit;
  if not Connect.Active or not Transact.Active then Exit;
  if Handle.Ptr = 0 then
    CreateBlob;
  if Handle.Ptr <> 0 then
  begin
    SetStatus(bsOk);
    SetActive(True);
  end;
  FPosition := 0;
end;

{ Close current blob }
procedure TDirOraSqlBlob.Close;
begin
  SetStatus(bsFail);
  if not Assigned(Connect) or not Connect.Active then Exit;
  SetStatus(bsOk);
  SetActive(False);
//  FHandle.Ptr := 0;
  FPosition := 0;
end;

{ Create a new blob }
procedure TDirOraSqlBlob.CreateBlob;
(*
var
  OraConnect: TDirOraSqlConnect;
  OraTransact: TDirOraSqlTransact;
  LobEmpty: ub4;
  Status: Integer;
*)
begin
  SetStatus(bsFail);
  if Active then Close;
  if not Assigned(Connect) or not Connect.Active then Exit;
  if not Assigned(Transact) or not Transact.Active then Exit;
(*
  FHandle.Ptr := 0;
  OraConnect := TDirOraSqlConnect(Connect);
  OraTransact := TDirOraSqlTransact(Transact);
  Status := OCIDescriptorAlloc(OraConnect.Handle, POCIDescriptor(FHandle.Ptr),
    OCI_DTYPE_LOB, 0, nil);
  if Status = OCI_SUCCESS then
  begin
    LobEmpty := 0;
    Status := OCIAttrSet(POCIDescriptor(FHandle.Ptr), OCI_DTYPE_LOB, @LobEmpty,
      0, OCI_ATTR_LOBEMPTY, OraTransact.ErrorHandle);
    OraTransact.CheckError(OraTransact.ErrorHandle, Status, FError);
*)
    SetStatus(bsOk);
    SetActive(True);
//  end;
  FPosition := 0;
end;

{ Delete current blob }
procedure TDirOraSqlBlob.DropBlob;
(*
var
  OraTransact: TDirOraSqlTransact;
  Status: Integer;
*)
begin
  inherited DropBlob;
  if not Assigned(Transact) then Exit;
(*
  OraTransact := TDirOraSqlTransact(Transact);
  Status := OCILobTrim(OraTransact.Handle, OraTransact.ErrorHandle,
    POCIDescriptor(Handle.Ptr), 0);
  OraTransact.CheckError(OraTransact.ErrorHandle, Status, FError);
  if Status = OCI_SUCCESS then
    Close;
*)
  SetStatus(bsOk);
end;

{ Read segment from open blob }
function TDirOraSqlBlob.Read(Buffer: PChar; Length: Integer): Integer;
var
  OraTransact: TDirOraSqlTransact;
  Affected: ub4;
  Status: Integer;
begin
  Result := 0;
  SetStatus(bsFail);
  if not Assigned(Transact) then Exit;
  if not Transact.Active or not Active then Exit;

  OraTransact := TDirOraSqlTransact(Transact);
  Affected := Length;
  Status := OCILobRead(OraTransact.Handle, OraTransact.ErrorHandle,
    POCIDescriptor(Handle.Ptr), Affected, FPosition+1, Buffer, Length, nil, nil,
    0, SQLCS_IMPLICIT);
  OraTransact.CheckError(OraTransact.ErrorHandle, Status, FError);

  if Status = OCI_SUCCESS then
  begin
    Result := Affected;
    FPosition := FPosition + Affected;
    SetStatus(bsOk);
  end;
end;

{ Write segment to open blob }
function TDirOraSqlBlob.Write(Buffer: PChar; Length: Integer): Integer;
(*
var
  Affected: ub4;
  OraTransact: TDirOraSqlTransact;
  Status: Integer;
*)
begin
  Result := 0;
  SetStatus(bsFail);
  if Handle.Ptr = 0 then Exit;
  if not Assigned(Transact) then Exit;
  if not Transact.Active or not Active then Exit;
(*
  OraTransact := TDirOraSqlTransact(Transact);
  Affected := Length;
  Status := OCILobWrite(OraTransact.Handle, OraTransact.ErrorHandle,
    POCIDescriptor(Handle.Ptr), Affected, FPosition+1, Buffer, Length,
    OCI_ONE_PIECE, nil, nil, 0, SQLCS_IMPLICIT);
  OraTransact.CheckError(OraTransact.ErrorHandle, Status, FError);

  if Status = OCI_SUCCESS then
  begin
    Result := Affected;
    FPosition := FPosition + Affected;
*)
    SetStatus(bsOk);
//  end;
end;

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

{ Convert Oracle field types to delphi field types }
function OraSqlToDelphiType(Value: string; Size, Prec: Integer;
  var BlobType: TBlobType): TFieldType;
begin
  BlobType := btInternal;
  if StrCaseCmp(Value, 'NUMBER') then
  begin
    if Prec = 0 then
      Result := ftInteger
    else Result := ftFloat;
  end
  else if StrCaseCmp(Value, 'VARCHAR2') or StrCaseCmp(Value, 'CHAR')
    or StrCaseCmp(Value, 'NCHAR') or StrCaseCmp(Value, 'NVARCHAR2') then
    Result := ftString
  else if StrCaseCmp(Value, 'LONG') then
    Result := ftMemo
  else if StrCaseCmp(Value, 'CLOB') then
  begin
    Result := ftMemo;
    BlobType := btExternal;
  end
  else if StrCaseCmp(Value, 'RAW') or StrCaseCmp(Value, 'LONG RAW') then
    Result := ftBlob
  else if StrCaseCmp(Value, 'BLOB') then
  begin
    Result := ftBlob;
    BlobType := btExternal;
  end
  else if StrCaseCmp(Value, 'FLOAT') then
    Result := ftFloat
  else if StrCaseCmp(Value, 'DATE') then
    Result := ftDateTime
  else
    Result := ftUnknown;
end;

{ Convert oracle internal date to date time }
function OraDateToDateTime(Value: PChar): TDateTime;
type
  TOraDate = array[1..7] of Byte;
  POraDate = ^TOraDate;
var
  Ptr: POraDate;
begin
  Ptr := POraDate(Value);
  Result := EncodeDate((Ptr[1] - 100) * 100 + Ptr[2] - 100, Ptr[3], Ptr[4]) +
    EncodeTime(Ptr[5]-1, Ptr[6]-1, Ptr[7]-1, 0);
end;

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