home *** CD-ROM | disk | FTP | other *** search
/ Delphi Anthology / aDELPHI.iso / Runimage / Delphi50 / Source / Vcl / ibstoredproc.pas < prev    next >
Pascal/Delphi Source File  |  1999-08-11  |  15KB  |  519 lines
  1. {********************************************************}
  2. {                                                        }
  3. {       Borland Delphi Visual Component Library          }
  4. {       InterBase Express core components                }
  5. {                                                        }
  6. {       Copyright (c) 1998-1999 Inprise Corporation      }
  7. {                                                        }
  8. {    InterBase Express is based in part on the product   }
  9. {    Free IB Components, written by Gregory H. Deatz for }
  10. {    Hoagland, Longo, Moran, Dunst & Doukas Company.     }
  11. {    Free IB Components is used under license.           }
  12. {                                                        }
  13. {********************************************************}
  14.  
  15. unit IBStoredProc;
  16.  
  17. interface
  18.  
  19. uses Windows, SysUtils, Graphics, Classes, Controls, Db, StdVCL, IB,
  20.   IBDatabase, IBCustomDataSet, IBHeader, IBSQL, IBUtils;
  21.  
  22. { TIBStoredProc }
  23. type
  24.  
  25.   TIBStoredProc = class(TIBCustomDataSet)
  26.   private
  27.     FIBLoaded: Boolean;
  28.     FStmtHandle: TISC_STMT_HANDLE;
  29.     FProcName: string;
  30.     FParams: TParams;
  31.     FPrepared: Boolean;
  32.     FNameList: TStrings;
  33.     procedure SetParamsList(Value: TParams);
  34.     procedure FreeStatement;
  35.     function GetStoredProcedureNames: TStrings;
  36.     procedure GetStoredProcedureNamesFromServer;
  37.     procedure CreateParamDesc;
  38.     procedure SetParams;
  39.     procedure SetParamsFromCursor;
  40.     procedure GenerateSQL;
  41.     procedure FetchDataIntoOutputParams;
  42.     procedure ReadParamData(Reader: TReader);
  43.     procedure WriteParamData(Writer: TWriter);
  44.  
  45.   protected
  46.     { IProviderSupport }
  47.     procedure PSExecute; override;
  48.     function PSGetTableName: string; override;
  49.     function PSGetParams: TParams; override;
  50.     procedure PSSetCommandText(const CommandText: string); override;
  51.     procedure PSSetParams(AParams: TParams); override;
  52.  
  53.     procedure DefineProperties(Filer: TFiler); override;
  54.     procedure SetFiltered(Value: Boolean); override;
  55.     function GetParamsCount: Word;
  56.     procedure SetPrepared(Value: Boolean);
  57.     procedure SetPrepare(Value: Boolean);
  58.     procedure SetProcName(Value: string);
  59.     procedure Disconnect; override;
  60.     procedure InternalOpen; override;
  61.  
  62.   public
  63.     constructor Create(AOwner: TComponent); override;
  64.     destructor Destroy; override;
  65.     procedure CopyParams(Value: TParams);
  66.     procedure ExecProc;
  67.     function ParamByName(const Value: string): TParam;
  68.     procedure Prepare;
  69.     procedure UnPrepare;
  70.     property ParamCount: Word read GetParamsCount;
  71.     property StmtHandle: TISC_STMT_HANDLE read FStmtHandle;
  72.     property Prepared: Boolean read FPrepared write SetPrepare;
  73.     property StoredProcedureNames: TStrings read GetStoredProcedureNames;
  74.  
  75.   published
  76.     property StoredProcName: string read FProcName write SetProcName;
  77.     property Params: TParams read FParams write SetParamsList;
  78.   end;
  79.  
  80. implementation
  81.  
  82.  uses
  83.    IBIntf;
  84.  
  85. { TIBStoredProc }
  86.  
  87. constructor TIBStoredProc.Create(AOwner: TComponent);
  88. begin
  89.   inherited Create(AOwner);
  90.   FIBLoaded := False;
  91.   CheckIBLoaded;
  92.   FIBLoaded := True;
  93.   FParams := TParams.Create (self);
  94.   FNameList := TStringList.Create;
  95. end;
  96.  
  97. destructor TIBStoredProc.Destroy;
  98. begin
  99.   if FIBLoaded then
  100.   begin
  101.     Destroying;
  102.     Disconnect;
  103.     FParams.Free;
  104.     FNameList.Destroy;
  105.   end;
  106.   inherited Destroy;
  107. end;
  108.  
  109. procedure TIBStoredProc.Disconnect;
  110. begin
  111.   Close;
  112.   UnPrepare;
  113. end;
  114.  
  115. procedure TIBStoredProc.ExecProc;
  116. var
  117.   DidActivate: Boolean;
  118. begin
  119.   CheckInActive;
  120.   if StoredProcName = '' then
  121.     IBError(ibxeNoStoredProcName, [nil]);
  122.   ActivateConnection;
  123.   DidActivate := ActivateTransaction;
  124.   try
  125.     SetPrepared(True);
  126.     if DataSource <> nil then SetParamsFromCursor;
  127.     if FParams.Count > 0 then SetParams;
  128.     InternalExecQuery;
  129.     FetchDataIntoOutputParams;
  130.   finally
  131.     if DidActivate then
  132.       DeactivateTransaction;
  133.   end;
  134. end;
  135.  
  136. procedure TIBStoredProc.SetProcName(Value: string);
  137. begin
  138.   if not (csReading in ComponentState) then
  139.   begin
  140.     CheckInactive;
  141.     if Value <> FProcName then
  142.     begin
  143.       FProcName := Value;
  144.       FreeStatement;
  145.       FParams.Clear;
  146.       if (Value <> '') and
  147.         (Database <> nil) then
  148.         GenerateSQL;
  149.     end;
  150.   end else begin
  151.     FProcName := Value;
  152.   if (Value <> '') and
  153.     (Database <> nil) then
  154.     GenerateSQL;
  155.   end;
  156. end;
  157.  
  158. function TIBStoredProc.GetParamsCount: Word;
  159. begin
  160.   Result := FParams.Count;
  161. end;
  162.  
  163. procedure TIBStoredProc.SetFiltered(Value: Boolean);
  164. begin
  165.   if Value <> False then
  166.     IBError(ibxeNotSupported, [nil]);
  167. end;
  168.  
  169. procedure TIBStoredProc.GenerateSQL;
  170. var
  171.   Query : TIBSQL;
  172.   input : string;
  173. begin
  174.   ActivateConnection;
  175.   Database.InternalTransaction.StartTransaction;
  176.   Query := TIBSQL.Create(self);
  177.   try
  178.     Query.Database := DataBase;
  179.     Query.Transaction := Database.InternalTransaction;
  180.     Query.SQL.Text := 'SELECT RDB$PARAMETER_NAME,  RDB$PARAMETER_TYPE ' + {do not localize}
  181.                        'FROM RDB$PROCEDURE_PARAMETERS ' + {do not localize}
  182.                        'WHERE RDB$PROCEDURE_NAME = ' + {do not localize}
  183.                        '''' + FormatIdentifierValue(Database.SQLDialect, FProcName) + '''' +
  184.                        ' ORDER BY RDB$PARAMETER_NUMBER'; {do not localize}
  185.     Query.Prepare;
  186.     Query.GoToFirstRecordOnExecute := False;
  187.     Query.ExecQuery;
  188.     while (not Query.EOF) and (Query.Next <> nil) do begin
  189.       if (Query.Current.ByName('RDB$PARAMETER_TYPE').AsInteger = 0) then begin {do not localize}
  190.         if (input <> '') then
  191.           input := input + ', :' +
  192.             FormatIdentifier(Database.SQLDialect, Query.Current.ByName('RDB$PARAMETER_NAME').AsString) else {do not localize}
  193.           input := ':' +
  194.             FormatIdentifier(Database.SQLDialect, Query.Current.ByName('RDB$PARAMETER_NAME').AsString); {do not localize}
  195.       end
  196.     end;
  197.     SelectSQL.Text := 'Execute Procedure ' + {do not localize}
  198.                 FormatIdentifier(Database.SQLDialect, FProcName) + ' ' + input;
  199.   finally
  200.     Query.Free;
  201.     Database.InternalTransaction.Commit;
  202.   end;
  203. end;
  204.  
  205. procedure TIBStoredProc.CreateParamDesc;
  206. var
  207.   i : integer;
  208.   DataType : TFieldType;
  209. begin
  210.   DataType := ftUnknown;
  211.   for i := 0 to QSelect.Current.Count - 1 do begin
  212.   case QSelect.Fields[i].SQLtype of
  213.     SQL_TYPE_DATE: DataType := ftDate;
  214.     SQL_TYPE_TIME: DataType := ftTime;
  215.     SQL_TIMESTAMP: DataType := ftDateTime;
  216.     SQL_SHORT:
  217.       if ((QSelect.Fields[i].AsXSQLVar)^.sqlscale = 0) then
  218.         DataType := ftSmallInt
  219.       else
  220.         DataType := ftBCD;
  221.     SQL_LONG:
  222.       if ((QSelect.Fields[i].AsXSQLVar)^.sqlscale = 0) then
  223.         DataType := ftInteger
  224.       else if ((QSelect.Fields[i].AsXSQLVar)^.sqlscale >= (-4)) then
  225.         DataType := ftBCD
  226.       else DataType := ftFloat;
  227.     SQL_INT64:
  228.       if ((QSelect.Fields[i].AsXSQLVar)^.sqlscale = 0) then
  229.         DataType := ftLargeInt
  230.       else if ((QSelect.Fields[i].AsXSQLVar)^.sqlscale >= (-4)) then
  231.         DataType := ftBCD
  232.       else DataType := ftFloat;
  233.     SQL_DOUBLE, SQL_FLOAT, SQL_D_FLOAT: DataType := ftFloat;
  234.     SQL_TEXT: DataType := ftString;
  235.     SQL_VARYING:
  236.       if ((QSelect.Fields[i].AsXSQLVar)^.sqllen < 1024) then
  237.         DataType := ftString
  238.       else DataType := ftBlob;
  239.     SQL_BLOB, SQL_ARRAY, SQL_QUAD: DataType := ftBlob;
  240.     end;
  241.     FParams.CreateParam(DataType, Trim(QSelect.Fields[i].Name), ptOutput);
  242.   end;
  243.  
  244.   DataType := ftUnknown;
  245.   for i := 0 to QSelect.Params.Count - 1 do begin
  246.   case QSelect.Params[i].SQLtype of
  247.     SQL_TYPE_DATE: DataType := ftDate;
  248.     SQL_TYPE_TIME: DataType := ftTime;
  249.     SQL_TIMESTAMP: DataType := ftDateTime;
  250.     SQL_SHORT:
  251.       if ((QSelect.Params[i].AsXSQLVar)^.sqlscale = 0) then
  252.         DataType := ftSmallInt
  253.       else
  254.         DataType := ftBCD;
  255.     SQL_LONG:
  256.       if ((QSelect.Params[i].AsXSQLVar)^.sqlscale = 0) then
  257.         DataType := ftInteger
  258.       else if ((QSelect.Params[i].AsXSQLVar)^.sqlscale >= (-4)) then
  259.         DataType := ftBCD
  260.       else DataType := ftFloat;
  261.     SQL_INT64:
  262.       if ((QSelect.Params[i].AsXSQLVar)^.sqlscale = 0) then
  263.         DataType := ftLargeInt
  264.       else if ((QSelect.Params[i].AsXSQLVar)^.sqlscale >= (-4)) then
  265.         DataType := ftBCD
  266.       else DataType := ftFloat;
  267.     SQL_DOUBLE, SQL_FLOAT, SQL_D_FLOAT: DataType := ftFloat;
  268.     SQL_TEXT: DataType := ftString;
  269.     SQL_VARYING:
  270.       if ((QSelect.Params[i].AsXSQLVar)^.sqllen < 1024) then
  271.         DataType := ftString
  272.       else DataType := ftBlob;
  273.     SQL_BLOB, SQL_ARRAY, SQL_QUAD: DataType := ftBlob;
  274.     end;
  275.     FParams.CreateParam(DataType, Trim(QSelect.Params[i].Name), ptInput);
  276.   end;
  277. end;
  278.  
  279. procedure TIBStoredProc.SetPrepared(Value: Boolean);
  280. begin
  281.   if Prepared <> Value then
  282.   begin
  283.     if Value then
  284.       try
  285.         if SelectSQL.Text = '' then GenerateSQL;
  286.         InternalPrepare;
  287.         if FParams.Count = 0 then CreateParamDesc;
  288.         FPrepared := True;
  289.       except
  290.         FreeStatement;
  291.         raise;
  292.       end
  293.     else FreeStatement;
  294.   end;
  295.  
  296. end;
  297.  
  298. procedure TIBStoredProc.Prepare;
  299. begin
  300.   SetPrepared(True);
  301. end;
  302.  
  303. procedure TIBStoredProc.UnPrepare;
  304. begin
  305.   SetPrepared(False);
  306. end;
  307.  
  308. procedure TIBStoredProc.FreeStatement;
  309. begin
  310.   InternalUnPrepare;
  311.   FPrepared := False;
  312. end;
  313.  
  314. procedure TIBStoredProc.SetPrepare(Value: Boolean);
  315. begin
  316.   if Value then Prepare
  317.   else UnPrepare;
  318. end;
  319.  
  320. procedure TIBStoredProc.CopyParams(Value: TParams);
  321. begin
  322.   if not Prepared and (FParams.Count = 0) then
  323.   try
  324.     Prepare;
  325.     Value.Assign(FParams);
  326.   finally
  327.     UnPrepare;
  328.   end else
  329.     Value.Assign(FParams);
  330. end;
  331.  
  332. procedure TIBStoredProc.SetParamsList(Value: TParams);
  333. begin
  334.   CheckInactive;
  335.   if Prepared then
  336.   begin
  337.     SetPrepared(False);
  338.     FParams.Assign(Value);
  339.     SetPrepared(True);
  340.   end else
  341.     FParams.Assign(Value);
  342. end;
  343.  
  344. function TIBStoredProc.ParamByName(const Value: string): TParam;
  345. begin
  346.   Result := FParams.ParamByName(Value);
  347. end;
  348.  
  349. function TIBStoredProc.GetStoredProcedureNames: TStrings;
  350. begin
  351.   FNameList.clear;
  352.   GetStoredProcedureNamesFromServer;
  353.   Result := FNameList;
  354. end;
  355.  
  356. procedure TIBStoredProc.GetStoredProcedureNamesFromServer;
  357. var
  358.   Query : TIBSQL;
  359. begin
  360.   if not (csReading in ComponentState) then begin
  361.     ActivateConnection;
  362.     Database.InternalTransaction.StartTransaction;
  363.     Query := TIBSQL.Create(self);
  364.     try
  365.       Query.GoToFirstRecordOnExecute := False;
  366.       Query.Database := DataBase;
  367.       Query.Transaction := Database.InternalTransaction;
  368.       Query.SQL.Text := 'Select RDB$PROCEDURE_NAME from RDB$PROCEDURES'; {do not localize}
  369.       Query.Prepare;
  370.       Query.ExecQuery;
  371.       while (not Query.EOF) and (Query.Next <> nil) do
  372.         FNameList.Add(TrimRight(Query.Current.ByName('RDB$PROCEDURE_NAME').AsString)); {do not localize}
  373.     finally
  374.       Query.Free;
  375.       Database.InternalTransaction.Commit;
  376.     end;
  377.   end;
  378. end;
  379.  
  380. procedure TIBStoredProc.SetParams;
  381. var
  382. i : integer;
  383. j: integer;
  384. begin
  385.   i := 0;
  386.   for j := 0 to FParams.Count - 1 do
  387.   begin
  388.     if (Params[j].ParamType <> ptInput) then
  389.       continue;
  390.     if not Params[j].Bound then
  391.       IBError(ibxeRequiredParamNotSet, [nil]);
  392.     if Params[j].IsNull then
  393.       SQLParams[i].IsNull := True
  394.     else begin
  395.       SQLParams[i].IsNull := False;
  396.       case Params[j].DataType of
  397.         ftString:
  398.           SQLParams[i].AsString := Params[j].AsString;
  399.         ftBoolean, ftSmallint, ftWord:
  400.           SQLParams[i].AsShort := Params[j].AsSmallInt;
  401.         ftInteger:
  402.           SQLParams[i].AsLong := Params[j].AsInteger;
  403. {        ftLargeInt:
  404.           SQLParams[i].AsInt64 := Params[j].AsLargeInt; }
  405.         ftFloat, ftCurrency:
  406.          SQLParams[i].AsDouble := Params[j].AsFloat;
  407.         ftBCD:
  408.           SQLParams[i].AsCurrency := Params[j].AsCurrency;
  409.         ftDate:
  410.           SQLParams[i].AsDate := Params[j].AsDateTime;
  411.         ftTime:
  412.           SQLParams[i].AsTime := Params[j].AsDateTime;
  413.         ftDateTime:
  414.           SQLParams[i].AsDateTime := Params[j].AsDateTime;
  415.         ftBlob, ftMemo:
  416.           SQLParams[i].AsString := Params[j].AsString;
  417.         else
  418.           IBError(ibxeNotSupported, [nil]);
  419.       end;
  420.     end;
  421.     Inc(i);
  422.   end;
  423. end;
  424.  
  425. procedure TIBStoredProc.SetParamsFromCursor;
  426. var
  427.   I: Integer;
  428.   DataSet: TDataSet;
  429. begin
  430.   if DataSource <> nil then
  431.   begin
  432.     DataSet := DataSource.DataSet;
  433.     if DataSet <> nil then
  434.     begin
  435.       DataSet.FieldDefs.Update;
  436.       for I := 0 to FParams.Count - 1 do
  437.         with FParams[I] do
  438.           if (not Bound) and
  439.             ((ParamType = ptInput) or (ParamType =  ptInputOutput)) then
  440.             AssignField(DataSet.FieldByName(Name));
  441.     end;
  442.   end;
  443. end;
  444.  
  445. procedure TIBStoredProc.FetchDataIntoOutputParams;
  446. var
  447. i,j : Integer;
  448. begin
  449.   j := 0;
  450.   for i := 0 to FParams.Count - 1 do
  451.     with Params[I] do
  452.       if ParamType = ptOutput then begin
  453.          Value := QSelect.Fields[j].Value;
  454.          Inc(j);
  455.       end;
  456. end;
  457.  
  458. procedure TIBStoredProc.InternalOpen;
  459. begin
  460.   IBError(ibxeIsAExecuteProcedure,[nil]);
  461. end;
  462.  
  463. procedure TIBStoredProc.DefineProperties(Filer: TFiler);
  464.  
  465.   function WriteData: Boolean;
  466.   begin
  467.     if Filer.Ancestor <> nil then
  468.       Result := not FParams.IsEqual(TIBStoredProc(Filer.Ancestor).FParams) else
  469.       Result := FParams.Count > 0;
  470.   end;
  471.  
  472. begin
  473.   inherited DefineProperties(Filer);
  474.   Filer.DefineProperty('ParamData', ReadParamData, WriteParamData, WriteData); {do not localize}
  475. end;
  476.  
  477. procedure TIBStoredProc.WriteParamData(Writer: TWriter);
  478. begin
  479.   Writer.WriteCollection(Params);
  480. end;
  481.  
  482. procedure TIBStoredProc.ReadParamData(Reader: TReader);
  483. begin
  484.   Reader.ReadValue;
  485.   Reader.ReadCollection(Params);
  486. end;
  487.  
  488. { TIBStoredProc IProviderSupport }
  489.  
  490. function TIBStoredProc.PSGetParams: TParams;
  491. begin
  492.   Result := Params;
  493. end;
  494.  
  495. procedure TIBStoredProc.PSSetParams(AParams: TParams);
  496. begin
  497.   if AParams.Count > 0 then
  498.     Params.Assign(AParams);
  499.   Close;
  500. end;
  501.  
  502. function TIBStoredProc.PSGetTableName: string;
  503. begin
  504.   { ! }
  505. end;
  506.  
  507. procedure TIBStoredProc.PSExecute;
  508. begin
  509.   ExecProc;
  510. end;
  511.  
  512. procedure TIBStoredProc.PSSetCommandText(const CommandText: string);
  513. begin
  514.   if CommandText <> '' then
  515.     StoredProcName := CommandText;
  516. end;
  517.  
  518. end.
  519.