zdiribsql.pas

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

            Currency(Buffer) := tmpCurrency;
          end
        else
          begin
            tmpDouble := PLongInt(SqlVar.sqldata)^
              * IntPower(10, SqlVar.sqlscale);
            Double(Buffer) := tmpDouble;
          end
      end;
    SQL_SHORT:
      begin
        if SqlVar.sqlscale = 0 then
          SmallInt(Buffer) := PSmallInt(SqlVar.sqldata)^
        else
        begin
          tmpCurrency := PSmallInt(SqlVar.sqldata)^
            * IntPower(10, SqlVar.sqlscale);
          Currency(Buffer) := tmpCurrency;
        end;
      end;
    SQL_DOUBLE:
      Double(Buffer) := PDouble(SqlVar.sqldata)^;
    SQL_D_FLOAT:
      Double(Buffer) := PDouble(SqlVar.sqldata)^;
    SQL_FLOAT:
      Single(Buffer) := PSingle(SqlVar.sqldata)^;
    SQL_TYPE_TIME:
      begin
        isc_decode_sql_time(PISC_TIME(SqlVar.sqldata), @TempDate);
        TempTime := EncodeTime(Word(TempDate.tm_hour), Word(TempDate.tm_min),
          Word(TempDate.tm_sec), 0);
        TDateTime(Buffer) := TempTime;
      end;
    SQL_TYPE_DATE:
      begin
        isc_decode_sql_date(PISC_DATE(SqlVar.sqldata), @TempDate);
        TempTime :=
          EncodeDate(Word(TempDate.tm_year + 1900), Word(TempDate.tm_mon + 1),
          Word(TempDate.tm_mday));
       TDateTime(Buffer) := TempTime;
      end;
{$IFNDEF VER100}
    SQL_INT64:
      begin
        if SqlVar.sqlscale = 0 then
          Int64(Buffer) := PInt64(SqlVar.sqldata)^
        else if Abs(SqlVar.sqlscale) <= 4 then
        begin
          tmpCurrency := PInt64(SqlVar.sqldata)^
            * IntPower(10, SqlVar.sqlscale);
          Currency(Buffer) := tmpCurrency;
        end
        else
        begin
          tmpDouble := PInt64(SqlVar.sqldata)^
            * IntPower(10, SqlVar.sqlscale);
          Double(Buffer) := tmpDouble;
        end;
      end;
{$ENDIF}
    SQL_QUAD: TISC_QUAD(Buffer) := PISC_QUAD(SqlVar.sqldata)^;
    SQL_DATE:
      begin
        isc_decode_date(PISC_QUAD(SqlVar.sqldata), @TempDate);
        TempTime := EncodeDate(TempDate.tm_year + 1900,
          TempDate.tm_mon + 1, TempDate.tm_mday) + EncodeTime(TempDate.tm_hour,
          TempDate.tm_min, TempDate.tm_sec, 0);
        TDateTime(Buffer) := TempTime;
      end;
    //SQL_ARRAY: Result := '(ARRAY)';
    SQL_BLOB:
      begin
       TISC_QUAD(Buffer) := PISC_QUAD(SqlVar.sqldata)^;
      end;
  end;
  DecimalSeparator := OldSep;
end;

{ Check if field is Null }
function TDirIbSqlQuery.FieldIsNull(FieldNum: Integer): Boolean;
var
  SqlVar: PXSQLVAR;
  VarType: Short;
begin
  Result := True;
  SqlVar := @FOutSqlDa.SqlVar[FieldNum];
  if not Active then Exit;
  VarType := SqlVar.sqltype;
  Result := ((VarType and 1) <> 0) and (SqlVar.sqlind <> nil)
    and ((SqlVar.sqlind^) = ISC_NULL);
end;

{ Check if field is ReadOnly }
function TDirIbSqlQuery.FieldReadOnly(FieldNum: Integer): boolean;
begin
  Result := false;
  if not Active then Exit;

  with FOutSqlDa.SqlVar[FieldNum] do
    Result := (RelName = '') or (SqlName = '') or {(SqlName = 'DB_KEY') or}
      (SqlName = 'RDB$DB_KEY');

(*
  if not Result then
  tmpQuery:=TDirIbSqlQuery.Create(Connect as TDirIbSqlConnect, Transact as TDirIbSqlTransact);
  try
   tmpQuery.SQL :='SELECT RDB$COMPUTED_BLR '
     + ' FROM RDB$RELATION_FIELDS A LEFT JOIN RDB$FIELDS B'
     + ' ON A.RDB$FIELD_SOURCE=B.RDB$FIELD_NAME WHERE'
     + ' A.RDB$RELATION_NAME=' + Quotedstr(FOutSqlDa.SqlVar[FieldNum].relname)
     + ' AND A.RDB$FIELD_NAME='+ Quotedstr(FOutSqlDa.SqlVar[FieldNum].sqlname);
   tmpQuery.Open;
   Result:=not tmpQuery.FieldIsNull(0);
  finally
   tmpQuery.Free;
  end;
*)
end;

{ Get field buffer }
function TDirIbSqlQuery.FieldBuffer(FieldNum: Integer): PChar;
var
  SqlVar: PXSQLVAR;
begin
  Result := nil;
  if not Active then Exit;
  SqlVar := @FOutSqlDa.SqlVar[FieldNum];
  if ((SqlVar.sqltype and 1) = 0) or ((SqlVar.sqlind^) <> -1) then
    Result := SqlVar.sqldata;
end;

{ Get field type }
function TDirIbSqlQuery.FieldType(FieldNum: Integer): Integer;
begin
  Result := 0;
  if not Active then Exit;
  Result := FOutSqlDa.SqlVar[FieldNum].sqltype and (not 1);
end;

{ Get field subtype }
function TDirIbSqlQuery.FieldSubType(FieldNum: Integer): Integer;
begin
  Result := 0;
  if not Active then Exit;
  Result := FOutSqlDa.SqlVar[FieldNum].sqlsubtype;
end;

{ Get field delphi compatible type }
function TDirIbSqlQuery.FieldDataType(FieldNum: Integer): TFieldType;
var
  ASqlScale: Integer;
  ASqlSubType: Integer;
begin
  Result := ftUnknown;
  if not Active then Exit;

  ASqlScale := FOutSqlDa.SqlVar[FieldNum].sqlscale;
  ASqlSubType := FOutSqlDa.SqlVar[FieldNum].sqlsubtype;

  case (FOutSqlDa.SqlVar[FieldNum].sqltype and (not 1)) of
    SQL_VARYING, SQL_TEXT: Result := ftString;
    SQL_LONG {$IFDEF VER100}, SQL_INT64{$ENDIF}:
      begin
        if ASqlScale = 0 then
          Result := ftInteger
        else if Abs(ASqlScale) <= 4 then
          Result := ftBCD
        else
          Result := ftFloat;
      end;
    SQL_SHORT:
      begin
        if ASqlScale = 0 then
          Result := ftSmallInt
        else Result := ftBCD;
      end;
    SQL_DOUBLE, SQL_FLOAT: Result := ftFloat;
    SQL_DATE: Result := ftDateTime;
    SQL_TYPE_TIME: Result := ftTime;
    SQL_TYPE_DATE: Result := ftDate;
{$IFNDEF VER100}
    SQL_INT64:
      begin
        if ASqlScale = 0 then
          Result := ftLargeInt
        else if Abs(ASqlScale) <= 4 then
          Result := ftBCD
        else
          Result := ftFloat;
      end;
{$ENDIF}
    SQL_BLOB:
      begin
        if ASqlSubType = isc_blob_text then
          Result := ftMemo
        else Result := ftBlob;
      end;
    //SQL_ARRAY: Result := ftArray;
    else Result := ftString;
  end;
end;

{ Get field count }
function TDirIbSqlQuery.FieldCount: Integer;
begin
  Result := 0;
  if not Active then Exit;
  Result := FOutSqlDa.sqld;
end;

{ Get field maximum size }
function TDirIbSqlQuery.FieldMaxSize(FieldNum: Integer): Integer;
begin
  Result := 0;
  if not Active then Exit;
  Result := FOutSqlDa.SqlVar[FieldNum].sqllen;
end;

{ Get fields decimals }
function TDirIbSqlQuery.FieldDecimals(FieldNum: Integer): Integer;
begin
  Result := 0;
  if not Active then Exit;
  Result := -FOutSqlDa.SqlVar[FieldNum].sqlscale;
end;

{ Get field name }
function TDirIbSqlQuery.FieldName(FieldNum: Integer): ShortString;
begin
  Result := '';
  if not Active then Exit;
  Result := MemPas(FOutSqlDa.SqlVar[FieldNum].aliasname,
    FOutSqlDa.SqlVar[FieldNum].aliasname_length);
  if Result = '' then Result := 'Field' + IntToStr(FieldNum + 1);
end;

{ Get field size }
function TDirIbSqlQuery.FieldSize(FieldNum: Integer): Integer;
begin
  Result := 0;
  if not Active then Exit;
  Result := FOutSqlDa.SqlVar[FieldNum].sqllen;
  if (FOutSqlDa.SqlVar[FieldNum].sqltype and (not 1)) = SQL_VARYING then
    Result := PSmallInt(FOutSqlDa.SqlVar[FieldNum].sqldata)^;
end;

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

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

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

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

  IbConnect := TDirIbSqlConnect(Connect);
  FetchStat := isc_dsql_fetch(@IbConnect.FStatusVector, @FHandle,
    IbConnect.Dialect, FOutSqlDa);

  if not IbConnect.HasError then
  begin
    SetStatus(qsTuplesOk);
    SetEOF(FetchStat <> 0);
    if FetchStat = 0 then
      SetRecNo(RecNo + 1);
  end else
    SetEOF(True);
end;

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

{ Get rows number }
function TDirIbSqlQuery.RecordCount: Integer;
var
  IbConnect: TDirIbSqlConnect;
  InBuf: Char;
  OutBuf: array[0..10] of Char;
begin
  Result := 0;
  if Active then
  begin
    IbConnect := TDirIbSqlConnect(Connect);
    InBuf := Chr(isc_info_sql_records);
    isc_dsql_sql_info(@IbConnect.FStatusVector, @FHandle, 1, @InBuf,
      SizeOf(OutBuf), OutBuf);
    if OutBuf[0] = Chr(isc_info_sql_records) then
      Result := isc_vax_integer(OutBuf + 1, 4)
    else
      Result := RecNo;
  end;
end;

{ Showes table columns }
procedure TDirIbSqlQuery.ShowColumns(TableName, ColumnName: ShortString);
begin
  if Active then Close;
  SQL := 'SELECT RDB$FIELD_POSITION AS Idx, A.RDB$FIELD_NAME AS Fld,'
    + ' B.RDB$FIELD_TYPE AS Typ, B.RDB$FIELD_LENGTH AS Len,'
    + ' A.RDB$NULL_FLAG AS Nul, A.RDB$DEFAULT_SOURCE AS Def,'
    + ' -B.RDB$FIELD_SCALE AS Scale, B.RDB$FIELD_SUB_TYPE SubType,'
    + ' RDB$COMPUTED_BLR COMPFLD,'
    + ' A.RDB$QUERY_NAME DL'
    + ' FROM RDB$RELATION_FIELDS A LEFT JOIN RDB$FIELDS B'
    + ' ON A.RDB$FIELD_SOURCE=B.RDB$FIELD_NAME WHERE'
    + ' A.RDB$RELATION_NAME=''' + UpperCase(TableName) + '''';
  if ColumnName <> '' then
    SQL := SQL + ' AND A.RDB$FIELD_NAME LIKE ''' + UpperCase(ColumnName) + '''';
  SQL := SQL + ' ORDER BY RDB$FIELD_POSITION';
  Open;
end;

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

{ Showes tables indices of database }
procedure TDirIbSqlQuery.ShowIndexes(TableName: ShortString);
begin
  if Active then Close;
  SQL := 'SELECT RDB$INDEX_ID AS Idx, A.RDB$INDEX_NAME AS Name, RDB$RELATION_NAME'
    + ' AS Tbl, RDB$UNIQUE_FLAG AS Uni, RDB$INDEX_TYPE AS Srt, RDB$FIELD_NAME AS Fld'
    + ' FROM RDB$INDICES A LEFT JOIN RDB$INDEX_SEGMENTS B'
    + ' ON A.RDB$INDEX_NAME=B.RDB$INDEX_NAME WHERE';
  if TableName <> '' then
    //SQL := SQL + ' RDB$RELATION_NAME LIKE ''' + UpperCase(TableName) + ' %'''
    SQL := SQL + ' RDB$RELATION_NAME = ''' + UpperCase(TableName)+''''
  else
    SQL := SQL + ' RDB$INDEX_NAME NOT LIKE ''RDB$%''';
  Open;
end;

{ Showes tables of database }
procedure TDirIbSqlQuery.ShowTables(TableName: ShortString);
begin
  if Active then Close;
  Sql := 'SELECT RDB$RELATION_ID AS Idx, RDB$RELATION_NAME AS TableName'
    + ' FROM RDB$RELATIONS WHERE';
  if TableName <> '' then
    Sql := Sql + ' RDB$RELATION_NAME LIKE ''' + UpperCase(TableName) + ''''
  else
    Sql := Sql + ' RDB$RELATION_NAME NOT LIKE ''RDB$%''';
  Sql := Sql + ' ORDER BY RDB$RELATION_NAME';
  Open;
end;

{ Showes Procs of database }
procedure TDirIbSqlQuery.ShowProcs(ProcName: ShortString);
begin
  if Active then Close;
  Sql := 'SELECT RDB$PROCEDURE_ID AS Idx, RDB$PROCEDURE_NAME AS ProcName'
    + ' FROM RDB$PROCEDURES WHERE';
  if ProcName <> '' then
    Sql := Sql + ' RDB$PROCEDURE_NAME LIKE ''' + UpperCase(ProcName) + ''''
  else
    Sql := Sql + ' RDB$PROCEDURE_NAME NOT LIKE ''RDB$%''';
  Sql := Sql + ' ORDER BY RDB$PROCEDURE_NAME';
  Open;
end;

{ Showes Proc Params }
procedure TDirIbSqlQuery.ShowProcsParams(ProcName: ShortString);
begin
  if Active then Close;
  SQL := 'SELECT A.RDB$PARAMETER_NUMBER AS Idx, A.RDB$PARAMETER_NAME AS Fld,'
    + ' A.RDB$PARAMETER_TYPE PTyp,'
    + ' B.RDB$FIELD_TYPE AS Typ, B.RDB$FIELD_LENGTH AS Len,'
    + ' B.RDB$NULL_FLAG AS Nul, B.RDB$DEFAULT_SOURCE AS Def,'
    + ' -B.RDB$FIELD_SCALE AS Scale,'
    + ' B.RDB$FIELD_SUB_TYPE SubType,'
    + ' B.RDB$QUERY_NAME DL'
    + ' FROM RDB$PROCEDURE_PARAMETERS A LEFT JOIN RDB$FIELDS B'
    + ' ON A.RDB$FIELD_SOURCE=B.RDB$FIELD_NAME WHERE'
    + ' A.RDB$PROCEDURE_NAME=''' + UpperCase(ProcName) + '''';
  SQL := SQL + ' ORDER BY A.RDB$PARAMETER_TYPE,A.RDB$PARAMETER_NUMBER';
  Open;
end;

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

{*************** TDirIbSqlBlob implementation ****************}

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

{ Open a blob }
procedure TDirIbSqlBlob.Open(Mode: Integer);
var
  IbConnect: TDirIbSqlConnect;
  IbTransact: TDirIbSqlTransact;
begin
  SetStatus(bsFail);
  if not Assigned(Connect) or not Assigned(Transact) then
    Exit;
  if not Connect.Active or not Transact.Active then
    Exit;

  if Active then Close;
  IbConnect := TDirIbSqlConnect(Connect);
  IbTransact := TDirIbSqlTransact(Transact);

  if Mode = fmOpenRead then
  begin
    FBlobHandle := nil;
    isc_open_blob2(@IbConnect.FStatusVector, @IbConnect.FHandle, @IbTransact.FHandle,
      @FBlobHandle, @Handle, 0, nil);
    if not IbConnect.HasError then
    begin
      SetStatus(bsOk);
      SetActive(True);
    end;
  end
  else if Mode = fmOpenWrite then
    CreateBlob;
end;

{ Close current blob }
procedure TDirIbSqlBlob.Close;
var
  IbConnect: TDirIbSqlConnect;
begin
  SetStatus(bsFail);
  if not Assigned(Connect) or not Connect.Active then
    Exit;

  if Active then
  begin
    IbConnect := TDirIbSqlConnect(Connect);
    isc_close