fbintf/client/FBServices.pas

(*
 *  Firebird Interface (fbintf). The fbintf components provide a set of
 *  Pascal language bindings for the Firebird API. Although predominantly
 *  a new development they include source code taken from IBX and may be
 *  considered a derived product. This software thus also includes the copyright
 *  notice and license conditions from IBX.
 *
 *  Except for those parts dervied from IBX, contents of this file are subject
 *  to the Initial Developer's Public License Version 1.0 (the "License"); you
 *  may not use this file except in compliance with the License. You may obtain a
 *  copy of the License here:
 *
 *    http://www.firebirdsql.org/index.php?op=doc&id=idpl
 *
 *  Software distributed under the License is distributed on an "AS
 *  IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
 *  implied. See the License for the specific language governing rights
 *  and limitations under the License.
 *
 *  The Initial Developer of the Original Code is Tony Whyman.
 *
 *  The Original Code is (C) 2016 Tony Whyman, MWA Software
 *  (http://www.mwasoftware.co.uk).
 *
 *  All Rights Reserved.
 *
 *  Contributor(s): ______________________________________.
 *
*)
unit FBServices;
{$IFDEF MSWINDOWS} 
{$DEFINE WINDOWS} 
{$ENDIF}

{$IFDEF FPC}
{$mode delphi}
{$interfaces COM}
{$ENDIF}

interface

uses
  Classes, SysUtils, IB,  FBParamBlock, FBActivityMonitor, FBClientAPI;

type

  { TFBServiceManager }

  TFBServiceManager = class(TFBInterfacedObject)
  private
    FFirebirdAPI: IFirebirdAPI;
    FProtocol: TProtocol;
    FServerName: AnsiString;
    FPort: AnsiString;
    procedure CheckServerName;
  protected
    FSPB: ISPB;
    procedure InternalAttach(ConnectString: AnsiString); virtual; abstract;
    procedure IBDatabaseError;
  public
    constructor Create(api: TFBClientAPI; ServerName: AnsiString; Protocol: TProtocol; SPB: ISPB; Port: AnsiString = '');
    destructor Destroy; override;
  public
    {IServiceManager}
    function getFirebirdAPI: IFirebirdAPI;
    function getSPB: ISPB;
    function getServerName: AnsiString;
    function getProtocol: TProtocol;
    function getPortNo: AnsiString;
    procedure Attach;
    procedure Detach(Force: boolean=false); virtual; abstract;
    function AllocateSRB: ISRB;
    function AllocateSQPB: ISQPB;
    function Query(SQPB: ISQPB; Request: ISRB; RaiseExceptionOnError: boolean=true): IServiceQueryResults; overload; virtual; abstract;
    function Query(Request: ISRB; RaiseExceptionOnError: boolean=true): IServiceQueryResults;  overload;
  end;

 { TSPBItem }

  TSPBItem = class(TParamBlockItem,ISPBItem)
  public
   function getParamTypeName: AnsiString; override;
   class function LookupParamTypeName(ParamType: byte): AnsiString;
  end;

 { TSPB }

  TSPB = class (TCustomParamBlock<TSPBItem,ISPBItem>, ISPB)
  protected
   function LookupItemType(ParamTypeName: AnsiString): byte; override;
  public
   constructor Create(api: TFBClientAPI);
   function GetParamTypeName(ParamType: byte): Ansistring;
   function ISPB.GetDPBParamTypeName = GetParamTypeName;
  end;

implementation

uses FBMessages, IBUtils;

const
  SPBPrefix = 'isc_spb_';
  isc_spb_last_spb_constant = 13;
  SPBConstantNames: array[1..isc_spb_last_spb_constant] of String = (
    'user_name',
    'sys_user_name',
    'sys_user_name_enc',
    'password',
    'password_enc',
    'command_line',
    'db_name',
    'verbose',
    'options',
    'connect_timeout',
    'dummy_packet_interval',
    'sql_role_name',
    'expected_db'
  );

  SPBConstantValues: array[1..isc_spb_last_spb_constant] of Integer = (
    isc_spb_user_name,
    isc_spb_sys_user_name,
    isc_spb_sys_user_name_enc,
    isc_spb_password,
    isc_spb_password_enc,
    isc_spb_command_line,
    isc_spb_dbname,
    isc_spb_verbose,
    isc_spb_options,
    isc_spb_connect_timeout,
    isc_spb_dummy_packet_interval,
    isc_spb_sql_role_name,
    isc_spb_expected_db
  );

{ TSPBItem }

function TSPBItem.getParamTypeName: AnsiString;
begin
    Result := LookupParamTypeName(getParamType);
end;

class function TSPBItem.LookupParamTypeName(ParamType: byte): AnsiString;
var i: integer;
begin
  Result := '';
  for i := 1 to isc_spb_last_spb_constant do
    if SPBConstantValues [i] = ParamType then
    begin
      Result := SPBConstantNames[i];
      break;
    end;
end;

{ TFBServiceManager }

procedure TFBServiceManager.CheckServerName;
begin
  if (FServerName = '') and (FProtocol <> Local) then
    IBError(ibxeServerNameMissing, [nil]);
end;

procedure TFBServiceManager.IBDatabaseError;
begin
  raise EIBInterBaseError.Create(FFirebirdAPI.GetStatus,cp_utf8);
end;

constructor TFBServiceManager.Create(api: TFBClientAPI; ServerName: AnsiString;
  Protocol: TProtocol; SPB: ISPB; Port: AnsiString);
begin
  inherited Create;
  FFirebirdAPI := api.getAPI; {Keep reference to interface}
  FProtocol := Protocol;
  FSPB := SPB;
  FServerName := ServerName;
  FPort := Port;
  Attach;
end;

destructor TFBServiceManager.Destroy;
begin
  Detach(true);
  inherited Destroy;
end;

function TFBServiceManager.getFirebirdAPI: IFirebirdAPI;
begin
  Result := FFirebirdAPI;
end;

function TFBServiceManager.getSPB: ISPB;
begin
  Result := FSPB;
end;

function TFBServiceManager.getServerName: AnsiString;
begin
  Result := FServerName;
end;

function TFBServiceManager.getProtocol: TProtocol;
begin
  Result := FProtocol;
end;

function TFBServiceManager.getPortNo: AnsiString;
begin
  Result := FPort;
end;

procedure TFBServiceManager.Attach;
var ConnectString: AnsiString;
begin
  ConnectString := MakeConnectString(FServerName,'service_mgr',FProtocol,FPort);
  InternalAttach(ConnectString);
end;

function TFBServiceManager.AllocateSRB: ISRB;
begin
  Result := TSRB.Create(FFirebirdAPI as TFBClientAPI);
end;

function TFBServiceManager.AllocateSQPB: ISQPB;
begin
   Result := TSQPB.Create(FFirebirdAPI as TFBClientAPI);
end;

function TFBServiceManager.Query(Request: ISRB; RaiseExceptionOnError: boolean
  ): IServiceQueryResults;
begin
   Result := Query(nil,Request,RaiseExceptionOnError);
end;

{ TSPB }

function TSPB.LookupItemType(ParamTypeName: AnsiString): byte;
var i: integer;
begin
  Result := 0;
  ParamTypeName := LowerCase(ParamTypeName);
  if Pos(SPBPrefix,ParamTypeName) = 1 then
    system.Delete(ParamTypeName,1,Length(SPBPrefix));
  for i := 1 to isc_spb_last_spb_constant do
    if SPBConstantNames [i] = ParamTypeName then
    begin
      Result := SPBConstantValues[i];
      break;
    end;
end;

constructor TSPB.Create(api: TFBClientAPI);
begin
  inherited Create(api);
  FDataLength := 2;
  FBuffer^ := isc_spb_version;
  (FBuffer+1)^ := isc_spb_current_version;
end;

function TSPB.GetParamTypeName(ParamType: byte): Ansistring;
begin
  Result := TSPBItem.LookupParamTypeName(ParamType);
end;

end.

Revision:	421
Committed:	Sat Oct 21 14:22:28 2023 UTC (6 months, 1 week ago) by tony
Content type:	text/x-pascal
File size:	6778 byte(s)
Log Message:	Release 2.6.3 Merged
#	Content
1	(*
2	* Firebird Interface (fbintf). The fbintf components provide a set of
3	* Pascal language bindings for the Firebird API. Although predominantly
4	* a new development they include source code taken from IBX and may be
5	* considered a derived product. This software thus also includes the copyright
6	* notice and license conditions from IBX.
7	*
8	* Except for those parts dervied from IBX, contents of this file are subject
9	* to the Initial Developer's Public License Version 1.0 (the "License"); you
10	* may not use this file except in compliance with the License. You may obtain a
11	* copy of the License here:
12	*
13	* http://www.firebirdsql.org/index.php?op=doc&id=idpl
14	*
15	* Software distributed under the License is distributed on an "AS
16	* IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
17	* implied. See the License for the specific language governing rights
18	* and limitations under the License.
19	*
20	* The Initial Developer of the Original Code is Tony Whyman.
21	*
22	* The Original Code is (C) 2016 Tony Whyman, MWA Software
23	* (http://www.mwasoftware.co.uk).
24	*
25	* All Rights Reserved.
26	*
27	* Contributor(s): ______________________________________.
28	*
29	*)
30	unit FBServices;
31	{$IFDEF MSWINDOWS}
32	{$DEFINE WINDOWS}
33	{$ENDIF}
34
35	{$IFDEF FPC}
36	{$mode delphi}
37	{$interfaces COM}
38	{$ENDIF}
39
40	interface
41
42	uses
43	Classes, SysUtils, IB, FBParamBlock, FBActivityMonitor, FBClientAPI;
44
45	type
46
47	{ TFBServiceManager }
48
49	TFBServiceManager = class(TFBInterfacedObject)
50	private
51	FFirebirdAPI: IFirebirdAPI;
52	FProtocol: TProtocol;
53	FServerName: AnsiString;
54	FPort: AnsiString;
55	procedure CheckServerName;
56	protected
57	FSPB: ISPB;
58	procedure InternalAttach(ConnectString: AnsiString); virtual; abstract;
59	procedure IBDatabaseError;
60	public
61	constructor Create(api: TFBClientAPI; ServerName: AnsiString; Protocol: TProtocol; SPB: ISPB; Port: AnsiString = '');
62	destructor Destroy; override;
63	public
64	{IServiceManager}
65	function getFirebirdAPI: IFirebirdAPI;
66	function getSPB: ISPB;
67	function getServerName: AnsiString;
68	function getProtocol: TProtocol;
69	function getPortNo: AnsiString;
70	procedure Attach;
71	procedure Detach(Force: boolean=false); virtual; abstract;
72	function AllocateSRB: ISRB;
73	function AllocateSQPB: ISQPB;
74	function Query(SQPB: ISQPB; Request: ISRB; RaiseExceptionOnError: boolean=true): IServiceQueryResults; overload; virtual; abstract;
75	function Query(Request: ISRB; RaiseExceptionOnError: boolean=true): IServiceQueryResults; overload;
76	end;
77
78	{ TSPBItem }
79
80	TSPBItem = class(TParamBlockItem,ISPBItem)
81	public
82	function getParamTypeName: AnsiString; override;
83	class function LookupParamTypeName(ParamType: byte): AnsiString;
84	end;
85
86	{ TSPB }
87
88	TSPB = class (TCustomParamBlock<TSPBItem,ISPBItem>, ISPB)
89	protected
90	function LookupItemType(ParamTypeName: AnsiString): byte; override;
91	public
92	constructor Create(api: TFBClientAPI);
93	function GetParamTypeName(ParamType: byte): Ansistring;
94	function ISPB.GetDPBParamTypeName = GetParamTypeName;
95	end;
96
97	implementation
98
99	uses FBMessages, IBUtils;
100
101	const
102	SPBPrefix = 'isc_spb_';
103	isc_spb_last_spb_constant = 13;
104	SPBConstantNames: array[1..isc_spb_last_spb_constant] of String = (
105	'user_name',
106	'sys_user_name',
107	'sys_user_name_enc',
108	'password',
109	'password_enc',
110	'command_line',
111	'db_name',
112	'verbose',
113	'options',
114	'connect_timeout',
115	'dummy_packet_interval',
116	'sql_role_name',
117	'expected_db'
118	);
119
120	SPBConstantValues: array[1..isc_spb_last_spb_constant] of Integer = (
121	isc_spb_user_name,
122	isc_spb_sys_user_name,
123	isc_spb_sys_user_name_enc,
124	isc_spb_password,
125	isc_spb_password_enc,
126	isc_spb_command_line,
127	isc_spb_dbname,
128	isc_spb_verbose,
129	isc_spb_options,
130	isc_spb_connect_timeout,
131	isc_spb_dummy_packet_interval,
132	isc_spb_sql_role_name,
133	isc_spb_expected_db
134	);
135
136	{ TSPBItem }
137
138	function TSPBItem.getParamTypeName: AnsiString;
139	begin
140	Result := LookupParamTypeName(getParamType);
141	end;
142
143	class function TSPBItem.LookupParamTypeName(ParamType: byte): AnsiString;
144	var i: integer;
145	begin
146	Result := '';
147	for i := 1 to isc_spb_last_spb_constant do
148	if SPBConstantValues [i] = ParamType then
149	begin
150	Result := SPBConstantNames[i];
151	break;
152	end;
153	end;
154
155	{ TFBServiceManager }
156
157	procedure TFBServiceManager.CheckServerName;
158	begin
159	if (FServerName = '') and (FProtocol <> Local) then
160	IBError(ibxeServerNameMissing, [nil]);
161	end;
162
163	procedure TFBServiceManager.IBDatabaseError;
164	begin
165	raise EIBInterBaseError.Create(FFirebirdAPI.GetStatus,cp_utf8);
166	end;
167
168	constructor TFBServiceManager.Create(api: TFBClientAPI; ServerName: AnsiString;
169	Protocol: TProtocol; SPB: ISPB; Port: AnsiString);
170	begin
171	inherited Create;
172	FFirebirdAPI := api.getAPI; {Keep reference to interface}
173	FProtocol := Protocol;
174	FSPB := SPB;
175	FServerName := ServerName;
176	FPort := Port;
177	Attach;
178	end;
179
180	destructor TFBServiceManager.Destroy;
181	begin
182	Detach(true);
183	inherited Destroy;
184	end;
185
186	function TFBServiceManager.getFirebirdAPI: IFirebirdAPI;
187	begin
188	Result := FFirebirdAPI;
189	end;
190
191	function TFBServiceManager.getSPB: ISPB;
192	begin
193	Result := FSPB;
194	end;
195
196	function TFBServiceManager.getServerName: AnsiString;
197	begin
198	Result := FServerName;
199	end;
200
201	function TFBServiceManager.getProtocol: TProtocol;
202	begin
203	Result := FProtocol;
204	end;
205
206	function TFBServiceManager.getPortNo: AnsiString;
207	begin
208	Result := FPort;
209	end;
210
211	procedure TFBServiceManager.Attach;
212	var ConnectString: AnsiString;
213	begin
214	ConnectString := MakeConnectString(FServerName,'service_mgr',FProtocol,FPort);
215	InternalAttach(ConnectString);
216	end;
217
218	function TFBServiceManager.AllocateSRB: ISRB;
219	begin
220	Result := TSRB.Create(FFirebirdAPI as TFBClientAPI);
221	end;
222
223	function TFBServiceManager.AllocateSQPB: ISQPB;
224	begin
225	Result := TSQPB.Create(FFirebirdAPI as TFBClientAPI);
226	end;
227
228	function TFBServiceManager.Query(Request: ISRB; RaiseExceptionOnError: boolean
229	): IServiceQueryResults;
230	begin
231	Result := Query(nil,Request,RaiseExceptionOnError);
232	end;
233
234	{ TSPB }
235
236	function TSPB.LookupItemType(ParamTypeName: AnsiString): byte;
237	var i: integer;
238	begin
239	Result := 0;
240	ParamTypeName := LowerCase(ParamTypeName);
241	if Pos(SPBPrefix,ParamTypeName) = 1 then
242	system.Delete(ParamTypeName,1,Length(SPBPrefix));
243	for i := 1 to isc_spb_last_spb_constant do
244	if SPBConstantNames [i] = ParamTypeName then
245	begin
246	Result := SPBConstantValues[i];
247	break;
248	end;
249	end;
250
251	constructor TSPB.Create(api: TFBClientAPI);
252	begin
253	inherited Create(api);
254	FDataLength := 2;
255	FBuffer^ := isc_spb_version;
256	(FBuffer+1)^ := isc_spb_current_version;
257	end;
258
259	function TSPB.GetParamTypeName(ParamType: byte): Ansistring;
260	begin
261	Result := TSPBItem.LookupParamTypeName(ParamType);
262	end;
263
264	end.
265