Skip to content

Commit 2e257e0

Browse files
andotandot
committed
Added Delphi/Lazarus Server.
1 parent ac2657c commit 2e257e0

File tree

4 files changed

+1300
-0
lines changed

4 files changed

+1300
-0
lines changed

‎Source/HproseServer.pas

Lines changed: 296 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,296 @@
1+
unit HproseServer;
2+
3+
{$I Hprose.inc}
4+
5+
interface
6+
7+
uses
8+
Classes, SysUtils, Variants, HproseCommon, HproseIO;
9+
10+
type
11+
12+
THproseServer = class;
13+
14+
TResultMode = (rmNormal, rmSerialized, rmRaw, rmRawWithEndTag);
15+
TMethodType = (mtProc, mtFunc, mtProcArgs, mtFuncArgs);
16+
17+
TInvokeFunction00 = procedure;
18+
TInvokeFunction01 = function: Variant;
19+
TInvokeFunction10 = procedure(Args: Variant);
20+
TInvokeFunction11 = function(Args: Variant): Variant;
21+
22+
TInvokeMethod00 = procedure of object;
23+
TInvokeMethod01 = function: Variant of object;
24+
TInvokeMethod10 = procedure(Args: Variant) of object;
25+
TInvokeMethod11 = function(Args: Variant): Variant of object;
26+
27+
TBeforeInvokeEvent = procedure(Name: string; Args: Variant; ByRef: Boolean) of object;
28+
TAfterInvokeEvent = procedure(Name: string; Args: Variant; ByRef: Boolean; Result: Variant) of object;
29+
30+
TErrorEvent = procedure(Error: Exception) of object;
31+
32+
THproseMethod = class
33+
private
34+
FMethod: TMethod;
35+
FMethodType: TMethodType;
36+
public
37+
constructor Create(Method: TMethod; MethodType: TMethodType);
38+
function Invoke(Args: Variant): Variant;
39+
end;
40+
41+
THproseServer = class(TComponent)
42+
private
43+
FMethods: THashMap;
44+
FMethodNames: THashMap;
45+
FResultMode: THashMap;
46+
FDebug: Boolean;
47+
FOnBeforeInvoke: TBeforeInvokeEvent;
48+
FOnAfterInvoke: TAfterInvokeEvent;
49+
FOnSendError: TErrorEvent;
50+
procedure AddMethod(Method: TMethod; MethodType: TMethodType; AliasName: string; ResultMode: TResultMode);overload;
51+
protected
52+
procedure DoFunctionList(OutStream: TStream);
53+
procedure DoInvoke(InStream: TStream; OutStream: TStream);
54+
procedure HandleCommand(InStream: TStream; OutStream: TStream);
55+
public
56+
constructor Create(AOwner: TComponent); override;
57+
destructor Destroy; override;
58+
procedure AddFunction(Func: Pointer; MethodType: TMethodType; FuncName: string; ResultMode: TResultMode = rmNormal);
59+
procedure AddMethod(Cls: TClass; MethodName: string; MethodType: TMethodType; AliasName: string = ''; ResultMode: TResultMode = rmNormal); overload;
60+
procedure AddMethod(Obj: TObject; MethodName: string; MethodType: TMethodType; AliasName: string = ''; ResultMode: TResultMode = rmNormal); overload;
61+
published
62+
property DebugEnabled: Boolean read FDebug write FDebug default False;
63+
property OnBeforeInvoke: TBeforeInvokeEvent read FOnBeforeInvoke write FOnBeforeInvoke;
64+
property OnAfterInvoke: TAfterInvokeEvent read FOnAfterInvoke write FOnAfterInvoke;
65+
property OnSendError: TErrorEvent read FOnSendError write FOnSendError;
66+
end;
67+
68+
implementation
69+
70+
uses
71+
TypInfo;
72+
73+
{ THproseMethod }
74+
75+
constructor THproseMethod.Create(Method: TMethod; MethodType: TMethodType);
76+
begin
77+
FMethod := Method;
78+
FMethodType := MethodType;
79+
end;
80+
81+
function THproseMethod.Invoke(Args: Variant): Variant;
82+
begin
83+
if FMethod.Data = nil then
84+
case FMethodType of
85+
mtProc:
86+
TInvokeFunction00(FMethod.Code)();
87+
mtFunc:
88+
Result := TInvokeFunction01(FMethod.Code)();
89+
mtProcArgs:
90+
TInvokeFunction10(FMethod.Code)(Args);
91+
mtFuncArgs:
92+
Result := TInvokeFunction11(FMethod.Code)(Args);
93+
end
94+
else
95+
case FMethodType of
96+
mtProc:
97+
TInvokeMethod00(FMethod)();
98+
mtFunc:
99+
Result := TInvokeMethod01(FMethod)();
100+
mtProcArgs:
101+
TInvokeMethod10(FMethod)(Args);
102+
mtFuncArgs:
103+
Result := TInvokeMethod11(FMethod)(Args);
104+
end;
105+
end;
106+
107+
{ THproseServer }
108+
109+
constructor THproseServer.Create(AOwner: TComponent);
110+
begin
111+
inherited Create(AOwner);
112+
FMethods := TCaseInsensitiveHashedMap.Create;
113+
FMethodNames := TCaseInsensitiveHashedMap.Create;
114+
FResultMode := TCaseInsensitiveHashedMap.Create;
115+
end;
116+
117+
destructor THproseServer.Destroy;
118+
var
119+
Enum: IListEnumerator;
120+
begin
121+
Enum := FMethods.Values.GetEnumerator;
122+
while Enum.MoveNext do
123+
THproseMethod(Integer(Enum.Current)).Free;
124+
FMethods.Free;
125+
FMethodNames.Free;
126+
FResultMode.Free;
127+
inherited;
128+
end;
129+
130+
procedure THproseServer.AddMethod(Method: TMethod; MethodType: TMethodType;
131+
AliasName: string; ResultMode: TResultMode);
132+
begin
133+
FMethods[AliasName] := Integer(THproseMethod.Create(Method, MethodType));
134+
//FMethodNames[AliasName] := MethodName;
135+
FResultMode[AliasName] := ResultMode;
136+
end;
137+
138+
procedure THproseServer.AddFunction(Func: Pointer; MethodType: TMethodType;
139+
FuncName: string; ResultMode: TResultMode);
140+
var
141+
Method: TMethod;
142+
begin
143+
if Func <> nil then
144+
begin
145+
Method.Code := Func;
146+
Method.Data := nil;
147+
AddMethod(Method, MethodType, FuncName, ResultMode);
148+
end;
149+
end;
150+
151+
procedure THproseServer.AddMethod(Cls: TClass; MethodName: string;
152+
MethodType: TMethodType; AliasName: string; ResultMode: TResultMode);
153+
var
154+
Method: TMethod;
155+
begin
156+
Method.Code := Cls.MethodAddress(MethodName);
157+
if Method.Code <> nil then
158+
begin
159+
Method.Data := Cls;
160+
if AliasName = '' then
161+
AliasName := MethodName;
162+
AddMethod(Method, MethodType, AliasName, ResultMode);
163+
end;
164+
165+
end;
166+
167+
procedure THproseServer.AddMethod(Obj: TObject; MethodName: string;
168+
MethodType: TMethodType; AliasName: string; ResultMode: TResultMode);
169+
var
170+
Method: TMethod;
171+
begin
172+
Method.Code := Obj.MethodAddress(MethodName);
173+
if Method.Code <> nil then
174+
begin
175+
Method.Data := Obj;
176+
if AliasName = '' then
177+
AliasName := MethodName;
178+
AddMethod(Method, MethodType, AliasName, ResultMode);
179+
end;
180+
end;
181+
182+
procedure THproseServer.DoFunctionList(OutStream: TStream);
183+
var
184+
Writer: THproseWriter;
185+
begin
186+
Writer := THproseWriter.Create(OutStream);
187+
try
188+
OutStream.Write(HproseTagFunctions, 1);
189+
Writer.Serialize(FMethodS.Keys);
190+
OutStream.Write(HproseTagEnd, 1);
191+
finally
192+
Writer.Free;
193+
end;
194+
end;
195+
196+
procedure THproseServer.DoInvoke(InStream: TStream; OutStream: TStream);
197+
var
198+
Reader: THproseReader;
199+
Writer: THproseWriter;
200+
Tag: AnsiChar;
201+
MethodName: string;
202+
Method: THproseMethod;
203+
ResultMode: TResultMode;
204+
Args, Result: Variant;
205+
ByRef: Boolean;
206+
begin
207+
Reader := THproseReader.Create(InStream);
208+
Writer := THproseWriter.Create(OutStream);
209+
try
210+
repeat
211+
Reader.Reset;
212+
ByRef := False;
213+
MethodName := Reader.ReadString;
214+
Tag := Reader.CheckTags(HproseTagList + HproseTagEnd + HproseTagCall);
215+
if Tag = HproseTagList then
216+
begin
217+
Reader.Reset;
218+
Args := Reader.ReadList(varVariant, nil, False);
219+
Tag := Reader.CheckTags(HproseTagTrue + HproseTagEnd + HproseTagCall);
220+
if Tag = HproseTagTrue then
221+
begin
222+
ByRef := True;
223+
Tag := Reader.CheckTags(HproseTagEnd + HproseTagCall);
224+
end;
225+
end;
226+
if FMethods.ContainsKey(MethodName) then
227+
begin
228+
Method := THproseMethod(Integer(FMethods[MethodName]));
229+
ResultMode := TResultMode(FResultMode[MethodName]);
230+
if Assigned(FOnBeforeInvoke) then
231+
FOnBeforeInvoke(Name, Args, ByRef);
232+
Result := Method.Invoke(Args);
233+
if Assigned(FOnAfterInvoke) then
234+
FOnAfterInvoke(Name, Args, ByRef, Result);
235+
if ResultMode = rmRawWithEndTag then
236+
begin
237+
OutStream.Write(AnsiString(Result)[1], Length(AnsiString(Result)));
238+
Exit;
239+
end
240+
else if ResultMode = rmRaw then
241+
OutStream.Write(AnsiString(Result)[1], Length(AnsiString(Result)))
242+
else
243+
begin
244+
OutStream.Write(HproseTagResult, 1);
245+
if ResultMode = rmSerialized then
246+
OutStream.Write(AnsiString(Result)[1], Length(AnsiString(Result)))
247+
else
248+
begin
249+
Writer.Reset;
250+
Writer.Serialize(Result);
251+
end;
252+
if ByRef then
253+
begin
254+
OutStream.write(HproseTagArgument, 1);
255+
Writer.Reset;
256+
Writer.Serialize(Args);
257+
end;
258+
end;
259+
OutStream.Write(HproseTagEnd, 1);
260+
end
261+
else
262+
raise EHproseException.Create(Format('Can''''t find this function %s.', [MethodName]));
263+
until (Tag <> HproseTagCall);
264+
except
265+
On E: Exception do
266+
begin
267+
if Assigned(OnSendError) then
268+
OnSendError(E);
269+
OutStream.Write(HproseTagError, 1);
270+
if FDebug then
271+
Writer.WriteString(E.ToString, False)
272+
else
273+
Writer.WriteString(E.Message, False);
274+
OutStream.Write(HproseTagEnd, 1)
275+
end;
276+
end;
277+
Reader.Free;
278+
Writer.Free;
279+
end;
280+
281+
procedure THproseServer.HandleCommand(InStream: TStream; OutStream: TStream);
282+
var
283+
Reader: THproseReader;
284+
Tag: AnsiChar;
285+
begin
286+
Reader := THproseReader.Create(InStream);
287+
Tag := Reader.CheckTags(HproseTagCall + HproseTagEnd);
288+
if Tag = HproseTagEnd then
289+
DoFunctionList(OutStream)
290+
else
291+
DoInvoke(InStream, OutStream);
292+
Reader.Free;
293+
end;
294+
295+
end.
296+

0 commit comments

Comments
 (0)