zibsqlquery.pas

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

      else KeyType := ktUnique;
    end else KeyType := ktIndex;
    { Define a sorting mode }
    if Query.Field(4) <> '1' then SortType := stAscending
    else SortType := stDescending;

    { Put new index description }
    SqlIndices.AddIndex(Query.Field(1), Table, Query.Field(5), KeyType, SortType);
    Query.Next;
  end;
  Query.Close;
end;

{ Update record after initialization }
procedure TZCustomIbSqlDataset.UpdateAfterInit(RecordData: PRecordData);
begin
  inherited UpdateAfterInit(RecordData);

  if ioAutoIncKey in FExtraOptions then
  begin
    if FieldDescKey <> nil then
      SqlBuffer.SetField(FieldDescKey, EvaluteDef(Format('GEN_ID(%s_%s_gen, 1)',
        [SqlParser.Tables[0], FieldDescKey.Field])), RecordData);
  end;
end;

{$IFDEF WITH_IPROVIDER}
{ IProvider support }

{ Is in transaction }
function TZCustomIbSqlDataset.PSInTransaction: Boolean;
begin
  Result := True;
end;

{ Execute an sql statement }
function TZCustomIbSqlDataset.PSExecuteStatement(const ASql: string; AParams: TParams;
  ResultSet: Pointer): Integer;
begin
  if Assigned(ResultSet) then
  begin
    TDataSet(ResultSet^) := TZIbSqlQuery.Create(nil);
    with TZIbSqlQuery(ResultSet^) do
    begin
      Sql.Text := ASql;
      Params.Assign(AParams);
      Open;
      Result := RowsAffected;
    end;
  end else
    Result := TransactObj.ExecSql(ASql);
end;

{ Set command query }
procedure TZCustomIbSqlDataset.PSSetCommandText(const CommandText: string);
begin
  Close;
  if Self is TZIbSqlQuery then
    TZIbSqlQuery(Self).Sql.Text := CommandText
  else if Self is TZIbSqlTable then
    TZIbSqlQuery(Self).TableName := CommandText
  else if Self is TZIbSqlStoredProc then
    TZIbSqlStoredProc(Self).StoredProcName := CommandText;
end;

{$ENDIF}

{ TZIbSqlTable }

procedure TZIbSqlTable.InternalExecute(Sql: string);
begin
  if Assigned(TransactObj) then
  begin
    TransactObj.Connected := True;
    TransactObj.ExecSql(ConvertToSqlEnc(Sql));
  end else
    DatabaseError(STransactNotDefined);
end;

procedure TZIbSqlTable.AddIndex(const Name, Fields: string;
  Options: TIndexOptions; const DescFields: string);
var
  FieldList: string;
  Temp: string;
begin
  FieldDefs.Update;
  if Active then
  begin
    CheckBrowseMode;
    CursorPosChanged;
  end;

  FieldList := FormatFieldsList(Fields);
  if (ixPrimary in Options) then
    Temp := 'ALTER TABLE ' + ProcessIdent(TableName) + ' ADD CONSTRAINT ' +
      ProcessIdent(Name) + ' PRIMARY KEY (' + FormatFieldsList(Fields) + ')'
  else if ([ixUnique, ixDescending] * Options = [ixUnique, ixDescending]) then
    Temp := 'CREATE UNIQUE DESCENDING INDEX ' + ProcessIdent(Name) + ' ON ' +
      ProcessIdent(TableName) + ' (' + FieldList + ')'
  else if (ixUnique in Options) then
    Temp := 'CREATE UNIQUE INDEX ' + ProcessIdent(Name) + ' ON ' +
      ProcessIdent(TableName) + ' (' + FieldList + ')'
  else if (ixDescending in Options) then
    Temp := 'CREATE DESCENDING INDEX ' + ProcessIdent(Name) + ' ON ' +
      ProcessIdent(TableName) + ' (' + FieldList + ')'
  else
    Temp := 'CREATE INDEX ' + ProcessIdent(Name) + ' ON ' +
      ProcessIdent(TableName) + ' (' + FieldList + ')';
  InternalExecute(Temp);
  IndexDefs.Updated := False;
end;

procedure TZIbSqlTable.CreateTable(CreateIndexes: Boolean);
var
  FieldList: string;

  procedure InitFieldsList;
  var
    I: Integer;
  begin
    {$IFNDEF VER100}
    InitFieldDefsFromFields;
    {$ENDIF}
    for I := 0 to FieldDefs.Count - 1 do
    begin
      if I > 0 then
        FieldList := FieldList + ', ';
      with FieldDefs[I] do
      begin
        case DataType of
          ftString:
            FieldList := FieldList + ProcessIdent(Name) +
              ' VARCHAR(' + IntToStr(Size) + ')';
          {$IFNDEF VER100}
          ftFixedChar:
            FieldList := FieldList + ProcessIdent(Name) +
              ' CHAR(' + IntToStr(Size) + ')';
          {$ENDIF}
          ftBoolean, ftSmallint, ftWord:
            FieldList := FieldList + ProcessIdent(Name) + ' SMALLINT';
          ftInteger:
            FieldList := FieldList + ProcessIdent(Name) + ' INTEGER';
          ftFloat, ftCurrency:
            FieldList := FieldList + ProcessIdent(Name) + ' DOUBLE PRECISION';
          ftBCD: begin
            if (Database.SQLDialect = 1) then
            begin
              if (Precision > 9) then
                DatabaseError('Unsupported field type');
              if (Precision <= 4) then
                Precision := 9;
            end;
            if (Precision <= 4 ) then
              FieldList := FieldList + ProcessIdent(Name) + ' NUMERIC(18, 4)'
            else
              FieldList := FieldList + ProcessIdent(Name) +
                ' NUMERIC(' + IntToStr(Precision) + ', 4)';
          end;
          ftDate:
            FieldList := FieldList + ProcessIdent(Name) + ' DATE';
          ftTime:
            FieldList := FieldList + ProcessIdent(Name) + ' TIME';
          ftDateTime:
            if (Database.SQLDialect = 1) then
              FieldList := FieldList + ProcessIdent(Name) + ' DATE'
            else
              FieldList := FieldList + ProcessIdent(Name) + ' TIMESTAMP';
          {$IFNDEF VER100}
          ftLargeInt:
            if (Database.SQLDialect = 1) then
              DatabaseError('Unsupported field type')
            else
              FieldList := FieldList + ProcessIdent(Name) + ' NUMERIC(18, 0)';
          {$ENDIF}
          ftBlob, ftMemo:
            FieldList := FieldList + ProcessIdent(Name) + ' BLOB SUB_TYPE 1';
          ftBytes, ftVarBytes, ftGraphic..ftTypedBinary:
            FieldList := FieldList + ProcessIdent(Name) + ' BLOB SUB_TYPE 0';
          else
            DatabaseError('Unsupported field type');
        end;
        {$IFNDEF VER100}
        if faRequired in Attributes then
          FieldList := FieldList + ' NOT NULL';
        {$ENDIF}
      end;
    end;
  end;

  procedure InternalCreateTable;
  var
    I: Integer;
    Temp: string;
  begin
    if FieldList = '' then
      DatabaseError('Unsupported field type');

    Temp := 'CREATE TABLE ' + ProcessIdent(TableName) + ' (' + FieldList;
    for I := 0 to IndexDefs.Count - 1 do
    with IndexDefs[I] do
    begin
      if ixPrimary in Options then
        Temp := Temp + ', CONSTRAINT ' + ProcessIdent(Name)
          + ' PRIMARY KEY (' + FormatFieldsList(Fields) + ')';
    end;
    Temp := Temp + ')';
    InternalExecute(Temp);
  end;

  procedure InternalCreateIndex;
  var
    I: Integer;
  begin
    for I := 0 to IndexDefs.Count - 1 do
    with IndexDefs[I] do
      if not (ixPrimary in Options) then
        AddIndex(Name, Fields, Options, '');
  end;

begin
  CheckInactive;
  InitFieldsList;
  InternalCreateTable;
  if CreateIndexes then
    InternalCreateIndex;
end;

procedure TZIbSqlTable.DeleteTable;
begin
  InternalExecute('DROP TABLE ' + ProcessIdent(TableName));
  if Active then Close;
end;

procedure TZIbSqlTable.EmptyTable;
begin
  InternalExecute('DELETE FROM ' + ProcessIdent(TableName));
  if Active then Refresh;
end;

{************* TZIbSqlStoredProc implementation ***************}

constructor TZIbSqlStoredProc.Create(AOwner: TComponent);
begin
 inherited Create(AOwner);
 FPrepared := False;
end;


procedure TZIbSqlStoredProc.SetProcName(Value: string);
begin
  if not (csReading in ComponentState) then
  begin
    CheckInactive;
    if FProcName <> Value then
    begin
      FProcName := UpperCase(Value);
      FPrepared := False;
      //SQL.Text := '';
      if (Value <> '') and (Database <> nil) then
        Prepare;
    end;
  end
  else
    begin
      FProcName := UpperCase(Value);
      FPrepared := False;
      //SQL.Text := '';
      if (Value <> '') and (Database <> nil) then
        Prepare;
    end;
end;


function TZIbSqlStoredProc.GetisSelectProc: boolean;
const
 Suspend = 'SUSPEND';
var
 AQuery: TDirIbSqlQuery;
 Ps: string;
 d, f: integer;
begin
 Result := False;

 AQuery := TDirIbSqlQuery(Transaction.QueryHandle);
 if AQuery.Active then AQuery.Close;
 AQuery.Sql := 'Select RDB$PROCEDURE_SOURCE from RDB$PROCEDURES where ' +
  'RDB$PROCEDURE_NAME=' + QuotedStr(UpperCase(FProcName));
 try
  AQuery.Open;
  Ps := UpperCase(AQuery.Field(0));

  D := Pos(Suspend, Ps);
  F := D + length(Suspend);
  if (D > 5) and (Ps[D - 1] in [' ', ';', #10, #13]) and
   (F < length(PS) - 3) and (Ps[F + 1] in [' ', ';', #10, #13]) then
   Result := True;
 finally
  AQuery.Close;
 end;
end;

function TZIbSqlStoredProc.GetParams:TParams;
begin
  Prepare;
  Result := inherited Params;
end;

procedure TZIbSqlStoredProc.Prepare;
var
 AQuery: TDirIbSqlQuery;
 ASQL: string;
 Input: string;
 ParamName: string;
 PrmType: integer;
begin
  if FPrepared or
    not Assigned(Database) or
    not Assigned(Transaction) then exit;

  if Active then Close;

  Input := '';

  AQuery := TDirIbSqlQuery(Transaction.QueryHandle);
  if AQuery.Active then AQuery.Close;

  CreateConnections;

  AQuery.ShowProcsParams(FProcName);
 while not AQuery.EOF do
  begin
   ParamName := AQuery.Field(1);
   PrmType := StrToIntDef(AQuery.Field(2), 0);

   if PrmType = 0 then
    begin
     if input <> '' then
      input := input + ',';
     input := input + ':' + ParamName;
    end;

   AQuery.Next;
  end;

 AQuery.Close;

 FisSelectProc := GetisSelectProc;

 if FisSelectProc then
  ASQL := 'Select * From ' + ProcessIdent(FProcName)
 else
  ASQL := 'EXECUTE PROCEDURE ' + ProcessIdent(FProcName);

 if input <> '' then
  ASQL := ASQL + '(' + input + ')';

  SQL.Text := ASQL;

 FPrepared := ASQL <> '';
end;


{ Fill collection with fields }
procedure TZIbSqlStoredProc.FetchDataIntoOutputParams;
var
 I: Integer;
 ParamName: string;
 FieldType: TFieldType;
 FieldValue: Variant;
 Parami: TParam;
begin
 if not FPrepared then exit;

 if Query.FieldCount > 0 then
  for i := 0 to Query.FieldCount - 1 do
   begin
    ParamName := Query.FieldName(i);
    FieldType := Query.FieldDataType(i);
    FieldValue := TDirIbSqlQuery(Query).FieldValue(i);

{$IFNDEF VER100}
    Parami := Params.FindParam(Paramname);
{$ELSE}
    try
      Parami := Params.ParamByName(Paramname);
    except
      Parami := nil;
    end;
{$ENDIF}
    if (Parami = nil) then
     begin
      Parami := Params.CreateParam(FieldType, Paramname, ptOutput);
      Parami.AsString := FieldValue;
     end
    else
     begin
      Parami.DataType := FieldType;
      Parami.ParamType := ptOutput;
      Parami.Value := FieldValue;
     end;
   end;
end;

procedure TZIbSqlStoredProc.InternalOpen;
begin
 Prepare;

 if not FisSelectProc then
  DataBaseError('is not selected proc');

 inherited InternalOpen;
end;


procedure TZIbSqlStoredProc.ExecProc;
begin
 Prepare;

 if FisSelectProc then
  DataBaseError('is selectted proc use open');

 Open;
 try
  FetchDataIntoOutputParams;
 finally
  Close;
 end;
end;

{$IFDEF WITH_IPROVIDER}

function TZIbSqlStoredProc.PSGetTableName: string;
begin
  { ? }
end;

procedure TZIbSqlStoredProc.PSExecute;
begin
  ExecProc;
end;

{$ENDIF}

end.