← Back to branch summary

~ubuntu-branches/debian/lenny/fpc/lenny

« back to all changes in this revision

Viewing changes to fcl/net/mkxmlrpc.pp

  • Committer: Bazaar Package Importer
  • Author(s): Mazen Neifer, Torsten Werner, Mazen Neifer
  • Date: 2008-05-17 17:12:11 UTC
  • mfrom: (3.1.9 intrepid)
  • Revision ID: james.westby@ubuntu.com-20080517171211-9qi33xhd9evfa0kg
Tags: 2.2.0-dfsg1-9
http://bugs.debian.org/477743
[ Torsten Werner ]
* Add Mazen Neifer to Uploaders field.

[ Mazen Neifer ]
* Moved FPC sources into a version dependent directory from /usr/share/fpcsrc
  to /usr/share/fpcsrc/${FPCVERSION}. This allow installing more than on FPC
  release.
* Fixed far call issue in compiler preventing building huge binearies.
  (closes: #477743)
* Updated building dependencies, recomennded and suggested packages.
* Moved fppkg to fp-utils as it is just a helper tool and is not required by
  compiler.

Show diffs side-by-side

added added

removed removed

Lines of Context:
fcl/net/mkxmlrpc.pp
1
 
{
2
 
    $Id: mkxmlrpc.pp,v 1.5 2004/02/02 16:53:07 sg Exp $
3
 
 
4
 
    Automatic XML-RPC wrapper generator
5
 
    Copyright (c) 2003 by
6
 
      Areca Systems GmbH / Sebastian Guenther, sg@freepascal.org
7
 
 
8
 
    See the file COPYING.FPC, included in this distribution,
9
 
    for details about the copyright.
10
 
 
11
 
    This program is distributed in the hope that it will be useful,
12
 
    but WITHOUT ANY WARRANTY; without even the implied warranty of
13
 
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
14
 
}
15
 
 
16
 
 
17
 
program MkXMLRPC;
18
 
uses SysUtils, Classes, PParser, PasTree, PasWrite;
19
 
 
20
 
resourcestring
21
 
  SCmdLineInvalidOption = 'Ignoring unknown option "%s"';
22
 
  SNoServerClassNameProvided =
23
 
    'No server class name provided (use --serverclass=<name>)';
24
 
  SNoUnitNameProvided =
25
 
    'No name for generated unit provided (use --unitname=<name>)';
26
 
 
27
 
type
28
 
  TParserEngine = class(TPasTreeContainer)
29
 
  protected
30
 
    Modules, UsedModules: TList;
31
 
    CurModule: TPasModule;
32
 
  public
33
 
    constructor Create;
34
 
    destructor Destroy; override;
35
 
    function CreateElement(AClass: TPTreeElement; const AName: String;
36
 
      AParent: TPasElement; AVisibility: TPasMemberVisibility;
37
 
      const ASourceFilename: String; ASourceLinenumber: Integer): TPasElement;
38
 
      override;
39
 
    function FindElement(const AName: String): TPasElement; override;
40
 
    function FindModule(const AName: String): TPasModule; override;
41
 
  end;
42
 
 
43
 
  TServerClass = class
44
 
    Element: TPasClassType;
45
 
    ImplName: String;
46
 
  end;
47
 
 
48
 
  TRPCList = class
49
 
    constructor Create;
50
 
    destructor Destroy; override;
51
 
    procedure AddServerClass(const AClassName: String);
52
 
    ServerClasses: TList;
53
 
    UsedModules: TStringList;
54
 
  end;
55
 
 
56
 
var
57
 
  Engine: TParserEngine;
58
 
 
59
 
 
60
 
constructor TParserEngine.Create;
61
 
begin
62
 
  inherited Create;
63
 
  Modules := TList.Create;
64
 
  UsedModules := TList.Create;
65
 
end;
66
 
 
67
 
destructor TParserEngine.Destroy;
68
 
begin
69
 
  UsedModules.Free;
70
 
  Modules.Free;
71
 
  inherited Destroy;
72
 
end;
73
 
 
74
 
function TParserEngine.CreateElement(AClass: TPTreeElement; const AName: String;
75
 
  AParent: TPasElement; AVisibility: TPasMemberVisibility;
76
 
  const ASourceFilename: String; ASourceLinenumber: Integer): TPasElement;
77
 
begin
78
 
  Result := AClass.Create(AName, AParent);
79
 
  Result.Visibility := AVisibility;
80
 
  if AClass.InheritsFrom(TPasModule) then
81
 
  begin
82
 
    Modules.Add(Result);
83
 
    CurModule := TPasModule(Result);
84
 
  end;
85
 
end;
86
 
 
87
 
function TParserEngine.FindElement(const AName: String): TPasElement;
88
 
 
89
 
  function FindInModule(AModule: TPasModule; const LocalName: String): TPasElement;
90
 
  var
91
 
    l: TList;
92
 
    i, j: Integer;
93
 
    Found: Boolean;
94
 
  begin
95
 
    l := AModule.InterfaceSection.Declarations;
96
 
    for i := 0 to l.Count - 1 do
97
 
    begin
98
 
      Result := TPasElement(l[i]);
99
 
      if CompareText(Result.Name, LocalName) = 0 then
100
 
      begin
101
 
        Found := False;
102
 
        for j := 0 to UsedModules.Count - 1 do
103
 
          if CompareText(TPasModule(UsedModules[j]).Name, AModule.Name) = 0 then
104
 
          begin
105
 
            Found := True;
106
 
            break;
107
 
          end;
108
 
        if not Found then
109
 
          UsedModules.Add(AModule);
110
 
        exit;
111
 
      end;
112
 
    end;
113
 
    Result := nil;
114
 
 end;
115
 
 
116
 
var
117
 
  i: Integer;
118
 
  //ModuleName, LocalName: String;
119
 
  Module: TPasElement;
120
 
begin
121
 
{!!!: Don't know if we ever will have to use the following:
122
 
  i := Pos('.', AName);
123
 
  if i <> 0 then
124
 
  begin
125
 
    WriteLn('Dot found in name: ', AName);
126
 
    Result := nil;
127
 
  end else
128
 
  begin}
129
 
    Result := FindInModule(CurModule, AName);
130
 
    if not Assigned(Result) then
131
 
      for i := CurModule.InterfaceSection.UsesList.Count - 1 downto 0 do
132
 
      begin
133
 
        Module := TPasElement(CurModule.InterfaceSection.UsesList[i]);
134
 
        if Module.ClassType = TPasModule then
135
 
        begin
136
 
          Result := FindInModule(TPasModule(Module), AName);
137
 
          if Assigned(Result) then
138
 
            exit;
139
 
        end;
140
 
      end;
141
 
  {end;}
142
 
end;
143
 
 
144
 
function TParserEngine.FindModule(const AName: String): TPasModule;
145
 
var
146
 
  i: Integer;
147
 
begin
148
 
  for i := Modules.Count - 1 downto 0 do
149
 
  begin
150
 
    Result := TPasModule(Modules[i]);
151
 
    if CompareText(Result.Name, AName) = 0 then
152
 
      exit;
153
 
  end;
154
 
  Result := nil;
155
 
end;
156
 
 
157
 
 
158
 
constructor TRPCList.Create;
159
 
begin
160
 
  ServerClasses := TList.Create;
161
 
  UsedModules := TStringList.Create;
162
 
end;
163
 
 
164
 
destructor TRPCList.Destroy;
165
 
var
166
 
  i: Integer;
167
 
begin
168
 
  UsedModules.Free;
169
 
  for i := 0 to ServerClasses.Count - 1 do
170
 
    TServerClass(ServerClasses[i]).Free;
171
 
  ServerClasses.Free;
172
 
end;
173
 
 
174
 
procedure TRPCList.AddServerClass(const AClassName: String);
175
 
var
176
 
  Element: TPasClassType;
177
 
  ServerClass: TServerClass;
178
 
begin
179
 
  Element := TPasClassType(Engine.FindElement(AClassName));
180
 
  if not Assigned(Element) then
181
 
  begin
182
 
    WriteLn(StdErr, 'Server class "', AClassName, '" not found!');
183
 
    Halt(3);
184
 
  end;
185
 
  if (not Element.InheritsFrom(TPasClassType)) or
186
 
    (Element.ObjKind <> okClass) then
187
 
  begin
188
 
    WriteLn('"', AClassName, '" is not a class!');
189
 
    Halt(4);
190
 
  end;
191
 
  ServerClass := TServerClass.Create;
192
 
  ServerClasses.Add(ServerClass);
193
 
  ServerClass.Element := Element;
194
 
  ServerClass.ImplName := Copy(Element.Name, 2, Length(Element.Name));
195
 
  UsedModules.Add(Element.GetModule.Name);
196
 
end;
197
 
 
198
 
 
199
 
var
200
 
  OutputFilename, UnitName: String;
201
 
  RPCList: TRPCList;
202
 
 
203
 
procedure WriteClassServerSource(ServerClass: TPasClassType;
204
 
  ImplementationSection: TPasSection; Method, ProcImpl: TPasProcedureImpl;
205
 
  const MethodPrefix: String; NestingLevel: Integer);
206
 
 
207
 
{ Method: Main server method
208
 
  ProcImpl: Current procedure (may be identical with Method) }
209
 
 
210
 
type
211
 
  TConversionInfo = record
212
 
    ConverterName, TypecastFunction: String;
213
 
    ArgIsParent: Boolean;
214
 
  end;
215
 
 
216
 
  function MakeStructConverter(AClass: TPasClassType;
217
 
    Referrer: TPasProcedureImpl): TPasProcedureImpl; forward;
218
 
 
219
 
  function MakeArrayConverter(Member, ArraySizeProp: TPasProperty;
220
 
    ProcessProc, Referrer: TPasProcedureImpl): TPasProcedureImpl; forward;
221
 
 
222
 
  function FindArraySizeProperty(AArrayProp: TPasProperty): TPasProperty;
223
 
  var
224
 
    i: Integer;
225
 
    Name: String;
226
 
  begin
227
 
    Name := Copy(AArrayProp.Name, 1, Length(AArrayProp.Name) - 1) + 'Count';
228
 
    for i := 0 to TPasClassType(AArrayProp.Parent).Members.Count - 1 do
229
 
    begin
230
 
      Result := TPasProperty(TPasClassType(AArrayProp.Parent).Members[i]);
231
 
      if (Result.ClassType = TPasProperty) and (Result.Visibility = visPublic)
232
 
        and (CompareStr(Result.Name, Name) = 0) then
233
 
        exit;
234
 
    end;
235
 
 
236
 
    Name := AArrayProp.Name + 'Count';
237
 
    for i := 0 to TPasClassType(AArrayProp.Parent).Members.Count - 1 do
238
 
    begin
239
 
      Result := TPasProperty(TPasClassType(AArrayProp.Parent).Members[i]);
240
 
      if (Result.ClassType = TPasProperty) and (Result.Visibility = visPublic)
241
 
        and (CompareStr(Result.Name, Name) = 0) then
242
 
        exit;
243
 
    end;
244
 
    Result := nil;
245
 
  end;
246
 
 
247
 
  function GetConversionInfo(Element: TPasElement;
248
 
    Referrer: TPasProcedureImpl): TConversionInfo;
249
 
  var
250
 
    s: String;
251
 
    ArraySizeProp: TPasProperty;
252
 
  begin
253
 
    FillChar(Result, SizeOf(Result), 0);
254
 
    Result.ArgIsParent := False;
255
 
 
256
 
    if Element.ClassType = TPasProperty then
257
 
    begin
258
 
      ArraySizeProp := FindArraySizeProperty(TPasProperty(Element));
259
 
      if Assigned(ArraySizeProp) then
260
 
      begin
261
 
        Result.ConverterName := MakeArrayConverter(TPasProperty(Element),
262
 
          ArraySizeProp, ProcImpl, Referrer).Name;
263
 
        Result.ArgIsParent := True;
264
 
        exit;
265
 
      end else
266
 
        Element := TPasProperty(Element).VarType;
267
 
    end;
268
 
 
269
 
    if Element.ClassType = TPasUnresolvedTypeRef then
270
 
    begin
271
 
      s := UpperCase(Element.Name);
272
 
      if (s = 'BYTE') or (s = 'SHORTINT') or (S = 'SMALLINT') or
273
 
        (s = 'INTEGER') or (s = 'LONGINT') or (s = 'CARDINAL') or
274
 
        (s = 'INT64') or (s = 'QUADWORD') then
275
 
        Result.ConverterName := 'AWriter.CreateIntValue'
276
 
      else if (s = 'BOOLEAN') or (s = 'WORDBOOL') or (s = 'LONGBOOL') then
277
 
        Result.ConverterName := 'AWriter.CreateBooleanValue'
278
 
      else if s = 'STRING' then
279
 
        Result.ConverterName := 'AWriter.CreateStringValue'
280
 
      else if (s = 'FLOAT') or (s = 'SINGLE') or (s = 'DOUBLE') or
281
 
        (s = 'EXTENDED') then
282
 
        Result.ConverterName := 'AWriter.CreateDoubleValue'
283
 
      else if s = 'TDATETIME' then
284
 
        Result.ConverterName := 'AWriter.CreateDateTimeValue';
285
 
    end else if Element.ClassType = TPasClassType then
286
 
      Result.ConverterName := MakeStructConverter(TPasClassType(Element), Referrer).Name
287
 
    else if Element.ClassType = TPasEnumType then
288
 
    begin
289
 
      Result.ConverterName := 'AWriter.CreateIntValue';
290
 
      Result.TypecastFunction := 'Ord';
291
 
    end;
292
 
 
293
 
    if Length(Result.ConverterName) = 0 then
294
 
      raise Exception.Create('Result type not supported: ' + Element.ClassName +
295
 
        ' ' + Element.Name);
296
 
  end;
297
 
 
298
 
  function MakeAccessor(ConversionInfo: TConversionInfo;
299
 
    const DataSource, ArrayIndex: String): String;
300
 
  begin
301
 
    Result := ConversionInfo.ConverterName + '(';
302
 
    if ConversionInfo.TypecastFunction <> '' then
303
 
      Result := Result + ConversionInfo.TypecastFunction + '(';
304
 
    Result := Result + DataSource;
305
 
    if ConversionInfo.TypecastFunction <> '' then
306
 
      Result := Result + ')';
307
 
    if ArrayIndex <> '' then
308
 
      Result := Result + '[' + ArrayIndex + ']';
309
 
    Result := Result + ')';
310
 
  end;
311
 
 
312
 
  function GetParseValueFnName(PasType: TPasType): String;
313
 
  var
314
 
    s: String;
315
 
  begin
316
 
    SetLength(Result, 0);
317
 
    if PasType.ClassType = TPasArgument then
318
 
    begin
319
 
      if TPasArgument(PasType).Access = argVar then
320
 
        raise Exception.Create('"var" arguments are not allowed');
321
 
      PasType := TPasArgument(PasType).ArgType;
322
 
    end;
323
 
 
324
 
    if PasType.ClassType = TPasUnresolvedTypeRef then
325
 
    begin
326
 
      s := UpperCase(PasType.Name);
327
 
      if (s = 'BYTE') or (s = 'SHORTINT') or (S = 'SMALLINT') or
328
 
        (s = 'INTEGER') or (s = 'LONGINT') or (s = 'CARDINAL') or
329
 
        (s = 'INT64') or (s = 'QUADWORD') then
330
 
        Result := 'Int'
331
 
      else if (s = 'BOOLEAN') or (s = 'WORDBOOL') or (s = 'LONGBOOL') then
332
 
        Result := 'Boolean'
333
 
      else if s = 'STRING' then
334
 
        Result := 'String'
335
 
      else if (s = 'FLOAT') or (s = 'SINGLE') or (s = 'DOUBLE') or
336
 
        (s = 'EXTENDED') then
337
 
        Result := 'Double'
338
 
      else if s = 'TDATETIME' then
339
 
        Result := 'DateTime';
340
 
    end;
341
 
    if Length(Result) = 0 then
342
 
      raise Exception.Create('Argument type not supported: ' +
343
 
        PasType.ClassName + ' ' + PasType.Name);
344
 
  end;
345
 
 
346
 
  function NeedLocalProc(const ProcName: String;
347
 
    Referrer: TPasProcedureImpl): TPasProcedureImpl;
348
 
  var
349
 
    i, j: Integer;
350
 
  begin
351
 
    for i := 0 to Method.Locals.Count - 1 do
352
 
    begin
353
 
      Result := TPasProcedureImpl(Method.Locals[i]);
354
 
      if Result.Name = ProcName then
355
 
      begin
356
 
        j := Method.Locals.IndexOf(Referrer);
357
 
        if (j >= 0) and (i >= j) then
358
 
        begin
359
 
          // Move existing converter to the top and exit
360
 
          Method.Locals.Delete(i);
361
 
          j := Method.Locals.IndexOf(ProcImpl);
362
 
          if j < 0 then
363
 
            j := 0;
364
 
          Method.Locals.Insert(j, Result);
365
 
        end;
366
 
        exit;
367
 
      end;
368
 
    end;
369
 
    Result := nil;
370
 
  end;
371
 
 
372
 
  function MakeStructConverter(AClass: TPasClassType;
373
 
    Referrer: TPasProcedureImpl): TPasProcedureImpl;
374
 
  var
375
 
    ConverterName, s: String;
376
 
    Commands: TPasImplCommands;
377
 
    i: Integer;
378
 
    LocalMember: TPasElement;
379
 
    ConversionInfo: TConversionInfo;
380
 
  begin
381
 
    ConverterName := 'Convert' + AClass.Name;
382
 
    Result := NeedLocalProc(ConverterName, Referrer);
383
 
    if Assigned(Result) then
384
 
      exit;
385
 
 
386
 
    Result := TPasProcedureImpl.Create(ConverterName, Method);
387
 
    i := Method.Locals.IndexOf(Referrer);
388
 
    if i < 0 then
389
 
      i := 0;
390
 
    Method.Locals.Insert(i, Result);
391
 
    Result.ProcType := TPasFunctionType.Create('', Result);
392
 
    Result.ProcType.CreateArgument('Inst', AClass.Name);
393
 
    TPasFunctionType(Result.ProcType).ResultEl :=
394
 
      TPasResultElement.Create('', Result);
395
 
    TPasFunctionType(Result.ProcType).ResultEl.ResultType :=
396
 
      TPasUnresolvedTypeRef.Create('TXMLRPCStruct', Result);
397
 
 
398
 
    Result.Body := TPasImplBlock.Create('', Result);
399
 
    Commands := Result.Body.AddCommands;
400
 
    Commands.Commands.Add('Result := AWriter.CreateStruct');
401
 
    for i := 0 to AClass.Members.Count - 1 do
402
 
    begin
403
 
      LocalMember := TPasElement(AClass.Members[i]);
404
 
      if LocalMember.ClassType = TPasProperty then
405
 
      begin
406
 
        ConversionInfo := GetConversionInfo(LocalMember, Result);
407
 
        if ConversionInfo.ArgIsParent then
408
 
          s := 'Inst'
409
 
        else
410
 
          s := 'Inst.' + LocalMember.Name;
411
 
        s := 'AWriter.AddStructMember(Result, ''' + LocalMember.Name + ''', ' +
412
 
          MakeAccessor(ConversionInfo, s, '') + ')';
413
 
        Commands.Commands.Add(s);
414
 
      end;
415
 
    end;
416
 
  end;
417
 
 
418
 
  function MakeArrayConverter(Member, ArraySizeProp: TPasProperty;
419
 
    ProcessProc, Referrer: TPasProcedureImpl): TPasProcedureImpl;
420
 
  var
421
 
    i: Integer;
422
 
    ConverterName, s: String;
423
 
    Commands: TPasImplCommands;
424
 
    VarMember: TPasVariable;
425
 
    ForLoop: TPasImplForLoop;
426
 
    ConversionInfo: TConversionInfo;
427
 
  begin
428
 
    ConverterName := 'Convert' + Member.Parent.Name + '_' + Member.Name;
429
 
    Result := NeedLocalProc(ConverterName, Referrer);
430
 
    if Assigned(Result) then
431
 
      exit;
432
 
 
433
 
    Result := TPasProcedureImpl.Create(ConverterName, Method);
434
 
    i := Method.Locals.IndexOf(Referrer);
435
 
    if i < 0 then
436
 
      i := 0;
437
 
    Method.Locals.Insert(i, Result);
438
 
    Result.ProcType := TPasFunctionType.Create('', Result);
439
 
    Result.ProcType.CreateArgument('Inst', Member.Parent.Name);
440
 
    TPasFunctionType(Result.ProcType).ResultEl :=
441
 
      TPasResultElement.Create('', Result);
442
 
    TPasFunctionType(Result.ProcType).ResultEl.ResultType :=
443
 
      TPasUnresolvedTypeRef.Create('TXMLRPCArray', Result);
444
 
 
445
 
    Result.Body := TPasImplBlock.Create('', Result);
446
 
    Commands := Result.Body.AddCommands;
447
 
    Commands.Commands.Add('Result := AWriter.CreateArray');
448
 
 
449
 
    VarMember := TPasVariable.Create('i', Result);
450
 
    Result.Locals.Add(VarMember);
451
 
    VarMember.VarType := TPasUnresolvedTypeRef.Create('Integer', VarMember);
452
 
 
453
 
    ForLoop := Result.Body.AddForLoop(TPasVariable.Create('i', Result),
454
 
      '0', MethodPrefix + ArraySizeProp.Name + ' - 1');
455
 
    ForLoop.Body := TPasImplCommand.Create('', ForLoop);
456
 
    ConversionInfo := GetConversionInfo(Member.VarType, Result);
457
 
    if ConversionInfo.ArgIsParent then
458
 
      s := 'Inst'
459
 
    else
460
 
      s := 'Inst.' + Member.Name + '[i]';
461
 
    s := 'AWriter.AddArrayElement(Result, ' +
462
 
      MakeAccessor(ConversionInfo, s, '') + ')';
463
 
    TPasImplCommand(ForLoop.Body).Command := s;
464
 
  end;
465
 
 
466
 
  function CreateDispatcher(VarType: TPasClassType;
467
 
    Referrer: TPasProcedureImpl): TPasProcedureImpl;
468
 
  var
469
 
    DispatcherName: String;
470
 
  begin
471
 
    DispatcherName := 'Dispatch' + VarType.Name;
472
 
    Result := NeedLocalProc(DispatcherName, Referrer);
473
 
    if Assigned(Result) then
474
 
      exit;
475
 
 
476
 
    // Create new dispatcher method
477
 
    Result := TPasProcedureImpl.Create(DispatcherName, Method);
478
 
    if ProcImpl = Method then
479
 
      Method.Locals.Insert(0, Result)
480
 
    else
481
 
      Method.Locals.Insert(Method.Locals.IndexOf(Referrer), Result);
482
 
    Result.ProcType := TPasProcedureType.Create('', Result);
483
 
    Result.ProcType.CreateArgument('Inst', VarType.Name);
484
 
    Result.ProcType.CreateArgument('Level', 'Integer');
485
 
    WriteClassServerSource(VarType,
486
 
      ImplementationSection, Method, Result, 'Inst.', NestingLevel + 1);
487
 
  end;
488
 
 
489
 
 
490
 
var
491
 
  IfElse, ParentIfElse: TPasImplIfElse;
492
 
 
493
 
  procedure CreateBranch(const MethodName: String);
494
 
  begin
495
 
    if Assigned(ParentIfElse) then
496
 
    begin
497
 
      IfElse := TPasImplIfElse.Create('', ParentIfElse);
498
 
      ParentIfElse.ElseBranch := IfElse;
499
 
    end else
500
 
    begin
501
 
      IfElse := TPasImplIfElse.Create('', ProcImpl.Body);
502
 
      ProcImpl.Body.Elements.Add(IfElse);
503
 
    end;
504
 
    ParentIfElse := IfElse;
505
 
    IfElse.Condition := 's = ''' + UpperCase(MethodName) + '''';
506
 
  end;
507
 
 
508
 
  procedure ProcessMethodCall(Member: TPasProcedure);
509
 
 
510
 
    function MakeProcArgs(Args: TList): String;
511
 
    var
512
 
      i: Integer;
513
 
    begin
514
 
      if (not Assigned(Args)) or (Args.Count = 0) then
515
 
        Result := ''
516
 
      else
517
 
      begin
518
 
        Result := '(';
519
 
        for i := 0 to Args.Count - 1 do
520
 
        begin
521
 
          if i > 0 then
522
 
            Result := Result + ', ';
523
 
          Result := Result + 'AParser.GetPrev' + GetParseValueFnName(TPasType(Args[i]));
524
 
        end;
525
 
        Result := Result + ')';
526
 
      end;
527
 
    end;
528
 
 
529
 
  var
530
 
    Commands: TPasImplCommands;
531
 
    s: String;
532
 
  begin
533
 
    CreateBranch(Member.Name);
534
 
    Commands := TPasImplCommands.Create('', IfElse);
535
 
    IfElse.IfBranch := Commands;
536
 
 
537
 
    if TPasProcedure(Member).ProcType.Args.Count > 0 then
538
 
      Commands.Commands.Add('AParser.ResetValueCursor');
539
 
    if Member.ClassType = TPasProcedure then
540
 
    begin
541
 
      Commands.Commands.Add(MethodPrefix + Member.Name +
542
 
        MakeProcArgs(TPasProcedure(Member).ProcType.Args));
543
 
      Commands.Commands.Add('AWriter.WriteResponse(nil)');
544
 
    end else
545
 
    begin
546
 
      // function
547
 
      s := MethodPrefix + Member.Name +
548
 
        MakeProcArgs(TPasProcedure(Member).ProcType.Args);
549
 
      Commands.Commands.Add('AWriter.WriteResponse(' +
550
 
        MakeAccessor(GetConversionInfo(TPasFunctionType(TPasFunction(Member).
551
 
          ProcType).ResultEl.ResultType, ProcImpl), s, '') + ')');
552
 
    end;
553
 
  end;
554
 
 
555
 
  procedure ProcessProperty(Member: TPasProperty);
556
 
  var
557
 
    LocalIfElse: TPasImplIfElse;
558
 
    IsArray, IsStruct: Boolean;
559
 
    s, s2: String;
560
 
    Commands: TPasImplCommands;
561
 
    Command: TPasImplCommand;
562
 
    ConversionInfo: TConversionInfo;
563
 
  begin
564
 
    if Member.ReadAccessorName <> '' then
565
 
    begin
566
 
      CreateBranch('Get' + Member.Name);
567
 
 
568
 
      IsArray := (Member.Args.Count = 1) and
569
 
        Assigned(FindArraySizeProperty(Member));
570
 
      IsStruct := Member.VarType.ClassType = TPasClassType;
571
 
 
572
 
      if IsStruct then
573
 
        s := CreateDispatcher(TPasClassType(Member.VarType), ProcImpl).Name +
574
 
          '(' + MethodPrefix + Member.Name;
575
 
 
576
 
      if NestingLevel = 0 then
577
 
        s2 := '1'
578
 
      else
579
 
        s2 := 'Level + 1';
580
 
 
581
 
      if IsArray or (IsStruct and (Member.Args.Count = 0)) then
582
 
      begin
583
 
        LocalIfElse := TPasImplIfElse.Create('', IfElse);
584
 
        IfElse.IfBranch := LocalIfElse;
585
 
        LocalIfElse.Condition := 'APath.Count <= ' + s2;
586
 
      end;
587
 
 
588
 
      if IsStruct then
589
 
        if IsArray then
590
 
        begin
591
 
          LocalIfElse.IfBranch := TPasImplCommand.Create('', LocalIfElse);
592
 
          TPasImplCommand(LocalIfElse.IfBranch).Command :=
593
 
            'AWriter.WriteResponse(' +
594
 
            MakeAccessor(GetConversionInfo(Member, ProcImpl),
595
 
              Copy(MethodPrefix, 1, Length(MethodPrefix) - 1), '') + ')';
596
 
 
597
 
          LocalIfElse.ElseBranch := TPasImplCommand.Create('', LocalIfElse);
598
 
          TPasImplCommand(LocalIfElse.ElseBranch).Command :=
599
 
            s + '[AParser.GetNext' +
600
 
            GetParseValueFnName(TPasArgument(Member.Args[0]).ArgType) + '], ' +
601
 
            s2 + ')';
602
 
        end else
603
 
        begin
604
 
          if Member.Args.Count = 0 then
605
 
          begin
606
 
            LocalIfElse.IfBranch := TPasImplCommand.Create('', LocalIfElse);
607
 
            TPasImplCommand(LocalIfElse.IfBranch).Command :=
608
 
               'AWriter.WriteResponse(' +
609
 
               MakeAccessor(GetConversionInfo(Member, ProcImpl),
610
 
                 MethodPrefix + Member.Name, '') + ')';
611
 
            LocalIfElse.ElseBranch := TPasImplCommand.Create('', LocalIfElse);
612
 
            TPasImplCommand(LocalIfElse.ElseBranch).Command := s + ', ' + s2 + ')';
613
 
          end else
614
 
          begin
615
 
            IfElse.IfBranch := TPasImplCommand.Create('', IfElse);
616
 
            TPasImplCommand(IfElse.IfBranch).Command := s + '[AParser.GetNext' +
617
 
            GetParseValueFnName(TPasArgument(Member.Args[0]).ArgType) + '], ' +
618
 
            s2 + ')';
619
 
          end;
620
 
        end
621
 
      else if IsArray then
622
 
      begin
623
 
        LocalIfElse.IfBranch := TPasImplCommand.Create('', LocalIfElse);
624
 
        TPasImplCommand(LocalIfElse.IfBranch).Command :=
625
 
           'AWriter.WriteResponse(' +
626
 
           MakeAccessor(GetConversionInfo(Member, ProcImpl),
627
 
             Copy(MethodPrefix, 1, Length(MethodPrefix) - 1), '') + ')';
628
 
 
629
 
        LocalIfElse.ElseBranch := TPasImplCommand.Create('', LocalIfElse);
630
 
        TPasImplCommand(LocalIfElse.ElseBranch).Command :=
631
 
          'AWriter.WriteResponse(' +
632
 
          MakeAccessor(GetConversionInfo(Member.VarType, ProcImpl),
633
 
            MethodPrefix + Member.Name, 'AParser.GetNext' +
634
 
            GetParseValueFnName(TPasArgument(Member.Args[0]).ArgType)) + ')';
635
 
      end else
636
 
      begin
637
 
        IfElse.IfBranch := TPasImplCommand.Create('', IfElse);
638
 
        TPasImplCommand(IfElse.IfBranch).Command := 'AWriter.WriteResponse(' +
639
 
          MakeAccessor(GetConversionInfo(Member.VarType, ProcImpl),
640
 
            MethodPrefix + Member.Name, '') + ')';
641
 
      end;
642
 
    end;
643
 
 
644
 
    if Member.WriteAccessorName <> '' then
645
 
    begin
646
 
      CreateBranch('Set' + Member.Name);
647
 
      Commands := TPasImplCommands.Create('', IfElse);
648
 
      IfElse.IfBranch := Commands;
649
 
      Commands.Commands.Add('// Not supported by mkxmlrpc yet');
650
 
    end;
651
 
  end;
652
 
 
653
 
var
654
 
  VarMember: TPasVariable;
655
 
  i: Integer;
656
 
  Command: TPasImplCommand;
657
 
  Member: TPasElement;
658
 
begin
659
 
  VarMember := TPasVariable.Create('s', ProcImpl);
660
 
  ProcImpl.Locals.Add(VarMember);
661
 
  VarMember.VarType := TPasUnresolvedTypeRef.Create('String', VarMember);
662
 
  ProcImpl.Body := TPasImplBlock.Create('', ProcImpl);
663
 
  if NestingLevel = 0 then
664
 
    ProcImpl.Body.AddCommand('s := APath[' + IntToStr(NestingLevel) + ']')
665
 
  else
666
 
    ProcImpl.Body.AddCommand('s := APath[Level]');
667
 
  ParentIfElse := nil;
668
 
  for i := 0 to ServerClass.Members.Count - 1 do
669
 
  begin
670
 
    Member := TPasElement(ServerClass.Members[i]);
671
 
    if Member.Visibility <> visPublic then
672
 
      continue;
673
 
 
674
 
    if (Member.ClassType = TPasProcedure) or (Member.ClassType = TPasFunction)
675
 
    then
676
 
      ProcessMethodCall(TPasProcedure(Member))
677
 
    else if Member.ClassType = TPasProperty then
678
 
      ProcessProperty(TPasProperty(Member))
679
 
    else if (Member.ClassType <> TPasConstructor) and
680
 
      (Member.ClassType <> TPasDestructor) then
681
 
      WriteLn('Warning: Unsupportet member type: ', Member.ElementTypeName);
682
 
  end;
683
 
 
684
 
  if Assigned(ParentIfElse) then
685
 
  begin
686
 
    Command := TPasImplCommand.Create('', ParentIfElse);
687
 
    ParentIfElse.ElseBranch := Command;
688
 
  end else
689
 
  begin
690
 
    Command := TPasImplCommand.Create('', ProcImpl.Body);
691
 
    ProcImpl.Body.Elements.Add(Command);
692
 
  end;
693
 
  Command.Command := 'AWriter.WriteFaultResponse(2, ''Invalid method name'')';
694
 
end;
695
 
 
696
 
procedure WriteFPCServerSource;
697
 
var
698
 
  i, j: Integer;
699
 
  Module: TPasModule;
700
 
  InterfaceSection, ImplementationSection: TPasSection;
701
 
  VarMember: TPasVariable;
702
 
  PropertyMember: TPasProperty;
703
 
  ProcMember: TPasProcedure;
704
 
  Arg: TPasArgument;
705
 
  ServerClass: TPasClassType;
706
 
  Stream: TStream;
707
 
  ProcImpl: TPasProcedureImpl;
708
 
  Found: Boolean;
709
 
begin
710
 
  Module := TPasModule.Create(UnitName, nil);
711
 
  try
712
 
    InterfaceSection := TPasSection.Create('', Module);
713
 
    Module.InterfaceSection := InterfaceSection;
714
 
    ImplementationSection := TPasSection.Create('', Module);
715
 
    Module.ImplementationSection := ImplementationSection;
716
 
    InterfaceSection.AddUnitToUsesList('Classes');
717
 
    InterfaceSection.AddUnitToUsesList('XMLRPC');
718
 
    for i := 0 to RPCList.UsedModules.Count - 1 do
719
 
      InterfaceSection.AddUnitToUsesList(RPCList.UsedModules[i]);
720
 
 
721
 
    for i := 0 to RPCList.ServerClasses.Count - 1 do
722
 
      with TServerClass(RPCList.ServerClasses[i]) do
723
 
      begin
724
 
        ServerClass := TPasClassType.Create('T' + ImplName + 'XMLRPCServlet',
725
 
          InterfaceSection);
726
 
        InterfaceSection.Declarations.Add(ServerClass);
727
 
        ServerClass.ObjKind := okClass;
728
 
        ServerClass.AncestorType :=
729
 
          TPasUnresolvedTypeRef.Create('TXMLRPCServlet', ServerClass);
730
 
 
731
 
        // Create private field which holds the implementation instance
732
 
        VarMember := TPasVariable.Create('F' + ImplName, ServerClass);
733
 
        VarMember.Visibility := visPrivate;
734
 
        VarMember.VarType := TPasUnresolvedTypeRef.Create(Element.Name, VarMember);
735
 
        ServerClass.Members.Add(VarMember);
736
 
 
737
 
        // Create dispatcher method
738
 
        ProcMember := TPasProcedure.Create('Dispatch', ServerClass);
739
 
        ProcMember.Visibility := visProtected;
740
 
        ProcMember.IsOverride := True;
741
 
        ProcMember.ProcType := TPasProcedureType.Create('', ProcMember);
742
 
        ProcMember.ProcType.CreateArgument('AParser', 'TXMLRPCParser').
743
 
          Visibility := visPublic;
744
 
        ProcMember.ProcType.CreateArgument('AWriter', 'TXMLRPCWriter').
745
 
          Visibility := visPublic;
746
 
        ProcMember.ProcType.CreateArgument('APath', 'TStrings').
747
 
          Visibility := visPublic;
748
 
        ServerClass.Members.Add(ProcMember);
749
 
 
750
 
        // Create published property for implementation instance
751
 
        PropertyMember := TPasProperty.Create(ImplName, ServerClass);
752
 
        PropertyMember.Visibility := visPublished;
753
 
        PropertyMember.VarType := VarMember.VarType;
754
 
        VarMember.VarType.AddRef;
755
 
        PropertyMember.ReadAccessorName := 'F' + ImplName;
756
 
        PropertyMember.WriteAccessorName := 'F' + ImplName;
757
 
        ServerClass.Members.Add(PropertyMember);
758
 
 
759
 
        // Create dispatcher implementation
760
 
        ProcImpl := TPasProcedureImpl.Create('Dispatch', ServerClass);
761
 
        ImplementationSection.Declarations.Add(ProcImpl);
762
 
        ProcImpl.ProcType := ProcMember.ProcType;
763
 
        ProcMember.ProcType.AddRef;
764
 
        ProcImpl.ProcType.AddRef;
765
 
        WriteClassServerSource(Element, ImplementationSection, ProcImpl,
766
 
          ProcImpl, ImplName + '.', 0);
767
 
      end;
768
 
 
769
 
    for i := 0 to Engine.UsedModules.Count - 1 do
770
 
    begin
771
 
      Found := False;
772
 
      for j := 0 to RPCList.UsedModules.Count - 1 do
773
 
        if CompareText(RPCList.UsedModules[j],
774
 
          TPasModule(Engine.UsedModules[i]).Name) = 0 then
775
 
        begin
776
 
          Found := True;
777
 
          break;
778
 
        end;
779
 
      if not Found then
780
 
        ImplementationSection.AddUnitToUsesList(
781
 
          TPasModule(Engine.UsedModules[i]).Name);
782
 
    end;
783
 
 
784
 
    Stream := THandleStream.Create(StdOutputHandle);
785
 
    try
786
 
      WritePasFile(Module, Stream);
787
 
    finally
788
 
      Stream.Free;
789
 
    end;
790
 
 
791
 
    Stream := TFileStream.Create(OutputFilename, fmCreate);
792
 
    try
793
 
      WritePasFile(Module, Stream);
794
 
    finally
795
 
      Stream.Free;
796
 
    end;
797
 
  finally
798
 
    Module.Free;
799
 
  end;
800
 
end;
801
 
 
802
 
 
803
 
var
804
 
  i, j: Integer;
805
 
  s, Cmd, Arg: String;
806
 
  InputFiles, ClassList: TStringList;
807
 
begin
808
 
  InputFiles := TStringList.Create;
809
 
  ClassList := TStringList.Create;
810
 
  try
811
 
    for i := 1 to ParamCount do
812
 
    begin
813
 
      s := ParamStr(i);
814
 
      j := Pos('=', s);
815
 
      if j > 0 then
816
 
      begin
817
 
        Cmd := Copy(s, 1, j - 1);
818
 
        Arg := Copy(s, j + 1, Length(s));
819
 
      end else
820
 
      begin
821
 
        Cmd := s;
822
 
        SetLength(Arg, 0);
823
 
      end;
824
 
      if (Cmd = '-i') or (Cmd = '--input') then
825
 
        InputFiles.Add(Arg)
826
 
      else if Cmd = '--output' then
827
 
        OutputFilename := Arg
828
 
      else if Cmd = '--unitname' then
829
 
        UnitName := Arg
830
 
      else if Cmd = '--serverclass' then
831
 
        ClassList.Add(Arg)
832
 
      else
833
 
        WriteLn(StdErr, Format(SCmdLineInvalidOption, [s]));
834
 
    end;
835
 
 
836
 
    if ClassList.Count = 0 then
837
 
    begin
838
 
      WriteLn(StdErr, SNoServerClassNameProvided);
839
 
      Halt(2);
840
 
    end;
841
 
 
842
 
    if UnitName = '' then
843
 
    begin
844
 
      WriteLn(StdErr, SNoUnitNameProvided);
845
 
      Halt(2);
846
 
    end;
847
 
 
848
 
    Engine := TParserEngine.Create;
849
 
    try
850
 
      // Engine.SetPackageName('XMLRPC');
851
 
      for i := 0 to InputFiles.Count - 1 do
852
 
        ParseSource(Engine, InputFiles[i], '', '');
853
 
 
854
 
      RPCList := TRPCList.Create;
855
 
      try
856
 
        for i := 0 to ClassList.Count - 1 do
857
 
          RPCList.AddServerClass(ClassList[i]);
858
 
        WriteFPCServerSource;
859
 
      finally
860
 
        RPCList.Free;
861
 
      end;
862
 
    finally
863
 
      Engine.Free;
864
 
    end;
865
 
  finally
866
 
    InputFiles.Free;
867
 
    ClassList.Free;
868
 
  end;
869
 
end.
870
 
 
871
 
 
872
 
{
873
 
  $Log: mkxmlrpc.pp,v $
874
 
  Revision 1.5  2004/02/02 16:53:07  sg
875
 
  * Small fix in GetConversionInfo (result was not fully cleared)
876
 
 
877
 
  Revision 1.4  2003/11/22 12:08:32  sg
878
 
  * Better error reporting with line numbers
879
 
  * Array properties: The size property now can just match the name of the
880
 
    array property as well; so it now also works without a plural "s" after
881
 
    the base name
882
 
  * Added support for TDateTime parameters and results
883
 
 
884
 
  Revision 1.3  2003/06/25 08:56:26  sg
885
 
  * Added support for reading set properties
886
 
 
887
 
  Revision 1.2  2003/06/12 19:00:53  michael
888
 
  * Supports usage of declarations from other units (as long as mkxmlrpc
889
 
     parsed these units due to a --input=unitname command)
890
 
 
891
 
  Revision 1.1  2003/04/26 16:42:10  sg
892
 
  * Added mkxmlrpc
893
 
 
894
 
}