diff --git a/fcl/net/Makefile b/fcl/net/Makefile index 683f92b583..55fa09e02d 100644 --- a/fcl/net/Makefile +++ b/fcl/net/Makefile @@ -1,8 +1,8 @@ # -# Don't edit, this file is generated by FPCMake Version 1.1 [2003/04/25] +# Don't edit, this file is generated by FPCMake Version 1.1 [2003/04/22] # default: all -MAKEFILETARGETS=linux go32v2 win32 os2 freebsd beos netbsd amiga atari sunos qnx netware openbsd wdosx palmos macos macosx emx +MAKEFILETARGETS=linux go32v2 win32 os2 freebsd beos netbsd amiga atari sunos qnx netware openbsd wdosx palmos macos macosx override PATH:=$(subst \,/,$(PATH)) ifeq ($(findstring ;,$(PATH)),) inUnix=1 @@ -204,6 +204,18 @@ UNITSDIR:=$(wildcard $(FPCDIR)/units/$(OS_TARGET)) endif PACKAGESDIR:=$(wildcard $(FPCDIR) $(FPCDIR)/packages/base $(FPCDIR)/packages/extra) override PACKAGE_NAME=fcl +ifeq ($(OS_TARGET),linux) +override TARGET_PROGRAMS+=mkxmlrpc +endif +ifeq ($(OS_TARGET),freebsd) +override TARGET_PROGRAMS+=mkxmlrpc +endif +ifeq ($(OS_TARGET),netbsd) +override TARGET_PROGRAMS+=mkxmlrpc +endif +ifeq ($(OS_TARGET),openbsd) +override TARGET_PROGRAMS+=mkxmlrpc +endif override TARGET_UNITS+=servlets ifeq ($(OS_TARGET),linux) override TARGET_UNITS+=http httpsvlt xmlrpc @@ -449,97 +461,6 @@ SHAREDLIBEXT=.so STATICLIBPREFIX=libp RSTEXT=.rst FPCMADE=fpcmade -ifeq ($(findstring 1.0.,$(FPC_VERSION)),) -ifeq ($(OS_TARGET),go32v1) -STATICLIBPREFIX= -FPCMADE=fpcmade.v1 -PACKAGESUFFIX=v1 -endif -ifeq ($(OS_TARGET),go32v2) -STATICLIBPREFIX= -FPCMADE=fpcmade.dos -ZIPSUFFIX=go32 -endif -ifeq ($(OS_TARGET),linux) -EXEEXT= -HASSHAREDLIB=1 -FPCMADE=fpcmade.lnx -ZIPSUFFIX=linux -endif -ifeq ($(OS_TARGET),freebsd) -EXEEXT= -HASSHAREDLIB=1 -FPCMADE=fpcmade.freebsd -ZIPSUFFIX=freebsd -endif -ifeq ($(OS_TARGET),netbsd) -EXEEXT= -HASSHAREDLIB=1 -FPCMADE=fpcmade.netbsd -ZIPSUFFIX=netbsd -endif -ifeq ($(OS_TARGET),openbsd) -EXEEXT= -HASSHAREDLIB=1 -FPCMADE=fpcmade.openbsd -ZIPSUFFIX=openbsd -endif -ifeq ($(OS_TARGET),win32) -SHAREDLIBEXT=.dll -FPCMADE=fpcmade.w32 -ZIPSUFFIX=w32 -endif -ifeq ($(OS_TARGET),os2) -AOUTEXT=.out -STATICLIBPREFIX= -SHAREDLIBEXT=.dll -FPCMADE=fpcmade.os2 -ZIPSUFFIX=os2 -ECHO=echo -endif -ifeq ($(OS_TARGET),emx) -AOUTEXT=.out -STATICLIBPREFIX= -SHAREDLIBEXT=.dll -FPCMADE=fpcmade.emx -ZIPSUFFIX=emx -ECHO=echo -endif -ifeq ($(OS_TARGET),amiga) -EXEEXT= -SHAREDLIBEXT=.library -FPCMADE=fpcmade.amg -endif -ifeq ($(OS_TARGET),atari) -EXEEXT=.ttp -FPCMADE=fpcmade.ata -endif -ifeq ($(OS_TARGET),beos) -EXEEXT= -FPCMADE=fpcmade.be -ZIPSUFFIX=be -endif -ifeq ($(OS_TARGET),sunos) -EXEEXT= -FPCMADE=fpcmade.sun -ZIPSUFFIX=sun -endif -ifeq ($(OS_TARGET),qnx) -EXEEXT= -FPCMADE=fpcmade.qnx -ZIPSUFFIX=qnx -endif -ifeq ($(OS_TARGET),netware) -EXEEXT=.nlm -STATICLIBPREFIX= -FPCMADE=fpcmade.nw -ZIPSUFFIX=nw -endif -ifeq ($(OS_TARGET),macos) -EXEEXT= -FPCMADE=fpcmade.mcc -endif -else ifeq ($(OS_TARGET),go32v1) PPUEXT=.pp1 OEXT=.o1 @@ -654,8 +575,8 @@ ZIPSUFFIX=qnx endif ifeq ($(OS_TARGET),netware) STATICLIBPREFIX= -PPUEXT=.ppu -OEXT=.o +PPUEXT=.ppn +OEXT=.on ASMEXT=.s SMARTEXT=.sl STATICLIBEXT=.a @@ -673,7 +594,6 @@ STATICLIBEXT=.a EXEEXT= FPCMADE=fpcmade.mcc endif -endif ifndef ECHO ECHO:=$(strip $(wildcard $(addsuffix /gecho$(SRCEXEEXT),$(SEARCHPATH)))) ifeq ($(ECHO),) @@ -897,187 +817,90 @@ TAREXT=.tar.gz endif override REQUIRE_PACKAGES=rtl netdb libasync ifeq ($(OS_TARGET),linux) -ifeq ($(CPU_TARGET),i386) REQUIRE_PACKAGES_RTL=1 REQUIRE_PACKAGES_NETDB=1 REQUIRE_PACKAGES_LIBASYNC=1 endif -endif -ifeq ($(OS_TARGET),linux) -ifeq ($(CPU_TARGET),m68k) -REQUIRE_PACKAGES_RTL=1 -REQUIRE_PACKAGES_NETDB=1 -REQUIRE_PACKAGES_LIBASYNC=1 -endif -endif -ifeq ($(OS_TARGET),linux) -ifeq ($(CPU_TARGET),powerpc) -REQUIRE_PACKAGES_RTL=1 -REQUIRE_PACKAGES_NETDB=1 -REQUIRE_PACKAGES_LIBASYNC=1 -endif -endif -ifeq ($(OS_TARGET),linux) -ifeq ($(CPU_TARGET),sparc) -REQUIRE_PACKAGES_RTL=1 -REQUIRE_PACKAGES_NETDB=1 -REQUIRE_PACKAGES_LIBASYNC=1 -endif -endif -ifeq ($(OS_TARGET),linux) -ifeq ($(CPU_TARGET),x86_64) -REQUIRE_PACKAGES_RTL=1 -REQUIRE_PACKAGES_NETDB=1 -REQUIRE_PACKAGES_LIBASYNC=1 -endif -endif ifeq ($(OS_TARGET),go32v2) -ifeq ($(CPU_TARGET),i386) REQUIRE_PACKAGES_RTL=1 REQUIRE_PACKAGES_NETDB=1 REQUIRE_PACKAGES_LIBASYNC=1 endif -endif ifeq ($(OS_TARGET),win32) -ifeq ($(CPU_TARGET),i386) REQUIRE_PACKAGES_RTL=1 REQUIRE_PACKAGES_NETDB=1 REQUIRE_PACKAGES_LIBASYNC=1 endif -endif ifeq ($(OS_TARGET),os2) -ifeq ($(CPU_TARGET),i386) REQUIRE_PACKAGES_RTL=1 REQUIRE_PACKAGES_NETDB=1 REQUIRE_PACKAGES_LIBASYNC=1 endif -endif ifeq ($(OS_TARGET),freebsd) -ifeq ($(CPU_TARGET),i386) REQUIRE_PACKAGES_RTL=1 REQUIRE_PACKAGES_NETDB=1 REQUIRE_PACKAGES_LIBASYNC=1 endif -endif -ifeq ($(OS_TARGET),freebsd) -ifeq ($(CPU_TARGET),m68k) -REQUIRE_PACKAGES_RTL=1 -REQUIRE_PACKAGES_NETDB=1 -REQUIRE_PACKAGES_LIBASYNC=1 -endif -endif ifeq ($(OS_TARGET),beos) -ifeq ($(CPU_TARGET),i386) REQUIRE_PACKAGES_RTL=1 REQUIRE_PACKAGES_NETDB=1 REQUIRE_PACKAGES_LIBASYNC=1 endif -endif ifeq ($(OS_TARGET),netbsd) -ifeq ($(CPU_TARGET),i386) REQUIRE_PACKAGES_RTL=1 REQUIRE_PACKAGES_NETDB=1 REQUIRE_PACKAGES_LIBASYNC=1 endif -endif -ifeq ($(OS_TARGET),netbsd) -ifeq ($(CPU_TARGET),m68k) -REQUIRE_PACKAGES_RTL=1 -REQUIRE_PACKAGES_NETDB=1 -REQUIRE_PACKAGES_LIBASYNC=1 -endif -endif ifeq ($(OS_TARGET),amiga) -ifeq ($(CPU_TARGET),m68k) REQUIRE_PACKAGES_RTL=1 REQUIRE_PACKAGES_NETDB=1 REQUIRE_PACKAGES_LIBASYNC=1 endif -endif ifeq ($(OS_TARGET),atari) -ifeq ($(CPU_TARGET),m68k) REQUIRE_PACKAGES_RTL=1 REQUIRE_PACKAGES_NETDB=1 REQUIRE_PACKAGES_LIBASYNC=1 endif -endif ifeq ($(OS_TARGET),sunos) -ifeq ($(CPU_TARGET),i386) REQUIRE_PACKAGES_RTL=1 REQUIRE_PACKAGES_NETDB=1 REQUIRE_PACKAGES_LIBASYNC=1 endif -endif -ifeq ($(OS_TARGET),sunos) -ifeq ($(CPU_TARGET),sparc) -REQUIRE_PACKAGES_RTL=1 -REQUIRE_PACKAGES_NETDB=1 -REQUIRE_PACKAGES_LIBASYNC=1 -endif -endif ifeq ($(OS_TARGET),qnx) -ifeq ($(CPU_TARGET),i386) REQUIRE_PACKAGES_RTL=1 REQUIRE_PACKAGES_NETDB=1 REQUIRE_PACKAGES_LIBASYNC=1 endif -endif ifeq ($(OS_TARGET),netware) -ifeq ($(CPU_TARGET),i386) REQUIRE_PACKAGES_RTL=1 REQUIRE_PACKAGES_NETDB=1 REQUIRE_PACKAGES_LIBASYNC=1 endif -endif ifeq ($(OS_TARGET),openbsd) -ifeq ($(CPU_TARGET),i386) REQUIRE_PACKAGES_RTL=1 REQUIRE_PACKAGES_NETDB=1 REQUIRE_PACKAGES_LIBASYNC=1 endif -endif -ifeq ($(OS_TARGET),openbsd) -ifeq ($(CPU_TARGET),m68k) -REQUIRE_PACKAGES_RTL=1 -REQUIRE_PACKAGES_NETDB=1 -REQUIRE_PACKAGES_LIBASYNC=1 -endif -endif ifeq ($(OS_TARGET),wdosx) -ifeq ($(CPU_TARGET),i386) REQUIRE_PACKAGES_RTL=1 REQUIRE_PACKAGES_NETDB=1 REQUIRE_PACKAGES_LIBASYNC=1 endif -endif ifeq ($(OS_TARGET),palmos) -ifeq ($(CPU_TARGET),m68k) REQUIRE_PACKAGES_RTL=1 REQUIRE_PACKAGES_NETDB=1 REQUIRE_PACKAGES_LIBASYNC=1 endif -endif ifeq ($(OS_TARGET),macos) -ifeq ($(CPU_TARGET),powerpc) REQUIRE_PACKAGES_RTL=1 REQUIRE_PACKAGES_NETDB=1 REQUIRE_PACKAGES_LIBASYNC=1 endif -endif ifeq ($(OS_TARGET),macosx) -ifeq ($(CPU_TARGET),powerpc) REQUIRE_PACKAGES_RTL=1 REQUIRE_PACKAGES_NETDB=1 REQUIRE_PACKAGES_LIBASYNC=1 endif -endif -ifeq ($(OS_TARGET),emx) -ifeq ($(CPU_TARGET),i386) -REQUIRE_PACKAGES_RTL=1 -REQUIRE_PACKAGES_NETDB=1 -REQUIRE_PACKAGES_LIBASYNC=1 -endif -endif ifdef REQUIRE_PACKAGES_RTL PACKAGEDIR_RTL:=$(firstword $(subst /Makefile.fpc,,$(strip $(wildcard $(addsuffix /rtl/$(OS_TARGET)/Makefile.fpc,$(PACKAGESDIR)))))) ifneq ($(PACKAGEDIR_RTL),) @@ -1269,7 +1092,7 @@ override COMPILER:=$(FPC) $(FPCOPT) ifeq (,$(findstring -s ,$(COMPILER))) EXECPPAS= else -ifeq ($(FULL_SOURCE),$(FULL_TARGET)) +ifeq ($(OS_SOURCE),$(OS_TARGET)) EXECPPAS:=@$(PPAS) endif endif @@ -1282,6 +1105,18 @@ override INSTALLPPUFILES+=$(UNITPPUFILES) $(IMPLICITUNITPPUFILES) override CLEANPPUFILES+=$(UNITPPUFILES) $(IMPLICITUNITPPUFILES) endif fpc_units: $(UNITPPUFILES) +.PHONY: fpc_exes +ifdef TARGET_PROGRAMS +override EXEFILES=$(addsuffix $(EXEEXT),$(TARGET_PROGRAMS)) +override EXEOFILES:=$(addsuffix $(OEXT),$(TARGET_PROGRAMS)) $(addprefix $(STATICLIBPREFIX),$(addsuffix $(STATICLIBEXT),$(TARGET_PROGRAMS))) +override ALLTARGET+=fpc_exes +override INSTALLEXEFILES+=$(EXEFILES) +override CLEANEXEFILES+=$(EXEFILES) $(EXEOFILES) +ifeq ($(OS_TARGET),os2) +override CLEANEXEFILES+=$(addsuffix $(AOUTEXT),$(TARGET_PROGRAMS)) +endif +endif +fpc_exes: $(EXEFILES) ifdef TARGET_RSTS override RSTFILES=$(addsuffix $(RSTEXT),$(TARGET_RSTS)) override CLEANRSTFILES+=$(RSTFILES) @@ -1296,9 +1131,6 @@ override CLEANEXEFILES+=$(EXAMPLEFILES) $(EXAMPLEOFILES) ifeq ($(OS_TARGET),os2) override CLEANEXEFILES+=$(addsuffix $(AOUTEXT),$(TARGET_EXAMPLES)) endif -ifeq ($(OS_TARGET),emx) -override CLEANEXEFILES+=$(addsuffix $(AOUTEXT),$(TARGET_EXAMPLES)) -endif endif ifdef TARGET_EXAMPLEDIRS HASEXAMPLES=1 diff --git a/fcl/net/Makefile.fpc b/fcl/net/Makefile.fpc index bc2feff6b6..952fd621ed 100644 --- a/fcl/net/Makefile.fpc +++ b/fcl/net/Makefile.fpc @@ -11,10 +11,10 @@ units_linux=http httpsvlt xmlrpc units_freebsd=http httpsvlt xmlrpc units_netbsd=http httpsvlt xmlrpc units_openbsd=http httpsvlt xmlrpc -#programs_linux=mkxmlrpc -#programs_freebsd=mkxmlrpc -#programs_netbsd=mkxmlrpc -#programs_openbsd=mkxmlrpc +programs_linux=mkxmlrpc +programs_freebsd=mkxmlrpc +programs_netbsd=mkxmlrpc +programs_openbsd=mkxmlrpc rsts_linux=httpsvlt mkxmlrpc rsts_freebsd=httpsvlt mkxmlrpc rsts_netbsd=httpsvlt mkxmlrpc diff --git a/fcl/net/mkxmlrpc.pp b/fcl/net/mkxmlrpc.pp new file mode 100644 index 0000000000..49a17f1f29 --- /dev/null +++ b/fcl/net/mkxmlrpc.pp @@ -0,0 +1,773 @@ +{ + $Id$ + + Automatic XML-RPC wrapper generator + Copyright (c) 2003 by + Areca Systems GmbH / Sebastian Guenther, sg@freepascal.org + + See the file COPYING.FPC, included in this distribution, + for details about the copyright. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. +} + + +program MkXMLRPC; +uses SysUtils, Classes, PParser, PasTree, PasWrite; + +resourcestring + SCmdLineInvalidOption = 'Ignoring unknown option "%s"'; + SNoServerClassNameProvided = + 'No server class name provided (use --serverclass=)'; + SNoUnitNameProvided = + 'No name for generated unit provided (use --unitname=)'; + +type + TParserEngine = class(TPasTreeContainer) + protected + CurModule: TPasModule; + public + function CreateElement(AClass: TPTreeElement; const AName: String; + AParent: TPasElement; AVisibility: TPasMemberVisibility): TPasElement; + override; + function FindElement(const AName: String): TPasElement; override; +{ function FindModule(const AName: String): TPasModule; override;} + end; + + TServerClass = class + Element: TPasClassType; + ImplName: String; + end; + + TRPCList = class + constructor Create; + destructor Destroy; override; + procedure AddServerClass(const AClassName: String); + ServerClasses: TList; + UsedModules: TStringList; + end; + +var + Engine: TParserEngine; + + +function TParserEngine.CreateElement(AClass: TPTreeElement; const AName: String; + AParent: TPasElement; AVisibility: TPasMemberVisibility): TPasElement; +begin + Result := AClass.Create(AName, AParent); + Result.Visibility := AVisibility; + if AClass.InheritsFrom(TPasModule) then + CurModule := TPasModule(Result); +end; + +function TParserEngine.FindElement(const AName: String): TPasElement; + + function FindInModule(AModule: TPasModule; const LocalName: String): TPasElement; + var + l: TList; + i: Integer; + begin + l := AModule.InterfaceSection.Declarations; + for i := 0 to l.Count - 1 do + begin + Result := TPasElement(l[i]); + if CompareText(Result.Name, LocalName) = 0 then + exit; + end; + Result := nil; + end; + +var + i: Integer; + //ModuleName, LocalName: String; + Module: TPasElement; +begin +{!!!: Don't know if we ever will have to use the following: + i := Pos('.', AName); + if i <> 0 then + begin + WriteLn('Dot found in name: ', AName); + Result := nil; + end else + begin} + Result := FindInModule(CurModule, AName); + if not Assigned(Result) then + for i := CurModule.InterfaceSection.UsesList.Count - 1 downto 0 do + begin + Module := TPasElement(CurModule.InterfaceSection.UsesList[i]); + if Module.ClassType = TPasModule then + begin + Result := FindInModule(TPasModule(Module), AName); + if Assigned(Result) then + exit; + end; + end; + {end;} +end; + + +constructor TRPCList.Create; +begin + ServerClasses := TList.Create; + UsedModules := TStringList.Create; +end; + +destructor TRPCList.Destroy; +var + i: Integer; +begin + UsedModules.Free; + for i := 0 to ServerClasses.Count - 1 do + TServerClass(ServerClasses[i]).Free; + ServerClasses.Free; +end; + +procedure TRPCList.AddServerClass(const AClassName: String); +var + Element: TPasClassType; + ServerClass: TServerClass; +begin + Element := TPasClassType(Engine.FindElement(AClassName)); + if not Assigned(Element) then + begin + WriteLn(StdErr, 'Server class "', AClassName, '" not found!'); + Halt(3); + end; + if (not Element.InheritsFrom(TPasClassType)) or + (Element.ObjKind <> okClass) then + begin + WriteLn('"', AClassName, '" is not a class!'); + Halt(4); + end; + ServerClass := TServerClass.Create; + ServerClasses.Add(ServerClass); + ServerClass.Element := Element; + ServerClass.ImplName := Copy(Element.Name, 2, Length(Element.Name)); + UsedModules.Add(Element.GetModule.Name); +end; + + +var + OutputFilename, UnitName: String; + RPCList: TRPCList; + +procedure WriteClassServerSource(ServerClass: TPasClassType; + ImplementationSection: TPasSection; Method, ProcImpl: TPasProcedureImpl; + const MethodPrefix: String; NestingLevel: Integer); + +{ Method: Main server method + ProcImpl: Current procedure (may be identical with Method) } + +type + TConversionInfo = record + ConverterName: String; + ArgIsParent: Boolean; + end; + + function MakeStructConverter(AClass: TPasClassType; + Referrer: TPasProcedureImpl): TPasProcedureImpl; forward; + + function MakeArrayConverter(Member, ArraySizeProp: TPasProperty; + ProcessProc, Referrer: TPasProcedureImpl): TPasProcedureImpl; forward; + + function FindArraySizeProperty(AArrayProp: TPasProperty): TPasProperty; + var + i: Integer; + Name: String; + begin + Name := Copy(AArrayProp.Name, 1, Length(AArrayProp.Name) - 1) + 'Count'; + for i := 0 to TPasClassType(AArrayProp.Parent).Members.Count - 1 do + begin + Result := TPasProperty(TPasClassType(AArrayProp.Parent).Members[i]); + if (Result.ClassType = TPasProperty) and (Result.Visibility = visPublic) + and (CompareStr(Result.Name, Name) = 0) then + exit; + end; + Result := nil; + end; + + function GetConversionInfo(Element: TPasElement; + Referrer: TPasProcedureImpl): TConversionInfo; + var + s: String; + ArraySizeProp: TPasProperty; + begin + SetLength(Result.ConverterName, 0); + Result.ArgIsParent := False; + + if Element.ClassType = TPasProperty then + begin + ArraySizeProp := FindArraySizeProperty(TPasProperty(Element)); + if Assigned(ArraySizeProp) then + begin + Result.ConverterName := MakeArrayConverter(TPasProperty(Element), + ArraySizeProp, ProcImpl, Referrer).Name; + Result.ArgIsParent := True; + exit; + end else + Element := TPasProperty(Element).VarType; + end; + + if Element.ClassType = TPasUnresolvedTypeRef then + begin + s := UpperCase(Element.Name); + if (s = 'BYTE') or (s = 'SHORTINT') or (S = 'SMALLINT') or + (s = 'INTEGER') or (s = 'LONGINT') or (s = 'CARDINAL') or + (s = 'INT64') or (s = 'QUADWORD') then + Result.ConverterName := 'AWriter.CreateIntValue' + else if (s = 'BOOLEAN') or (s = 'WORDBOOL') or (s = 'LONGBOOL') then + Result.ConverterName := 'AWriter.CreateBooleanValue' + else if s = 'STRING' then + Result.ConverterName := 'AWriter.CreateStringValue' + else if (s = 'FLOAT') or (s = 'SINGLE') or (s = 'DOUBLE') or + (s = 'EXTENDED') then + Result.ConverterName := 'AWriter.CreateDoubleValue'; + end else if Element.ClassType = TPasClassType then + Result.ConverterName := MakeStructConverter(TPasClassType(Element), Referrer).Name; + + if Length(Result.ConverterName) = 0 then + raise Exception.Create('Result type not supported: ' + Element.ClassName + + ' ' + Element.Name); + end; + + function GetParseValueFnName(PasType: TPasType): String; + var + s: String; + begin + SetLength(Result, 0); + if PasType.ClassType = TPasArgument then + begin + if TPasArgument(PasType).Access = argVar then + raise Exception.Create('"var" arguments are not allowed'); + PasType := TPasArgument(PasType).ArgType; + end; + + if PasType.ClassType = TPasUnresolvedTypeRef then + begin + s := UpperCase(PasType.Name); + if (s = 'BYTE') or (s = 'SHORTINT') or (S = 'SMALLINT') or + (s = 'INTEGER') or (s = 'LONGINT') or (s = 'CARDINAL') or + (s = 'INT64') or (s = 'QUADWORD') then + Result := 'Int' + else if (s = 'BOOLEAN') or (s = 'WORDBOOL') or (s = 'LONGBOOL') then + Result := 'Boolean' + else if s = 'STRING' then + Result := 'String' + else if (s = 'FLOAT') or (s = 'SINGLE') or (s = 'DOUBLE') or + (s = 'EXTENDED') then + Result := 'Double'; + end; + if Length(Result) = 0 then + raise Exception.Create('Argument type not supported: ' + + PasType.ClassName + ' ' + PasType.Name); + end; + + function NeedLocalProc(const ProcName: String; + Referrer: TPasProcedureImpl): TPasProcedureImpl; + var + i, j: Integer; + begin + for i := 0 to Method.Locals.Count - 1 do + begin + Result := TPasProcedureImpl(Method.Locals[i]); + if Result.Name = ProcName then + begin + j := Method.Locals.IndexOf(Referrer); + if (j >= 0) and (i >= j) then + begin + // Move existing converter to the top and exit + Method.Locals.Delete(i); + Method.Locals.Insert(Method.Locals.IndexOf(ProcImpl), Result); + end; + exit; + end; + end; + Result := nil; + end; + + function MakeStructConverter(AClass: TPasClassType; + Referrer: TPasProcedureImpl): TPasProcedureImpl; + var + ConverterName, s: String; + Commands: TPasImplCommands; + i: Integer; + LocalMember: TPasElement; + ConversionInfo: TConversionInfo; + begin + ConverterName := 'Convert' + AClass.Name; + Result := NeedLocalProc(ConverterName, Referrer); + if Assigned(Result) then + exit; + + Result := TPasProcedureImpl.Create(ConverterName, Method); + Method.Locals.Insert(Method.Locals.IndexOf(Referrer), Result); + Result.ProcType := TPasFunctionType.Create('', Result); + Result.ProcType.CreateArgument('Inst', AClass.Name); + TPasFunctionType(Result.ProcType).ResultEl := + TPasResultElement.Create('', Result); + TPasFunctionType(Result.ProcType).ResultEl.ResultType := + TPasUnresolvedTypeRef.Create('TXMLRPCStruct', Result); + + Result.Body := TPasImplBlock.Create('', Result); + Commands := Result.Body.AddCommands; + Commands.Commands.Add('Result := AWriter.CreateStruct'); + for i := 0 to AClass.Members.Count - 1 do + begin + LocalMember := TPasElement(AClass.Members[i]); + if LocalMember.ClassType = TPasProperty then + begin + ConversionInfo := GetConversionInfo(LocalMember, Result); + s := 'AWriter.AddStructMember(Result, ''' + LocalMember.Name + ''', ' + + ConversionInfo.ConverterName; + if ConversionInfo.ArgIsParent then + s := s + '(Inst))' + else + s := s + '(Inst.' + LocalMember.Name + '))'; + Commands.Commands.Add(s); + end; + end; + end; + + function MakeArrayConverter(Member, ArraySizeProp: TPasProperty; + ProcessProc, Referrer: TPasProcedureImpl): TPasProcedureImpl; + var + i: Integer; + ConverterName, s: String; + Commands: TPasImplCommands; + VarMember: TPasVariable; + ForLoop: TPasImplForLoop; + ConversionInfo: TConversionInfo; + begin + ConverterName := 'Convert' + Member.Parent.Name + '_' + Member.Name; + Result := NeedLocalProc(ConverterName, Referrer); + if Assigned(Result) then + exit; + + Result := TPasProcedureImpl.Create(ConverterName, Method); + i := Method.Locals.IndexOf(Referrer); + if i < 0 then + i := 0; + Method.Locals.Insert(i, Result); + Result.ProcType := TPasFunctionType.Create('', Result); + Result.ProcType.CreateArgument('Inst', Member.Parent.Name); + TPasFunctionType(Result.ProcType).ResultEl := + TPasResultElement.Create('', Result); + TPasFunctionType(Result.ProcType).ResultEl.ResultType := + TPasUnresolvedTypeRef.Create('TXMLRPCArray', Result); + + Result.Body := TPasImplBlock.Create('', Result); + Commands := Result.Body.AddCommands; + Commands.Commands.Add('Result := AWriter.CreateArray'); + + VarMember := TPasVariable.Create('i', Result); + Result.Locals.Add(VarMember); + VarMember.VarType := TPasUnresolvedTypeRef.Create('Integer', VarMember); + + ForLoop := Result.Body.AddForLoop(TPasVariable.Create('i', Result), + '0', MethodPrefix + ArraySizeProp.Name + ' - 1'); + ForLoop.Body := TPasImplCommand.Create('', ForLoop); + ConversionInfo := GetConversionInfo(Member.VarType, Result); + s := 'AWriter.AddArrayElement(Result, ' + ConversionInfo.ConverterName; + if ConversionInfo.ArgIsParent then + s := s + '(Inst))' + else + s := s + '(Inst.' + Member.Name + '[i]))'; + TPasImplCommand(ForLoop.Body).Command := s; + end; + + function CreateDispatcher(VarType: TPasClassType; + Referrer: TPasProcedureImpl): TPasProcedureImpl; + var + DispatcherName: String; + begin + DispatcherName := 'Dispatch' + VarType.Name; + Result := NeedLocalProc(DispatcherName, Referrer); + if Assigned(Result) then + exit; + + // Create new dispatcher method + Result := TPasProcedureImpl.Create(DispatcherName, Method); + if ProcImpl = Method then + Method.Locals.Insert(0, Result) + else + Method.Locals.Insert(Method.Locals.IndexOf(Referrer), Result); + Result.ProcType := TPasProcedureType.Create('', Result); + Result.ProcType.CreateArgument('Inst', VarType.Name); + Result.ProcType.CreateArgument('Level', 'Integer'); + WriteClassServerSource(VarType, + ImplementationSection, Method, Result, 'Inst.', NestingLevel + 1); + end; + + +var + IfElse, ParentIfElse: TPasImplIfElse; + + procedure CreateBranch(const MethodName: String); + begin + if Assigned(ParentIfElse) then + begin + IfElse := TPasImplIfElse.Create('', ParentIfElse); + ParentIfElse.ElseBranch := IfElse; + end else + begin + IfElse := TPasImplIfElse.Create('', ProcImpl.Body); + ProcImpl.Body.Elements.Add(IfElse); + end; + ParentIfElse := IfElse; + IfElse.Condition := 's = ''' + UpperCase(MethodName) + ''''; + end; + + procedure ProcessMethodCall(Member: TPasProcedure); + + function MakeProcArgs(Args: TList): String; + var + i: Integer; + begin + if (not Assigned(Args)) or (Args.Count = 0) then + Result := '' + else + begin + Result := '('; + for i := 0 to Args.Count - 1 do + begin + if i > 0 then + Result := Result + ', '; + Result := Result + 'AParser.GetPrev' + GetParseValueFnName(TPasType(Args[i])); + end; + Result := Result + ')'; + end; + end; + + var + Commands: TPasImplCommands; + begin + CreateBranch(Member.Name); + Commands := TPasImplCommands.Create('', IfElse); + IfElse.IfBranch := Commands; + + if TPasProcedure(Member).ProcType.Args.Count > 0 then + Commands.Commands.Add('AParser.ResetValueCursor'); + if Member.ClassType = TPasProcedure then + begin + Commands.Commands.Add(MethodPrefix + Member.Name + + MakeProcArgs(TPasProcedure(Member).ProcType.Args)); + Commands.Commands.Add('AWriter.WriteResponse(nil)'); + end else + begin + // function + Commands.Commands.Add('AWriter.WriteResponse(' + + GetConversionInfo(TPasFunctionType(TPasFunction(Member).ProcType). + ResultEl.ResultType, ProcImpl).ConverterName + '(' + MethodPrefix + + Member.Name + MakeProcArgs(TPasProcedure(Member).ProcType.Args) + '))'); + end; + end; + + procedure ProcessProperty(Member: TPasProperty); + var + LocalIfElse: TPasImplIfElse; + IsArray, IsStruct: Boolean; + s, s2: String; + Commands: TPasImplCommands; + Command: TPasImplCommand; + ConversionInfo: TConversionInfo; + begin + if Member.ReadAccessorName <> '' then + begin + CreateBranch('Get' + Member.Name); + + IsArray := (Member.Args.Count = 1) and + Assigned(FindArraySizeProperty(Member)); + IsStruct := Member.VarType.ClassType = TPasClassType; + + if IsStruct then + s := CreateDispatcher(TPasClassType(Member.VarType), ProcImpl).Name + + '(' + MethodPrefix + Member.Name; + + if NestingLevel = 0 then + s2 := '1' + else + s2 := 'Level + 1'; + + if IsArray or (IsStruct and (Member.Args.Count = 0)) then + begin + LocalIfElse := TPasImplIfElse.Create('', IfElse); + IfElse.IfBranch := LocalIfElse; + LocalIfElse.Condition := 'APath.Count <= ' + s2; + end; + + if IsStruct then + if IsArray then + begin + LocalIfElse.IfBranch := TPasImplCommand.Create('', LocalIfElse); + TPasImplCommand(LocalIfElse.IfBranch).Command := + 'AWriter.WriteResponse(' + + GetConversionInfo(Member, ProcImpl).ConverterName + '(' + + Copy(MethodPrefix, 1, Length(MethodPrefix) - 1) + '))'; + + LocalIfElse.ElseBranch := TPasImplCommand.Create('', LocalIfElse); + TPasImplCommand(LocalIfElse.ElseBranch).Command := + s + '[AParser.GetNext' + + GetParseValueFnName(TPasArgument(Member.Args[0]).ArgType) + '], ' + + s2 + ')'; + end else + begin + if Member.Args.Count = 0 then + begin + LocalIfElse.IfBranch := TPasImplCommand.Create('', LocalIfElse); + TPasImplCommand(LocalIfElse.IfBranch).Command := + 'AWriter.WriteResponse(' + + GetConversionInfo(Member, ProcImpl).ConverterName + '(' + + MethodPrefix + Member.Name + '))'; + LocalIfElse.ElseBranch := TPasImplCommand.Create('', LocalIfElse); + TPasImplCommand(LocalIfElse.ElseBranch).Command := s + ', ' + s2 + ')'; + end else + begin + IfElse.IfBranch := TPasImplCommand.Create('', IfElse); + TPasImplCommand(IfElse.IfBranch).Command := s + '[AParser.GetNext' + + GetParseValueFnName(TPasArgument(Member.Args[0]).ArgType) + '], ' + + s2 + ')'; + end; + end + else if IsArray then + begin + LocalIfElse.IfBranch := TPasImplCommand.Create('', LocalIfElse); + TPasImplCommand(LocalIfElse.IfBranch).Command := + 'AWriter.WriteResponse(' + + GetConversionInfo(Member, ProcImpl).ConverterName + '(' + + Copy(MethodPrefix, 1, Length(MethodPrefix) - 1) + '))'; + + LocalIfElse.ElseBranch := TPasImplCommand.Create('', LocalIfElse); + TPasImplCommand(LocalIfElse.ElseBranch).Command := + 'AWriter.WriteResponse(' + + GetConversionInfo(Member.VarType, ProcImpl).ConverterName + '(' + + MethodPrefix + Member.Name + '[AParser.GetNext' + + GetParseValueFnName(TPasArgument(Member.Args[0]).ArgType) + ']))'; + end else + begin + IfElse.IfBranch := TPasImplCommand.Create('', IfElse); + TPasImplCommand(IfElse.IfBranch).Command := 'AWriter.WriteResponse(' + + GetConversionInfo(Member.VarType, ProcImpl).ConverterName + '(' + + MethodPrefix + Member.Name + '))'; + end; + end; + + if Member.WriteAccessorName <> '' then + begin + CreateBranch('Set' + Member.Name); + Commands := TPasImplCommands.Create('', IfElse); + IfElse.IfBranch := Commands; + Commands.Commands.Add('// Not supported by mkxmlrpc yet'); + end; + end; + +var + VarMember: TPasVariable; + i: Integer; + Command: TPasImplCommand; + Member: TPasElement; +begin + VarMember := TPasVariable.Create('s', ProcImpl); + ProcImpl.Locals.Add(VarMember); + VarMember.VarType := TPasUnresolvedTypeRef.Create('String', VarMember); + ProcImpl.Body := TPasImplBlock.Create('', ProcImpl); + if NestingLevel = 0 then + ProcImpl.Body.AddCommand('s := APath[' + IntToStr(NestingLevel) + ']') + else + ProcImpl.Body.AddCommand('s := APath[Level]'); + ParentIfElse := nil; + for i := 0 to ServerClass.Members.Count - 1 do + begin + Member := TPasElement(ServerClass.Members[i]); + if Member.Visibility <> visPublic then + continue; + + if (Member.ClassType = TPasProcedure) or (Member.ClassType = TPasFunction) + then + ProcessMethodCall(TPasProcedure(Member)) + else if Member.ClassType = TPasProperty then + ProcessProperty(TPasProperty(Member)) + else if (Member.ClassType <> TPasConstructor) and + (Member.ClassType <> TPasDestructor) then + WriteLn('Warning: Unsupportet member type: ', Member.ElementTypeName); + end; + + if Assigned(ParentIfElse) then + begin + Command := TPasImplCommand.Create('', ParentIfElse); + ParentIfElse.ElseBranch := Command; + end else + begin + Command := TPasImplCommand.Create('', ProcImpl.Body); + ProcImpl.Body.Elements.Add(Command); + end; + Command.Command := 'AWriter.WriteFaultResponse(2, ''Invalid method name'')'; +end; + +procedure WriteFPCServerSource; +var + i: Integer; + Module: TPasModule; + InterfaceSection, ImplementationSection: TPasSection; + VarMember: TPasVariable; + PropertyMember: TPasProperty; + ProcMember: TPasProcedure; + Arg: TPasArgument; + ServerClass: TPasClassType; + Stream: TStream; + ProcImpl: TPasProcedureImpl; +begin + Module := TPasModule.Create(UnitName, nil); + try + InterfaceSection := TPasSection.Create('', Module); + Module.InterfaceSection := InterfaceSection; + ImplementationSection := TPasSection.Create('', Module); + Module.ImplementationSection := ImplementationSection; + InterfaceSection.AddUnitToUsesList('Classes'); + InterfaceSection.AddUnitToUsesList('XMLRPC'); + for i := 0 to RPCList.UsedModules.Count - 1 do + InterfaceSection.AddUnitToUsesList(RPCList.UsedModules[i]); + + for i := 0 to RPCList.ServerClasses.Count - 1 do + with TServerClass(RPCList.ServerClasses[i]) do + begin + ServerClass := TPasClassType.Create('T' + ImplName + 'XMLRPCServlet', + InterfaceSection); + InterfaceSection.Declarations.Add(ServerClass); + ServerClass.ObjKind := okClass; + ServerClass.AncestorType := + TPasUnresolvedTypeRef.Create('TXMLRPCServlet', ServerClass); + + // Create private field which holds the implementation instance + VarMember := TPasVariable.Create('F' + ImplName, ServerClass); + VarMember.Visibility := visPrivate; + VarMember.VarType := TPasUnresolvedTypeRef.Create(Element.Name, VarMember); + ServerClass.Members.Add(VarMember); + + // Create dispatcher method + ProcMember := TPasProcedure.Create('Dispatch', ServerClass); + ProcMember.Visibility := visProtected; + ProcMember.IsOverride := True; + ProcMember.ProcType := TPasProcedureType.Create('', ProcMember); + ProcMember.ProcType.CreateArgument('AParser', 'TXMLRPCParser'). + Visibility := visPublic; + ProcMember.ProcType.CreateArgument('AWriter', 'TXMLRPCWriter'). + Visibility := visPublic; + ProcMember.ProcType.CreateArgument('APath', 'TStrings'). + Visibility := visPublic; + ServerClass.Members.Add(ProcMember); + + // Create published property for implementation instance + PropertyMember := TPasProperty.Create(ImplName, ServerClass); + PropertyMember.Visibility := visPublished; + PropertyMember.VarType := VarMember.VarType; + VarMember.VarType.AddRef; + PropertyMember.ReadAccessorName := 'F' + ImplName; + PropertyMember.WriteAccessorName := 'F' + ImplName; + ServerClass.Members.Add(PropertyMember); + + // Create dispatcher implementation + ProcImpl := TPasProcedureImpl.Create('Dispatch', ServerClass); + ImplementationSection.Declarations.Add(ProcImpl); + ProcImpl.ProcType := ProcMember.ProcType; + ProcMember.ProcType.AddRef; + ProcImpl.ProcType.AddRef; + WriteClassServerSource(Element, ImplementationSection, ProcImpl, + ProcImpl, ImplName + '.', 0); + end; + + Stream := THandleStream.Create(StdOutputHandle); + try + WritePasFile(Module, Stream); + finally + Stream.Free; + end; + + Stream := TFileStream.Create(OutputFilename, fmCreate); + try + WritePasFile(Module, Stream); + finally + Stream.Free; + end; + finally + Module.Free; + end; +end; + + +var + i, j: Integer; + s, Cmd, Arg: String; + InputFiles, ClassList: TStringList; +begin + InputFiles := TStringList.Create; + ClassList := TStringList.Create; + try + for i := 1 to ParamCount do + begin + s := ParamStr(i); + j := Pos('=', s); + if j > 0 then + begin + Cmd := Copy(s, 1, j - 1); + Arg := Copy(s, j + 1, Length(s)); + end else + begin + Cmd := s; + SetLength(Arg, 0); + end; + if (Cmd = '-i') or (Cmd = '--input') then + InputFiles.Add(Arg) + else if Cmd = '--output' then + OutputFilename := Arg + else if Cmd = '--unitname' then + UnitName := Arg + else if Cmd = '--serverclass' then + ClassList.Add(Arg) + else + WriteLn(StdErr, Format(SCmdLineInvalidOption, [s])); + end; + + if ClassList.Count = 0 then + begin + WriteLn(StdErr, SNoServerClassNameProvided); + Halt(2); + end; + + if UnitName = '' then + begin + WriteLn(StdErr, SNoUnitNameProvided); + Halt(2); + end; + + Engine := TParserEngine.Create; + try + // Engine.SetPackageName('XMLRPC'); + for i := 0 to InputFiles.Count - 1 do + ParseSource(Engine, InputFiles[i], '', ''); + + RPCList := TRPCList.Create; + try + for i := 0 to ClassList.Count - 1 do + RPCList.AddServerClass(ClassList[i]); + WriteFPCServerSource; + finally + RPCList.Free; + end; + finally + Engine.Free; + end; + finally + InputFiles.Free; + ClassList.Free; + end; +end. + + +{ + $Log$ + Revision 1.1 2003-04-26 16:42:10 sg + * Added mkxmlrpc + +}