zdirdb2sql.pas

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

        TempDate := PSQL_DATE_STRUCT(SqlVar.Data);
        TempDate1 := EncodeDate(TempDate.year, TempDate.month, TempDate.day);
        Result := FormatSqlDate(TempDate1);
      end;
    ftTime:
      begin
        TempTime := PSQL_TIME_STRUCT(SqlVar.Data);
        TempDate1 := EncodeTime(TempTime.hour, TempTime.minute, TempTime.second, 0);
        Result := FormatSqlTime(TempDate1);
      end;
    ftDateTime:
      begin
        TempDateTime := PSQL_TIMESTAMP_STRUCT(SqlVar.Data);
        TempDate1 := EncodeDate(TempDateTime.year, TempDateTime.month,
          TempDateTime.day) + EncodeTime(TempDateTime.hour, TempDateTime.minute,
          TempDateTime.second, 0);
        Result := DateTimeToSqlDate(TempDate1);
      end;
    {$IFNDEF VER100}
    ftLargeInt:
      Result := IntToStr(PInt64(SqlVar.Data)^);
    {$ENDIF}
    ftMemo, ftBlob:
      begin
        TempHandle.Ptr := PInteger(SqlVar.Data)^;
        TempHandle.PtrEx := SqlVar.TypeCode + 1000;
        with TDirDb2SqlBlob.Create(Connect, Transact, TempHandle) do
        try
          Result := Value;
        finally
          Free;
        end;
      end;
  end;
  DecimalSeparator := OldSep;
end;

{ Check if field is null }
function TDirDb2SqlQuery.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.DataLen < 0) and (SqlVar.Data <> nil);
end;

{ Get field buffer }
function TDirDb2SqlQuery.FieldBuffer(FieldNum: Integer): PChar;
var
  SqlVar: PSqlVar;
begin
  Result := nil;

  if not Active or (FieldNum >= FOutSqlVars.ActualNum) then Exit;
  SqlVar := @FOutSqlVars.Variables[FieldNum];

  Result := SqlVar.Data;
end;

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

{ Get field type code }
function TDirDb2SqlQuery.FieldTypeCode(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 TDirDb2SqlQuery.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 TDirDb2SqlQuery.FieldCount: Integer;
begin
  Result := 0;
  if Active then
    Result := FOutSqlVars.ActualNum;
end;

{ Get field maximum size }
function TDirDb2SqlQuery.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 TDirDb2SqlQuery.FieldDecimals(FieldNum: Integer): Integer;
begin
  Result := 0;
  if not Active or (FieldNum >= FOutSqlVars.ActualNum) then Exit;
  Result := FOutSqlVars.Variables[FieldNum].Scale;
end;

{ Get field name }
function TDirDb2SqlQuery.FieldName(FieldNum: Integer): ShortString;
begin
  Result := '';

  if not Active or (FieldNum >= FOutSqlVars.ActualNum) then Exit;
  Result := FOutSqlVars.Variables[FieldNum].Name;

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

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

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

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

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

{ Go to next row }
procedure TDirDb2SqlQuery.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 := SqlFetch(FHandle);
  case Status of
    SQL_SUCCESS, SQL_SUCCESS_WITH_INFO:
      begin
        SetStatus(qsTuplesOk);
        SetRecNo(RecNo + 1);
        SetEOF(False);
      end;
    SQL_NO_DATA:
      begin
        SetStatus(qsTuplesOk);
        SetEOF(True);
      end;
    else
      begin
        SetEOF(True);
        TDirDb2SqlTransact(Transact).CheckError(SQL_HANDLE_STMT, FHandle, Status, FError);
      end;
  end;
end;

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

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

{ Showes table columns }
procedure TDirDb2SqlQuery.ShowColumns(TableName, ColumnName: ShortString);
begin
  if Active then Close;
  SQL := 'SELECT COLNO AS Idx, COLNAME AS Fld, TYPENAME AS Typ, LENGTH AS Len,'
    +' NULLS AS Nul, DEFAULT AS Def, SCALE AS Scale, IDENTITY AS Autoinc,'
    +' GENERATED AS AutoGen'
    +' FROM SYSCAT.COLUMNS WHERE'
    +' TABNAME = ''' + UpperCase(TableName) + '''';
  if ColumnName <> '' then
    SQL := SQL + ' AND COLNAME LIKE ''' + UpperCase(ColumnName) + '''';
  SQL := SQL + ' ORDER BY COLNO';
  Open;
end;

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

{ Showes tables indices of database }
procedure TDirDb2SqlQuery.ShowIndexes(TableName: ShortString);
begin
  if Active then Close;
  SQL := 'SELECT A.INDNAME AS Name, TABNAME AS Tbl, '
    + 'UNIQUERULE AS Uni, COLORDER AS Srt, COLNAME AS Fld '
    + 'FROM SYSCAT.INDEXES AS A LEFT JOIN SYSCAT.INDEXCOLUSE AS B '
    + 'ON A.INDSCHEMA=B.INDSCHEMA AND A.INDNAME=B.INDNAME ';
  if TableName <> '' then
    SQL := SQL + 'WHERE TABNAME LIKE ''' + UpperCase(TableName) + ''' ';
  SQL := SQL + ' ORDER BY A.INDNAME, COLSEQ';
  Open;
end;

{ Showes tables of database }
procedure TDirDb2SqlQuery.ShowTables(TableName: ShortString);
begin
  if Active then Close;
  Sql := 'SELECT TABNAME FROM SYSCAT.TABLES WHERE';
  if TableName <> '' then
    Sql := Sql + ' TABNAME LIKE ''' + UpperCase(TableName) + ''''
  else
    Sql := Sql + ' DEFINER <> ''SYSIBM''';
  Sql := Sql + ' ORDER BY TABNAME';
  Open;
end;

{*************** TDirDb2SqlBlob implementation ****************}

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

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

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

{ Open a blob }
procedure TDirDb2SqlBlob.Open(Mode: Integer);
var
  Status: SQLINTEGER;
  Indicator: SQLINTEGER;
begin
  SetStatus(bsFail);
  if not Assigned(Connect) or not Connect.Active then Exit;
  if not Assigned(Transact) or not Transact.Active then Exit;
  if Handle.Ptr = 0 then
    CreateBlob;
  if (Handle.Ptr <> 0) and (Mode = 0) then
  begin
    FStatementHandle := 0;
    Status := SqlAllocHandle(SQL_HANDLE_STMT, TDirDb2SqlConnect(Connect).Handle,
      @FStatementHandle);
    if not TDirDb2SqlTransact(Transact).CheckError(SQL_HANDLE_STMT,
      FStatementHandle, Status, FError) then Exit;

    if FHandle.PtrEx < 500 then
      FBlobType := FHandle.PtrEx
    else FBlobType := FHandle.PtrEx - 1000;

    Indicator := 0;

    Status := SQLGetLength(FStatementHandle, FBlobType, FHandle.Ptr,
      @FSize, @Indicator);

    if not TDirDb2SqlTransact(Transact).CheckError(SQL_HANDLE_STMT,
      FStatementHandle, Status, FError) then Exit;

    SetStatus(bsOk);
    SetActive(True);
  end;
  FPosition := 0;
end;

{ Close current blob }
procedure TDirDb2SqlBlob.Close;
begin
  SetStatus(bsFail);
  if FStatementHandle <> 0 then
    SqlFreeHandle(SQL_HANDLE_STMT, FStatementHandle);
  FStatementHandle := 0;
  SetStatus(bsOk);
  SetActive(False);
  FHandle.Ptr := 0;
  FPosition := 0;
end;

{ Create a new blob }
procedure TDirDb2SqlBlob.CreateBlob;
begin
  SetStatus(bsFail);
  if Active then Close;
  if not Assigned(Transact) or not Transact.Active then Exit;
  SetStatus(bsOk);
  SetActive(True);
  FPosition := 0;
end;

{ Delete current blob }
procedure TDirDb2SqlBlob.DropBlob;
begin
  inherited DropBlob;
  if not Assigned(Transact) or not Transact.Active then Exit;
  SetStatus(bsOk);
end;

{ Read segment from open blob }
function TDirDb2SqlBlob.Read(Buffer: PChar; Length: Integer): Integer;
var
  Db2Transact: TDirDb2SqlTransact;
  Affected: SQLINTEGER;
  Indicator: SQLINTEGER;
  Status: SQLINTEGER;
begin
  Result := 0;
  SetStatus(bsFail);
  if not Assigned(Transact) or not Transact.Active then Exit;
  if not Active or (FStatementHandle = 0) then Exit;

  Db2Transact := TDirDb2SqlTransact(Transact);

  Affected := 0;
  Indicator := 0;

  Status := SQLGetSubString(FStatementHandle, FBlobType, FHandle.Ptr,
    FPosition + 1, Min(Length, FSize - FPosition), SQL_BINARY, Buffer, Length, @Affected, @Indicator);

  if Db2Transact.CheckError(SQL_HANDLE_STMT, FStatementHandle, Status, FError) then
  begin
    Result := Affected;
    FPosition := FPosition + Affected;
    SetStatus(bsOk);
  end;
end;

{ Write segment to open blob }
function TDirDb2SqlBlob.Write(Buffer: PChar; Length: Integer): Integer;
begin
  Result := 0;
  SetStatus(bsFail);
  if Handle.Ptr = 0 then Exit;
  if not Assigned(Transact) or not Transact.Active or not Active then Exit;
  SetStatus(bsOk);
end;

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

{ Convert Db2 field types to delphi field types }
function Db2SqlToDelphiType(Value: string; Size, Prec: Integer;
  var BlobType: TBlobType): TFieldType;
begin
  BlobType := btExternal;
  if StrCaseCmp(Value, 'NUMBER') then
  begin
    if Prec = 0 then
      Result := ftInteger
    else Result := ftFloat;
  end
  else if Pos('CHAR', Value) > 0 then
    Result := ftString
  {$IFNDEF VER100}
  else if StrCaseCmp(Value, 'BIGINT') then
    Result := ftLargeInt
  {$ENDIF}
  else if Pos('INT', Value) > 0 then
    Result := ftInteger
  else if StrCaseCmp(Value, 'CLOB') then
  begin
    Result := ftMemo;
    BlobType := btExternal;
  end
  else if StrCaseCmp(Value, 'BLOB') then
  begin
    Result := ftBlob;
    BlobType := btExternal;
  end
  else if StrCaseCmp(Value, 'DOUBLE') or StrCaseCmp(Value, 'REAL') then
    Result := ftFloat
  else if StrCaseCmp(Value, 'DATE') then
    Result := ftDate
  else if StrCaseCmp(Value, 'TIME') then
    Result := ftTime
  else if StrCaseCmp(Value, 'TIMESTAMP') then
    Result := ftDateTime
  else
    Result := ftUnknown;
end;

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