pascal/lazarus-ccr
1
0
Fork 0
Code Issues Releases Activity

made a copy

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@186 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
inoussa
2007-06-23 13:41:44 +00:00
parent 1eda83ee33
commit c3e6d4b260
181 changed files with 67362 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

481
wst/tags/0.4/COPYING.LGPL Normal file
View File

@ -0,0 +1,481 @@
GNU LIBRARY GENERAL PUBLIC LICENSE
Version 2, June 1991
Copyright (C) 1991 Free Software Foundation, Inc.
59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
Everyone is permitted to copy and distribute verbatim copies
of this license document, but changing it is not allowed.
[This is the first released version of the library GPL. It is
numbered 2 because it goes with version 2 of the ordinary GPL.]
Preamble
The licenses for most software are designed to take away your
freedom to share and change it. By contrast, the GNU General Public
Licenses are intended to guarantee your freedom to share and change
free software--to make sure the software is free for all its users.
This license, the Library General Public License, applies to some
specially designated Free Software Foundation software, and to any
other libraries whose authors decide to use it. You can use it for
your libraries, too.
When we speak of free software, we are referring to freedom, not
price. Our General Public Licenses are designed to make sure that you
have the freedom to distribute copies of free software (and charge for
this service if you wish), that you receive source code or can get it
if you want it, that you can change the software or use pieces of it
in new free programs; and that you know you can do these things.
To protect your rights, we need to make restrictions that forbid
anyone to deny you these rights or to ask you to surrender the rights.
These restrictions translate to certain responsibilities for you if
you distribute copies of the library, or if you modify it.
For example, if you distribute copies of the library, whether gratis
or for a fee, you must give the recipients all the rights that we gave
you. You must make sure that they, too, receive or can get the source
code. If you link a program with the library, you must provide
complete object files to the recipients so that they can relink them
with the library, after making changes to the library and recompiling
it. And you must show them these terms so they know their rights.
Our method of protecting your rights has two steps: (1) copyright
the library, and (2) offer you this license which gives you legal
permission to copy, distribute and/or modify the library.
Also, for each distributor's protection, we want to make certain
that everyone understands that there is no warranty for this free
library. If the library is modified by someone else and passed on, we
want its recipients to know that what they have is not the original
version, so that any problems introduced by others will not reflect on
the original authors' reputations.
Finally, any free program is threatened constantly by software
patents. We wish to avoid the danger that companies distributing free
software will individually obtain patent licenses, thus in effect
transforming the program into proprietary software. To prevent this,
we have made it clear that any patent must be licensed for everyone's
free use or not licensed at all.
Most GNU software, including some libraries, is covered by the ordinary
GNU General Public License, which was designed for utility programs. This
license, the GNU Library General Public License, applies to certain
designated libraries. This license is quite different from the ordinary
one; be sure to read it in full, and don't assume that anything in it is
the same as in the ordinary license.
The reason we have a separate public license for some libraries is that
they blur the distinction we usually make between modifying or adding to a
program and simply using it. Linking a program with a library, without
changing the library, is in some sense simply using the library, and is
analogous to running a utility program or application program. However, in
a textual and legal sense, the linked executable is a combined work, a
derivative of the original library, and the ordinary General Public License
treats it as such.
Because of this blurred distinction, using the ordinary General
Public License for libraries did not effectively promote software
sharing, because most developers did not use the libraries. We
concluded that weaker conditions might promote sharing better.
However, unrestricted linking of non-free programs would deprive the
users of those programs of all benefit from the free status of the
libraries themselves. This Library General Public License is intended to
permit developers of non-free programs to use free libraries, while
preserving your freedom as a user of such programs to change the free
libraries that are incorporated in them. (We have not seen how to achieve
this as regards changes in header files, but we have achieved it as regards
changes in the actual functions of the Library.) The hope is that this
will lead to faster development of free libraries.
The precise terms and conditions for copying, distribution and
modification follow. Pay close attention to the difference between a
"work based on the library" and a "work that uses the library". The
former contains code derived from the library, while the latter only
works together with the library.
Note that it is possible for a library to be covered by the ordinary
General Public License rather than by this special one.
GNU LIBRARY GENERAL PUBLIC LICENSE
TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
0. This License Agreement applies to any software library which
contains a notice placed by the copyright holder or other authorized
party saying it may be distributed under the terms of this Library
General Public License (also called "this License"). Each licensee is
addressed as "you".
A "library" means a collection of software functions and/or data
prepared so as to be conveniently linked with application programs
(which use some of those functions and data) to form executables.
The "Library", below, refers to any such software library or work
which has been distributed under these terms. A "work based on the
Library" means either the Library or any derivative work under
copyright law: that is to say, a work containing the Library or a
portion of it, either verbatim or with modifications and/or translated
straightforwardly into another language. (Hereinafter, translation is
included without limitation in the term "modification".)
"Source code" for a work means the preferred form of the work for
making modifications to it. For a library, complete source code means
all the source code for all modules it contains, plus any associated
interface definition files, plus the scripts used to control compilation
and installation of the library.
Activities other than copying, distribution and modification are not
covered by this License; they are outside its scope. The act of
running a program using the Library is not restricted, and output from
such a program is covered only if its contents constitute a work based
on the Library (independent of the use of the Library in a tool for
writing it). Whether that is true depends on what the Library does
and what the program that uses the Library does.
1. You may copy and distribute verbatim copies of the Library's
complete source code as you receive it, in any medium, provided that
you conspicuously and appropriately publish on each copy an
appropriate copyright notice and disclaimer of warranty; keep intact
all the notices that refer to this License and to the absence of any
warranty; and distribute a copy of this License along with the
Library.
You may charge a fee for the physical act of transferring a copy,
and you may at your option offer warranty protection in exchange for a
fee.
2. You may modify your copy or copies of the Library or any portion
of it, thus forming a work based on the Library, and copy and
distribute such modifications or work under the terms of Section 1
above, provided that you also meet all of these conditions:
a) The modified work must itself be a software library.
b) You must cause the files modified to carry prominent notices
stating that you changed the files and the date of any change.
c) You must cause the whole of the work to be licensed at no
charge to all third parties under the terms of this License.
d) If a facility in the modified Library refers to a function or a
table of data to be supplied by an application program that uses
the facility, other than as an argument passed when the facility
is invoked, then you must make a good faith effort to ensure that,
in the event an application does not supply such function or
table, the facility still operates, and performs whatever part of
its purpose remains meaningful.
(For example, a function in a library to compute square roots has
a purpose that is entirely well-defined independent of the
application. Therefore, Subsection 2d requires that any
application-supplied function or table used by this function must
be optional: if the application does not supply it, the square
root function must still compute square roots.)
These requirements apply to the modified work as a whole. If
identifiable sections of that work are not derived from the Library,
and can be reasonably considered independent and separate works in
themselves, then this License, and its terms, do not apply to those
sections when you distribute them as separate works. But when you
distribute the same sections as part of a whole which is a work based
on the Library, the distribution of the whole must be on the terms of
this License, whose permissions for other licensees extend to the
entire whole, and thus to each and every part regardless of who wrote
it.
Thus, it is not the intent of this section to claim rights or contest
your rights to work written entirely by you; rather, the intent is to
exercise the right to control the distribution of derivative or
collective works based on the Library.
In addition, mere aggregation of another work not based on the Library
with the Library (or with a work based on the Library) on a volume of
a storage or distribution medium does not bring the other work under
the scope of this License.
3. You may opt to apply the terms of the ordinary GNU General Public
License instead of this License to a given copy of the Library. To do
this, you must alter all the notices that refer to this License, so
that they refer to the ordinary GNU General Public License, version 2,
instead of to this License. (If a newer version than version 2 of the
ordinary GNU General Public License has appeared, then you can specify
that version instead if you wish.) Do not make any other change in
these notices.
Once this change is made in a given copy, it is irreversible for
that copy, so the ordinary GNU General Public License applies to all
subsequent copies and derivative works made from that copy.
This option is useful when you wish to copy part of the code of
the Library into a program that is not a library.
4. You may copy and distribute the Library (or a portion or
derivative of it, under Section 2) in object code or executable form
under the terms of Sections 1 and 2 above provided that you accompany
it with the complete corresponding machine-readable source code, which
must be distributed under the terms of Sections 1 and 2 above on a
medium customarily used for software interchange.
If distribution of object code is made by offering access to copy
from a designated place, then offering equivalent access to copy the
source code from the same place satisfies the requirement to
distribute the source code, even though third parties are not
compelled to copy the source along with the object code.
5. A program that contains no derivative of any portion of the
Library, but is designed to work with the Library by being compiled or
linked with it, is called a "work that uses the Library". Such a
work, in isolation, is not a derivative work of the Library, and
therefore falls outside the scope of this License.
However, linking a "work that uses the Library" with the Library
creates an executable that is a derivative of the Library (because it
contains portions of the Library), rather than a "work that uses the
library". The executable is therefore covered by this License.
Section 6 states terms for distribution of such executables.
When a "work that uses the Library" uses material from a header file
that is part of the Library, the object code for the work may be a
derivative work of the Library even though the source code is not.
Whether this is true is especially significant if the work can be
linked without the Library, or if the work is itself a library. The
threshold for this to be true is not precisely defined by law.
If such an object file uses only numerical parameters, data
structure layouts and accessors, and small macros and small inline
functions (ten lines or less in length), then the use of the object
file is unrestricted, regardless of whether it is legally a derivative
work. (Executables containing this object code plus portions of the
Library will still fall under Section 6.)
Otherwise, if the work is a derivative of the Library, you may
distribute the object code for the work under the terms of Section 6.
Any executables containing that work also fall under Section 6,
whether or not they are linked directly with the Library itself.
6. As an exception to the Sections above, you may also compile or
link a "work that uses the Library" with the Library to produce a
work containing portions of the Library, and distribute that work
under terms of your choice, provided that the terms permit
modification of the work for the customer's own use and reverse
engineering for debugging such modifications.
You must give prominent notice with each copy of the work that the
Library is used in it and that the Library and its use are covered by
this License. You must supply a copy of this License. If the work
during execution displays copyright notices, you must include the
copyright notice for the Library among them, as well as a reference
directing the user to the copy of this License. Also, you must do one
of these things:
a) Accompany the work with the complete corresponding
machine-readable source code for the Library including whatever
changes were used in the work (which must be distributed under
Sections 1 and 2 above); and, if the work is an executable linked
with the Library, with the complete machine-readable "work that
uses the Library", as object code and/or source code, so that the
user can modify the Library and then relink to produce a modified
executable containing the modified Library. (It is understood
that the user who changes the contents of definitions files in the
Library will not necessarily be able to recompile the application
to use the modified definitions.)
b) Accompany the work with a written offer, valid for at
least three years, to give the same user the materials
specified in Subsection 6a, above, for a charge no more
than the cost of performing this distribution.
c) If distribution of the work is made by offering access to copy
from a designated place, offer equivalent access to copy the above
specified materials from the same place.
d) Verify that the user has already received a copy of these
materials or that you have already sent this user a copy.
For an executable, the required form of the "work that uses the
Library" must include any data and utility programs needed for
reproducing the executable from it. However, as a special exception,
the source code distributed need not include anything that is normally
distributed (in either source or binary form) with the major
components (compiler, kernel, and so on) of the operating system on
which the executable runs, unless that component itself accompanies
the executable.
It may happen that this requirement contradicts the license
restrictions of other proprietary libraries that do not normally
accompany the operating system. Such a contradiction means you cannot
use both them and the Library together in an executable that you
distribute.
7. You may place library facilities that are a work based on the
Library side-by-side in a single library together with other library
facilities not covered by this License, and distribute such a combined
library, provided that the separate distribution of the work based on
the Library and of the other library facilities is otherwise
permitted, and provided that you do these two things:
a) Accompany the combined library with a copy of the same work
based on the Library, uncombined with any other library
facilities. This must be distributed under the terms of the
Sections above.
b) Give prominent notice with the combined library of the fact
that part of it is a work based on the Library, and explaining
where to find the accompanying uncombined form of the same work.
8. You may not copy, modify, sublicense, link with, or distribute
the Library except as expressly provided under this License. Any
attempt otherwise to copy, modify, sublicense, link with, or
distribute the Library is void, and will automatically terminate your
rights under this License. However, parties who have received copies,
or rights, from you under this License will not have their licenses
terminated so long as such parties remain in full compliance.
9. You are not required to accept this License, since you have not
signed it. However, nothing else grants you permission to modify or
distribute the Library or its derivative works. These actions are
prohibited by law if you do not accept this License. Therefore, by
modifying or distributing the Library (or any work based on the
Library), you indicate your acceptance of this License to do so, and
all its terms and conditions for copying, distributing or modifying
the Library or works based on it.
10. Each time you redistribute the Library (or any work based on the
Library), the recipient automatically receives a license from the
original licensor to copy, distribute, link with or modify the Library
subject to these terms and conditions. You may not impose any further
restrictions on the recipients' exercise of the rights granted herein.
You are not responsible for enforcing compliance by third parties to
this License.
11. If, as a consequence of a court judgment or allegation of patent
infringement or for any other reason (not limited to patent issues),
conditions are imposed on you (whether by court order, agreement or
otherwise) that contradict the conditions of this License, they do not
excuse you from the conditions of this License. If you cannot
distribute so as to satisfy simultaneously your obligations under this
License and any other pertinent obligations, then as a consequence you
may not distribute the Library at all. For example, if a patent
license would not permit royalty-free redistribution of the Library by
all those who receive copies directly or indirectly through you, then
the only way you could satisfy both it and this License would be to
refrain entirely from distribution of the Library.
If any portion of this section is held invalid or unenforceable under any
particular circumstance, the balance of the section is intended to apply,
and the section as a whole is intended to apply in other circumstances.
It is not the purpose of this section to induce you to infringe any
patents or other property right claims or to contest validity of any
such claims; this section has the sole purpose of protecting the
integrity of the free software distribution system which is
implemented by public license practices. Many people have made
generous contributions to the wide range of software distributed
through that system in reliance on consistent application of that
system; it is up to the author/donor to decide if he or she is willing
to distribute software through any other system and a licensee cannot
impose that choice.
This section is intended to make thoroughly clear what is believed to
be a consequence of the rest of this License.
12. If the distribution and/or use of the Library is restricted in
certain countries either by patents or by copyrighted interfaces, the
original copyright holder who places the Library under this License may add
an explicit geographical distribution limitation excluding those countries,
so that distribution is permitted only in or among countries not thus
excluded. In such case, this License incorporates the limitation as if
written in the body of this License.
13. The Free Software Foundation may publish revised and/or new
versions of the Library General Public License from time to time.
Such new versions will be similar in spirit to the present version,
but may differ in detail to address new problems or concerns.
Each version is given a distinguishing version number. If the Library
specifies a version number of this License which applies to it and
"any later version", you have the option of following the terms and
conditions either of that version or of any later version published by
the Free Software Foundation. If the Library does not specify a
license version number, you may choose any version ever published by
the Free Software Foundation.
14. If you wish to incorporate parts of the Library into other free
programs whose distribution conditions are incompatible with these,
write to the author to ask for permission. For software which is
copyrighted by the Free Software Foundation, write to the Free
Software Foundation; we sometimes make exceptions for this. Our
decision will be guided by the two goals of preserving the free status
of all derivatives of our free software and of promoting the sharing
and reuse of software generally.
NO WARRANTY
15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO
WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW.
EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR
OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY
KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE
IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE
LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME
THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION.
16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN
WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY
AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU
FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR
CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE
LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING
RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A
FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF
SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH
DAMAGES.
END OF TERMS AND CONDITIONS
How to Apply These Terms to Your New Libraries
If you develop a new library, and you want it to be of the greatest
possible use to the public, we recommend making it free software that
everyone can redistribute and change. You can do so by permitting
redistribution under these terms (or, alternatively, under the terms of the
ordinary General Public License).
To apply these terms, attach the following notices to the library. It is
safest to attach them to the start of each source file to most effectively
convey the exclusion of warranty; and each file should have at least the
"copyright" line and a pointer to where the full notice is found.
<one line to give the library's name and a brief idea of what it does.>
Copyright (C) <year> <name of author>
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
This library 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. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
Also add information on how to contact you by electronic and paper mail.
You should also get your employer (if you work as a programmer) or your
school, if any, to sign a "copyright disclaimer" for the library, if
necessary. Here is a sample; alter the names:
Yoyodyne, Inc., hereby disclaims all copyright interest in the
library `Frob' (a library for tweaking knobs) written by James Random Hacker.
<signature of Ty Coon>, 1 April 1990
Ty Coon, President of Vice
That's all there is to it!

26
wst/tags/0.4/COPYING.modifiedLGPL Normal file
View File

@ -0,0 +1,26 @@
This is the file COPYING.modifiedLGPL, it applies to several units in the
Lazarus sources distributed by members of the Lazarus Development Team.
All files contains headers showing the appropriate license. See there if this
modification can be applied.
These files are distributed under the Library GNU General Public License
(see the file COPYING.LPGL) with the following modification:
As a special exception, the copyright holders of this library give you
permission to link this library with independent modules to produce an
executable, regardless of the license terms of these independent modules,
and to copy and distribute the resulting executable under terms of your choice,
provided that you also meet, for each linked independent module, the terms
and conditions of the license of that module. An independent module is a
module which is not derived from or based on this library. If you modify this
library, you may extend this exception to your version of the library, but
you are not obligated to do so. If you do not wish to do so, delete this
exception statement from your version.
If you didn't receive a copy of the file COPYING.LGPL, contact:
Free Software Foundation, Inc.,
675 Mass Ave
Cambridge, MA 02139
USA

1592
wst/tags/0.4/base_binary_formatter.pas Normal file
View File

File diff suppressed because it is too large Load Diff

4148
wst/tags/0.4/base_service_intf.pas Normal file
View File

File diff suppressed because it is too large Load Diff

1685
wst/tags/0.4/base_soap_formatter.pas Normal file
View File

File diff suppressed because it is too large Load Diff

203
wst/tags/0.4/binary_formatter.pas Normal file
View File

@ -0,0 +1,203 @@
{
This file is part of the Web Service Toolkit
Copyright (c) 2006 by Inoussa OUEDRAOGO
This file is provide under modified LGPL licence
( the files COPYING.modifiedLGPL and COPYING.LGPL).
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.
}
unit binary_formatter;
interface
uses
Classes, SysUtils, TypInfo,
base_service_intf, service_intf, imp_utils,
base_binary_formatter;
{$INCLUDE wst.inc}
Const
sCONTENT_TYPE = 'contenttype';
sBINARY_CONTENT = 'binary';
sPROTOCOL_NAME = sBINARY_CONTENT;
sTARGET = 'target';
Type
{$M+}
TBinaryFormatter = class(TBaseBinaryFormatter,IFormatterClient)
private
FPropMngr : IPropertyManager;
FCallProcedureName : string;
FCallTarget : String;
protected
public
function GetPropertyManager():IPropertyManager;
procedure BeginCall(
const AProcName,
ATarget : string;
ACallContext : ICallContext
);
procedure EndCall();
procedure BeginCallRead(ACallContext : ICallContext);
function GetCallProcedureName():String;
function GetCallTarget():String;
End;
{ TBinaryCallMaker }
TBinaryCallMaker = class(TSimpleFactoryItem,ICallMaker)
Private
FPropMngr : IPropertyManager;
Public
constructor Create();override;
destructor Destroy();override;
function GetPropertyManager():IPropertyManager;
procedure MakeCall(
ASerializer : IFormatterClient;
ATransport : ITransport
);
End;
implementation
function TBinaryFormatter.GetPropertyManager(): IPropertyManager;
begin
If Not Assigned(FPropMngr) Then
FPropMngr := TPublishedPropertyManager.Create(Self);
Result := FPropMngr;
end;
procedure TBinaryFormatter.BeginCall(
const AProcName,
ATarget : string;
ACallContext : ICallContext
);
begin
FCallProcedureName := AProcName;
FCallTarget := ATarget;
BeginObject('Body',Nil);
BeginObject(FCallTarget,Nil);
BeginObject(FCallProcedureName,Nil);
end;
procedure TBinaryFormatter.EndCall();
begin
EndScope();
EndScope();
EndScope();
end;
procedure TBinaryFormatter.BeginCallRead(ACallContext : ICallContext);
Var
s,nme : string;
e : EBaseRemoteException;
begin
ClearStack();
PushStack(GetRootData(),stObject);
s := 'Body';
BeginObjectRead(s,nil);
s := StackTop().GetByIndex(0)^.Name;
If AnsiSameText(s,'Fault') Then Begin
BeginObjectRead(s,nil);
e := EBaseRemoteException.Create('');
Try
nme := 'faultcode';
Get(TypeInfo(string),nme,s);
e.FaultCode := s;
nme := 'faultstring';
Get(TypeInfo(string),nme,s);
e.FaultString := s;
e.Message := Format('%s : "%s"',[e.FaultCode,e.FaultString]);
Except
FreeAndNil(e);
Raise;
End;
Raise e;
End;
FCallTarget := s;
BeginObjectRead(FCallTarget,nil);
FCallProcedureName := StackTop().GetByIndex(0)^.Name;
BeginObjectRead(FCallProcedureName,nil);
end;
function TBinaryFormatter.GetCallProcedureName(): String;
begin
Result := FCallProcedureName;
end;
function TBinaryFormatter.GetCallTarget(): String;
begin
Result := FCallTarget;
end;
{ TBinaryCallMaker }
constructor TBinaryCallMaker.Create();
begin
FPropMngr := TPublishedPropertyManager.Create(Self);
end;
destructor TBinaryCallMaker.Destroy();
begin
FPropMngr := Nil;
inherited Destroy();
end;
function TBinaryCallMaker.GetPropertyManager(): IPropertyManager;
begin
Result:= FPropMngr;
end;
procedure TBinaryCallMaker.MakeCall(
ASerializer : IFormatterClient;
ATransport : ITransport
);
Var
rqt, rsps : TMemoryStream;
begin
Assert(Assigned(ASerializer));
Assert(Assigned(ATransport));
ATransport.GetPropertyManager().SetProperty(
sCONTENT_TYPE,
sBINARY_CONTENT
);
rsps := Nil;
rqt := TMemoryStream.Create();
Try
rsps := TMemoryStream.Create();
ASerializer.SaveToStream(rqt);
rqt.Position := 0;
ATransport.SendAndReceive(rqt,rsps);
rqt.Clear();
rsps.Position := 0;
ASerializer.Clear();
ASerializer.LoadFromStream(rsps);
Finally
rsps.Free();
rqt.Free();
End;
end;
procedure RegisterBinaryProtocol();
begin
GetFormaterRegistry().Register(
sPROTOCOL_NAME,
TSimpleItemFactory.Create(TBinaryFormatter) as IItemFactory,
TSimpleItemFactory.Create(TBinaryCallMaker) as IItemFactory
);
end;
Initialization
RegisterBinaryProtocol();
end.

521
wst/tags/0.4/binary_streamer.pas Normal file
View File

@ -0,0 +1,521 @@
{
This file is part of the Web Service Toolkit
Copyright (c) 2006 by Inoussa OUEDRAOGO
This file is provide under modified LGPL licence
( the files COPYING.modifiedLGPL and COPYING.LGPL).
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.
}
unit binary_streamer;
interface
uses
Classes, SysUtils, Types;
{$INCLUDE wst.inc}
{$INCLUDE wst_delphi.inc}
Const
MAX_ARRAY_LENGTH = 1024*1024;
Type
TInt8U = Byte; TInt8S = ShortInt;
TInt16U = Word; TInt16S = SmallInt;
TInt32U = LongWord; TInt32S = LongInt;
TInt64S = Int64;TInt64U = QWord;
TBoolData = Boolean;
TEnumData = Int64;
TStringData = AnsiString;
TFloat_Single_4 = Single;
TFloat_Double_8 = Double;
TFloat_Extended_10 = Extended;
TFloat_Currency_8 = Currency;
IDataStore = Interface
['{CA767A0E-7660-4765-9959-6960A69B1660}']
procedure WriteInt8U(Const AData : TInt8U);
procedure WriteInt8S(Const AData : TInt8S);
procedure WriteInt16U(Const AData : TInt16U);
procedure WriteInt16S(Const AData : TInt16S);
procedure WriteInt32U(Const AData : TInt32U);
procedure WriteInt32S(Const AData : TInt32S);
procedure WriteInt64U(Const AData : TInt64U);
procedure WriteInt64S(Const AData : TInt64S);
procedure WriteBool(Const AData : TBoolData);
procedure WriteEnum(Const AData : TEnumData);
procedure WriteStr(Const AData : TStringData);
procedure WriteSingle(Const AData : TFloat_Single_4);
procedure WriteDouble(Const AData : TFloat_Double_8);
procedure WriteExtended(Const AData : TFloat_Extended_10);
procedure WriteCurrency(Const AData : TFloat_Currency_8);
End;
IDataStoreReader = Interface
['{AF50317E-6DD6-40C5-A2F6-3ED5F478564F}']
function IsAtEof():Boolean;
function ReadInt8U():TInt8U;
function ReadInt8S():TInt8S;
function ReadInt16U():TInt16U;
function ReadInt16S():TInt16S;
function ReadInt32U():TInt32U;
function ReadInt32S():TInt32S;
function ReadInt64U():TInt64U;
function ReadInt64S():TInt64S;
function ReadBool():TBoolData;
function ReadEnum():TEnumData;
function ReadStr():TStringData;
function ReadSingle():TFloat_Single_4;
function ReadDouble():TFloat_Double_8;
function ReadExtended():TFloat_Extended_10;
function ReadCurrency():TFloat_Currency_8;
End;
function CreateBinaryReader(AStream : TStream):IDataStoreReader;
function CreateBinaryWriter(AStream : TStream):IDataStore;
procedure ReverseBytes(var AData; const ALength : Integer);{$IFDEF ENDIAN_BIG}inline;{$ENDIF}
function Reverse_16(AValue:Word):Word;{$IFDEF USE_INLINE}inline;{$ENDIF}
function Reverse_32(AValue:DWord):DWord;{$IFDEF USE_INLINE}inline;{$ENDIF}
function Reverse_64(AValue:QWord):QWord;{$IFDEF USE_INLINE}inline;{$ENDIF}
function Reverse_Single(AValue:Single):Single;{$IFDEF USE_INLINE}inline;{$ENDIF}
function Reverse_Double(AValue:Double):Double;{$IFDEF USE_INLINE}inline;{$ENDIF}
function Reverse_Extended(AValue:Extended):Extended;{$IFDEF USE_INLINE}inline;{$ENDIF}
function Reverse_Currency(AValue:Currency):Currency;{$IFDEF USE_INLINE}inline;{$ENDIF}
implementation
{$IFDEF ENDIAN_BIG}
procedure ReverseBytes(var AData; const ALength : Integer);{$IFDEF USE_INLINE}inline;{$ENDIF}
begin
end;
{$ELSE} // assume ENDIAN_LITTLE
procedure ReverseBytes(var AData; const ALength : Integer);
Var
i,j : PtrInt;
c : Byte;
pDt : {$IFDEF FPC}^Byte{$ELSE}PByteArray{$ENDIF};
begin
pDt := @AData;
j := ALength div 2;
For i := 0 To Pred(j) Do Begin
c := pDt{$IFNDEF FPC}^{$ENDIF}[i];
pDt[i] := pDt[(ALength - 1 ) - i];
pDt[(ALength - 1 ) - i] := c;
End;
end;
{$ENDIF}
function Reverse_16(AValue:Word):Word;{$IFDEF USE_INLINE}inline;{$ENDIF}
begin
Result := AValue;
ReverseBytes(Result,2)
end;
function Reverse_32(AValue:DWord):DWord;{$IFDEF USE_INLINE}inline;{$ENDIF}
begin
Result := AValue;
ReverseBytes(Result,4)
end;
function Reverse_64(AValue:QWord):QWord;{$IFDEF USE_INLINE}inline;{$ENDIF}
begin
Result := AValue;
ReverseBytes(Result,8)
end;
function Reverse_Single(AValue:Single):Single;{$IFDEF USE_INLINE}inline;{$ENDIF}
begin
Result := AValue;
ReverseBytes(Result,4)
end;
function Reverse_Double(AValue:Double):Double;{$IFDEF USE_INLINE}inline;{$ENDIF}
begin
Result := AValue;
ReverseBytes(Result,8)
end;
function Reverse_Extended(AValue:Extended):Extended;{$IFDEF USE_INLINE}inline;{$ENDIF}
begin
Result := AValue;
ReverseBytes(Result,10);
end;
function Reverse_Currency(AValue:Currency):Currency;{$IFDEF USE_INLINE}inline;{$ENDIF}
begin
Result := AValue;
ReverseBytes(Result,8);
end;
Type
{ TDataStore }
TDataStore = class(TInterfacedObject,IDataStore)
Private
FStream : TStream;
Protected
procedure WriteInt8U(Const AData : TInt8U);
procedure WriteInt8S(Const AData : TInt8S);
procedure WriteInt16U(Const AData : TInt16U);
procedure WriteInt16S(Const AData : TInt16S);
procedure WriteInt32U(Const AData : TInt32U);
procedure WriteInt32S(Const AData : TInt32S);
procedure WriteInt64U(Const AData : TInt64U);
procedure WriteInt64S(Const AData : TInt64S);
procedure WriteBool(Const AData : TBoolData);
procedure WriteEnum(Const AData : TEnumData);
procedure WriteStr(Const AData : TStringData);
procedure WriteSingle(Const AData : TFloat_Single_4);
procedure WriteDouble(Const AData : TFloat_Double_8);
procedure WriteExtended(Const AData : TFloat_Extended_10);
procedure WriteCurrency(Const AData : TFloat_Currency_8);
Public
constructor Create(AStream : TStream);
End;
{ TDataStoreReader }
TDataStoreReader = class(TInterfacedObject,IDataStoreReader)
Private
FStream : TStream;
Protected
function IsAtEof():Boolean;
function ReadInt8U():TInt8U;
function ReadInt8S():TInt8S;
function ReadInt16U():TInt16U;
function ReadInt16S():TInt16S;
function ReadInt32U():TInt32U;
function ReadInt32S():TInt32S;
function ReadInt64U():TInt64U;
function ReadInt64S():TInt64S;
function ReadBool():TBoolData;
function ReadEnum():TEnumData;
function ReadStr():TStringData;
function ReadSingle():TFloat_Single_4;
function ReadDouble():TFloat_Double_8;
function ReadExtended():TFloat_Extended_10;
function ReadCurrency():TFloat_Currency_8;
Public
constructor Create(AStream : TStream);
End;
function CreateBinaryWriter(AStream : TStream):IDataStore;
begin
Result := TDataStore.Create(AStream) As IDataStore;
end;
function CreateBinaryReader(AStream : TStream):IDataStoreReader;
begin
Result := TDataStoreReader.Create(AStream) As IDataStoreReader;
end;
{ TDataStore }
procedure TDataStore.WriteInt8U(const AData: TInt8U);
begin
FStream.Write(AData,SizeOf(AData));
end;
procedure TDataStore.WriteInt8S(const AData: TInt8S);
begin
FStream.Write(AData,SizeOf(AData));
end;
{$IFDEF FPC}
procedure TDataStore.WriteInt16U(const AData: TInt16U);
begin
FStream.Write(Reverse_16(AData),SizeOf(AData));
end;
procedure TDataStore.WriteInt16S(const AData: TInt16S);
begin
FStream.Write(Reverse_16(AData),SizeOf(AData));
end;
procedure TDataStore.WriteInt32U(const AData: TInt32U);
begin
FStream.Write(Reverse_32(AData),SizeOf(AData));
end;
procedure TDataStore.WriteInt32S(const AData: TInt32S);
begin
FStream.Write(Reverse_32(AData),SizeOf(AData));
end;
procedure TDataStore.WriteInt64U(const AData: TInt64U);
begin
FStream.Write(Reverse_64(AData),SizeOf(AData));
end;
procedure TDataStore.WriteInt64S(const AData: TInt64S);
begin
FStream.Write(Reverse_64(AData),SizeOf(AData));
end;
{$ELSE}
procedure TDataStore.WriteInt16U(const AData: TInt16U);
var
bffr : TInt16U;
begin
bffr := Reverse_16(AData);
FStream.Write(bffr,SizeOf(AData));
end;
procedure TDataStore.WriteInt16S(const AData: TInt16S);
var
bffr : TInt16U;
begin
bffr := Reverse_16(AData);
FStream.Write(bffr,SizeOf(AData));
end;
procedure TDataStore.WriteInt32U(const AData: TInt32U);
var
bffr : TInt32U;
begin
bffr := Reverse_32(AData);
FStream.Write(bffr,SizeOf(AData));
end;
procedure TDataStore.WriteInt32S(const AData: TInt32S);
var
bffr : TInt32U;
begin
bffr := Reverse_32(AData);
FStream.Write(bffr,SizeOf(AData));
end;
procedure TDataStore.WriteInt64U(const AData: TInt64U);
var
bffr : TInt64U;
begin
bffr := Reverse_64(AData);
FStream.Write(bffr,SizeOf(AData));
end;
procedure TDataStore.WriteInt64S(const AData: TInt64S);
var
bffr : TInt64U;
begin
bffr := Reverse_64(AData);
FStream.Write(bffr,SizeOf(AData));
end;
{$ENDIF}
procedure TDataStore.WriteBool(const AData: TBoolData);
Var
i : TInt8U;
begin
If AData Then
i := 1
Else
i := 0;
WriteInt8U(i);
end;
procedure TDataStore.WriteEnum(const AData: TEnumData);
begin
WriteInt64S(AData);
end;
procedure TDataStore.WriteStr(const AData: TStringData);
Var
i : TInt32S;
begin
i := Length(AData);
WriteInt32S(i);
If ( i > 0 ) Then
FStream.Write(AData[1],i);
end;
{$IFDEF FPC}
procedure TDataStore.WriteSingle(const AData: TFloat_Single_4);
begin
FStream.Write(Reverse_Single(AData),SizeOf(AData));
end;
procedure TDataStore.WriteDouble(const AData: TFloat_Double_8);
begin
FStream.Write(Reverse_Double(AData),SizeOf(AData));
end;
procedure TDataStore.WriteExtended(const AData: TFloat_Extended_10);
begin
FStream.Write(Reverse_Extended(AData),SizeOf(AData));
end;
procedure TDataStore.WriteCurrency(const AData: TFloat_Currency_8);
begin
FStream.Write(Reverse_Currency(AData),SizeOf(AData));
end;
{$ELSE}
procedure TDataStore.WriteSingle(const AData: TFloat_Single_4);
var
bffr : TFloat_Single_4;
begin
bffr := Reverse_Single(AData);
FStream.Write(bffr,SizeOf(AData));
end;
procedure TDataStore.WriteDouble(const AData: TFloat_Double_8);
var
bffr : TFloat_Double_8;
begin
bffr := Reverse_Double(AData);
FStream.Write(bffr,SizeOf(AData));
end;
procedure TDataStore.WriteExtended(const AData: TFloat_Extended_10);
var
bffr : TFloat_Extended_10;
begin
bffr := Reverse_Extended(AData);
FStream.Write(bffr,SizeOf(AData));
end;
procedure TDataStore.WriteCurrency(const AData: TFloat_Currency_8);
var
bffr : TFloat_Currency_8;
begin
bffr := Reverse_Currency(AData);
FStream.Write(bffr,SizeOf(AData));
end;
{$ENDIF}
constructor TDataStore.Create(AStream: TStream);
begin
Assert(Assigned(AStream));
FStream := AStream;
end;
{ TDataStoreReader }
function TDataStoreReader.IsAtEof(): Boolean;
begin
Result := ( FStream.Position >= FStream.Size );
end;
function TDataStoreReader.ReadInt8U(): TInt8U;
begin
FStream.Read(Result,SizeOf(Result));
end;
function TDataStoreReader.ReadInt8S(): TInt8S;
begin
FStream.Read(Result,SizeOf(Result));
end;
function TDataStoreReader.ReadInt16U(): TInt16U;
begin
FStream.Read(Result,SizeOf(Result));
Result := Reverse_16(Result);
end;
function TDataStoreReader.ReadInt16S(): TInt16S;
begin
FStream.Read(Result,SizeOf(Result));
Result := Reverse_16(Result);
end;
function TDataStoreReader.ReadInt32U(): TInt32U;
begin
FStream.Read(Result,SizeOf(Result));
Result := Reverse_32(Result);
end;
function TDataStoreReader.ReadInt32S(): TInt32S;
begin
FStream.Read(Result,SizeOf(Result));
Result := Reverse_32(Result);
end;
function TDataStoreReader.ReadInt64U(): TInt64U;
begin
FStream.Read(Result,SizeOf(Result));
Result := Reverse_64(Result);
end;
function TDataStoreReader.ReadInt64S(): TInt64S;
begin
FStream.Read(Result,SizeOf(Result));
Result := Reverse_64(Result);
end;
function TDataStoreReader.ReadBool(): TBoolData;
begin
Result := ( ReadInt8U() > 0 );
end;
function TDataStoreReader.ReadEnum(): TEnumData;
begin
Result := ReadInt64S();
end;
function TDataStoreReader.ReadStr(): TStringData;
Var
i : TInt32S;
begin
i := ReadInt32S();
SetLength(Result,i);
If ( i > 0 ) Then
FStream.ReadBuffer(Result[1],i);
end;
function TDataStoreReader.ReadSingle(): TFloat_Single_4;
begin
FStream.Read(Result,SizeOf(Result));
Result := Reverse_Single(Result);
end;
function TDataStoreReader.ReadDouble(): TFloat_Double_8;
begin
FStream.Read(Result,SizeOf(Result));
Result := Reverse_Double(Result);
end;
function TDataStoreReader.ReadExtended(): TFloat_Extended_10;
begin
FStream.Read(Result,SizeOf(Result));
Result := Reverse_Extended(Result);
end;
function TDataStoreReader.ReadCurrency(): TFloat_Currency_8;
begin
FStream.Read(Result,SizeOf(Result));
Result := Reverse_Currency(Result);
end;
constructor TDataStoreReader.Create(AStream: TStream);
begin
Assert(Assigned(AStream));
FStream := AStream;
end;
end.

BIN
wst/tags/0.4/doc/WebServiceToolKit.odt Normal file
View File

Binary file not shown.

1585
wst/tags/0.4/doc/WebServiceToolKit.rtf Normal file
View File

File diff suppressed because it is too large Load Diff

203
wst/tags/0.4/ics_http_protocol.pas Normal file
View File

@ -0,0 +1,203 @@
{
This file is part of the Web Service Toolkit
Copyright (c) 2006 by Inoussa OUEDRAOGO
This file is provide under modified LGPL licence
( the files COPYING.modifiedLGPL and COPYING.LGPL).
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.
}
unit ics_http_protocol;
{$mode objfpc}{$H+}
{$DEFINE WST_DBG}
interface
uses
Classes, SysUtils, {$IFDEF WST_DBG}Dialogs,{$ENDIF}
service_intf, imp_utils, base_service_intf,
HttpProt;
Const
sTRANSPORT_NAME = 'HTTP';
Type
{$M+}
{ THTTPTransport }
THTTPTransport = class(TSimpleFactoryItem,ITransport)
Private
FPropMngr : IPropertyManager;
FConnection : THttpCli;
FSoapAction: string;
function GetAddress: string;
function GetContentType: string;
function GetProxyPassword: string;
function GetProxyPort: Integer;
function GetProxyServer: string;
function GetProxyUsername: string;
procedure SetAddress(const AValue: string);
procedure SetContentType(const AValue: string);
procedure SetProxyPassword(const AValue: string);
procedure SetProxyPort(const AValue: Integer);
procedure SetProxyServer(const AValue: string);
procedure SetProxyUsername(const AValue: string);
private
procedure HttpBeforeHeaderSendHandler(
Sender : TObject;
const Method : String;
Headers : TStrings
);
Public
constructor Create();override;
destructor Destroy();override;
function GetPropertyManager():IPropertyManager;
procedure SendAndReceive(ARequest,AResponse:TStream);
Published
property ContentType : string Read GetContentType Write SetContentType;
property Address : string Read GetAddress Write SetAddress;
property ProxyServer : string Read GetProxyServer Write SetProxyServer;
property ProxyPort : Integer Read GetProxyPort Write SetProxyPort;
property ProxyUsername : string read GetProxyUsername write SetProxyUsername;
property ProxyPassword : string read GetProxyPassword write SetProxyPassword;
property SoapAction : string read FSoapAction write FSoapAction;
End;
{$M+}
procedure ICS_RegisterHTTP_Transport();
implementation
{ THTTPTransport }
function THTTPTransport.GetAddress: string;
begin
Result := FConnection.URL;
end;
function THTTPTransport.GetContentType: string;
begin
Result := FConnection.ContentTypePost;
end;
function THTTPTransport.GetProxyPassword: string;
begin
Result := FConnection.ProxyPassword;
end;
function THTTPTransport.GetProxyPort: Integer;
begin
Result := StrToIntDef(FConnection.ProxyPort,0);
end;
function THTTPTransport.GetProxyServer: string;
begin
Result := FConnection.Proxy;
end;
function THTTPTransport.GetProxyUsername: string;
begin
Result := FConnection.ProxyUsername;
end;
procedure THTTPTransport.SetAddress(const AValue: string);
begin
FConnection.URL := AValue;
end;
procedure THTTPTransport.SetContentType(const AValue: string);
begin
FConnection.ContentTypePost := AValue;
end;
procedure THTTPTransport.SetProxyPassword(const AValue: string);
begin
FConnection.ProxyPassword := AValue;
end;
procedure THTTPTransport.SetProxyPort(const AValue: Integer);
begin
FConnection.ProxyPort := IntToStr(AValue);
end;
procedure THTTPTransport.SetProxyServer(const AValue: string);
begin
FConnection.Proxy := AValue;
end;
procedure THTTPTransport.SetProxyUsername(const AValue: string);
begin
FConnection.ProxyUsername := AValue;
end;
procedure THTTPTransport.HttpBeforeHeaderSendHandler(
Sender: TObject;
const Method: String;
Headers: TStrings
);
begin
Headers.Add('soapAction:' + SoapAction);
end;
constructor THTTPTransport.Create();
begin
FPropMngr := TPublishedPropertyManager.Create(Self);
FConnection := THttpCli.Create(Nil);
end;
destructor THTTPTransport.Destroy();
begin
FreeAndNil(FConnection);
FPropMngr := Nil;
inherited Destroy();
end;
function THTTPTransport.GetPropertyManager(): IPropertyManager;
begin
Result := FPropMngr;
end;
procedure THTTPTransport.SendAndReceive(ARequest, AResponse: TStream);
{$IFDEF WST_DBG}
Var
s : string;
i : Int64;
{$ENDIF WST_DBG}
begin
{$IFDEF WST_DBG}
i := ARequest.Position;
ARequest.Position := 0;
SetLength(s,ARequest.Size);
ARequest.Read(s[1],ARequest.Size);
TMemoryStream(AResponse).SaveToFile('request.log');
ARequest.Position := i;
{$ENDIF WST_DBG}
FConnection.SendStream := ARequest;
FConnection.RcvdStream := AResponse;
FConnection.Post();
{$IFDEF WST_DBG}
TMemoryStream(AResponse).SaveToFile('request.log');
i := AResponse.Position;
SetLength(s,AResponse.Size);
AResponse.Read(s[1],AResponse.Size);
TMemoryStream(AResponse).SaveToFile('response.log');
if IsConsole then
WriteLn(s)
else
ShowMessage(s);
{$ENDIF WST_DBG}
end;
procedure ICS_RegisterHTTP_Transport();
begin
GetTransportRegistry().Register(sTRANSPORT_NAME,TSimpleItemFactory.Create(THTTPTransport) as IItemFactory);
end;
end.

222
wst/tags/0.4/ics_tcp_protocol.pas Normal file
View File

@ -0,0 +1,222 @@
{
This file is part of the Web Service Toolkit
Copyright (c) 2006 by Inoussa OUEDRAOGO
This file is provide under modified LGPL licence
( the files COPYING.modifiedLGPL and COPYING.LGPL).
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.
}
unit ics_tcp_protocol;
{$INCLUDE wst.inc}
interface
uses
Classes, SysUtils,
service_intf, imp_utils, base_service_intf,
WSocket;
Const
sTRANSPORT_NAME = 'TCP';
Type
ETCPException = class(EServiceException)
End;
{$M+}
{ TTCPTransport }
TTCPTransport = class(TSimpleFactoryItem,ITransport)
Private
FPropMngr : IPropertyManager;
FConnection : TWSocket;
FContentType : string;
FTarget: string;
function GetAddress: string;
function GetPort: string;
procedure SetAddress(const AValue: string);
procedure SetPort(const AValue: string);
private
FDataLength : LongInt;
FDataBuffer : string;
FAllDataRead : Boolean;
FBeginRead : Boolean;
FHasException : Boolean;
FExceptionMessage : string;
procedure DataAvailable(Sender: TObject; Error: Word);
procedure BgExceptionHandler(Sender : TObject;E : Exception;var CanClose : Boolean);
Public
constructor Create();override;
destructor Destroy();override;
function GetPropertyManager():IPropertyManager;
procedure SendAndReceive(ARequest,AResponse:TStream);
Published
property Target : string Read FTarget Write FTarget;
property ContentType : string Read FContentType Write FContentType;
property Address : string Read GetAddress Write SetAddress;
property Port : string Read GetPort Write SetPort;
End;
{$M+}
procedure ICS_RegisterTCP_Transport();
implementation
uses binary_streamer, Math;
{ TTCPTransport }
function TTCPTransport.GetAddress: string;
begin
Result := FConnection.Addr;
end;
function TTCPTransport.GetPort: string;
begin
Result := FConnection.Port;
end;
procedure TTCPTransport.SetAddress(const AValue: string);
begin
FConnection.Addr := AValue;
end;
procedure TTCPTransport.SetPort(const AValue: string);
begin
FConnection.Port := AValue;
end;
procedure TTCPTransport.DataAvailable(Sender: TObject; Error: Word);
Var
i,j : PtrInt;
buff : string;
begin
If Not FBeginRead Then Begin
i := 1024;
SetLength(buff,i);
While ( FConnection.Receive(@(buff[1]),i) = i ) Do
;
FDataBuffer := '';
FDataLength := -1;
Exit;
End;
If ( FDataLength < 0 ) Then Begin
i := 4;
if ( FConnection.Receive(@FDataLength,i) < i ) then
raise ETCPException.Create('Error reading data length.');
FDataLength := Reverse_32(FDataLength);
End;
If ( FDataLength > Length(FDataBuffer) ) Then Begin
i := 1024;
If ( i > FDataLength ) Then
i := FDataLength;
SetLength(buff,i);
Repeat
j := FConnection.Receive(@(buff[1]),i);
FDataBuffer := FDataBuffer + Copy(buff,1,j);
i := Min(1024,(FDataLength-Length(FDataBuffer)));
Until ( i =0 ) or ( j <= 0 );
End;
FAllDataRead := ( FDataLength <= Length(FDataBuffer) );
end;
procedure TTCPTransport.BgExceptionHandler(Sender: TObject; E: Exception;var CanClose: Boolean);
begin
CanClose := True;
FHasException := True;
FExceptionMessage := E.Message;
end;
constructor TTCPTransport.Create();
begin
FDataLength := -1;
FAllDataRead := False;
FPropMngr := TPublishedPropertyManager.Create(Self);
FConnection := TWSocket.Create(Nil);
FConnection.OnDataAvailable := {$IFDEF FPC}@{$ENDIF}DataAvailable;
FConnection.OnBgException := {$IFDEF FPC}@{$ENDIF}BgExceptionHandler;
end;
destructor TTCPTransport.Destroy();
begin
FreeAndNil(FConnection);
FPropMngr := Nil;
inherited Destroy();
end;
function TTCPTransport.GetPropertyManager(): IPropertyManager;
begin
Result := FPropMngr;
end;
procedure TTCPTransport.SendAndReceive(ARequest, AResponse: TStream);
Var
wrtr : IDataStore;
buffStream : TMemoryStream;
strBuff : string;
{$IFDEF WST_DBG}
s : string;
i : Int64;
{$ENDIF WST_DBG}
begin
buffStream := TMemoryStream.Create();
Try
wrtr := CreateBinaryWriter(buffStream);
wrtr.WriteInt32S(0);
wrtr.WriteStr(Target);
wrtr.WriteStr(ContentType);
SetLength(strBuff,ARequest.Size);
ARequest.Position := 0;
ARequest.Read(strBuff[1],Length(strBuff));
wrtr.WriteStr(strBuff);
buffStream.Position := 0;
wrtr.WriteInt32S(buffStream.Size-4);
If ( FConnection.State = wsClosed ) Then Begin
FConnection.Connect();
While ( FConnection.State < wsConnected ) Do
FConnection.ProcessMessage();
End;
FDataBuffer := '';
FDataLength := -1;
FAllDataRead := False;
FHasException := False;
FExceptionMessage := '';
FBeginRead := True;
FConnection.Send(buffStream.Memory,buffStream.Size);
FConnection.Flush();
While Not ( FAllDataRead Or FHasException ) Do
FConnection.ProcessMessage();
If FHasException Then
Raise ETCPException.Create(FExceptionMessage);
AResponse.Size := 0;
AResponse.Write(FDataBuffer[1],Length(FDataBuffer));
FDataBuffer := '';
FDataLength := -1;
FAllDataRead := False;
AResponse.Position := 0;
{$IFDEF WST_DBG}
i := AResponse.Position;
SetLength(s,AResponse.Size);
AResponse.Read(s[1],AResponse.Size);
WriteLn(s);
{$ENDIF WST_DBG}
Finally
buffStream.Free();
End;
end;
procedure ICS_RegisterTCP_Transport();
begin
GetTransportRegistry().Register(sTRANSPORT_NAME,TSimpleItemFactory.Create(TTCPTransport) as IItemFactory);
end;
end.

202
wst/tags/0.4/imp_utils.pas Normal file
View File

@ -0,0 +1,202 @@
{
This file is part of the Web Service Toolkit
Copyright (c) 2006 by Inoussa OUEDRAOGO
This file is provide under modified LGPL licence
( the files COPYING.modifiedLGPL and COPYING.LGPL).
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.
}
unit imp_utils;
interface
uses
Classes, SysUtils, TypInfo,
base_service_intf;
{$INCLUDE wst.inc}
Type
EPropertyManagerException = class(EServiceException)
End;
{ TPublishedPropertyManager }
TPublishedPropertyManager = class(TInterfacedObject,IPropertyManager)
Private
FParent : TObject;
procedure Error(Const AMsg:string);overload;
procedure Error(Const AMsg:string; Const AArgs : array of const);overload;
Protected
procedure SetProperty(Const AName,AValue:string);
procedure SetProperties(Const APropsStr:string);
function GetProperty(Const AName:String):string;
function GetPropertyNames(ADest : TStrings):Integer;
procedure Clear();
procedure Copy(ASource:IPropertyManager; Const AClearBefore : Boolean);
Public
constructor Create(AParent : TObject);
End;
function IsStrEmpty(Const AStr:String):Boolean;
function ExtractOptionName(const ACompleteName : string):string;
implementation
function IsStrEmpty(Const AStr:String):Boolean;
begin
Result := ( Length(Trim(AStr)) = 0 );
end;
function ExtractOptionName(const ACompleteName : string):string;
var
i, c : Integer;
begin
Result := '';
c := Length(ACompleteName);
for i := c downto 1 do begin
if ( ACompleteName[i] = '_' ) then
Break;
Result := ACompleteName[i] + Result;
end;
Result := Trim(Result);
end;
{ TPublishedPropertyManager }
procedure TPublishedPropertyManager.Error(const AMsg: string);
begin
Raise EPropertyManagerException.Create(AMsg);
end;
procedure TPublishedPropertyManager.Error(const AMsg: string;const AArgs: array of const);
begin
Raise EPropertyManagerException.CreateFmt(AMsg,AArgs);
end;
procedure TPublishedPropertyManager.SetProperty(const AName, AValue: string);
Var
pinf : PPropInfo;
int64Val : Int64;
begin
pinf := GetPropInfo(FParent,AName);
If Assigned(pinf) And Assigned(pinf^.SetProc) Then Begin
Case pinf^.PropType^.Kind of
tkLString{$IFDEF FPC},tkSString,tkAString{$ENDIF},tkWString:
SetStrProp(FParent,pinf,AValue);
tkEnumeration :
SetEnumProp(FParent,pinf,AValue);
tkInteger,tkInt64{$IFDEF FPC},tkQWord{$ENDIF} :
Begin
If TryStrToInt64(AValue,int64Val) Then
SetOrdProp(FParent,AName,int64Val);
End;
End;
End;
end;
procedure TPublishedPropertyManager.SetProperties(const APropsStr: string);
Var
lst : TStringList;
i : Integer;
begin
If IsStrEmpty(APropsStr) Then
Exit;
lst := TStringList.Create();
Try
lst.QuoteChar := #0;
lst.Delimiter := PROP_LIST_DELIMITER;
lst.DelimitedText := APropsStr;
For i := 0 To Pred(lst.Count) Do
SetProperty(lst.Names[i],lst.ValueFromIndex[i]);
Finally
lst.Free();
End;
end;
function TPublishedPropertyManager.GetProperty(const AName: String): string;
Var
pinf : PPropInfo;
begin
Result := '';
pinf := GetPropInfo(FParent,AName);
If Assigned(pinf) And Assigned(pinf^.SetProc) Then Begin
Case pinf^.PropType^.Kind of
tkLString{$IFDEF FPC},tkSString,tkAString{$ENDIF},tkWString:
Result := GetStrProp(FParent,pinf);
tkEnumeration :
Result := GetEnumProp(FParent,pinf);
tkInteger,tkInt64{$IFDEF FPC},tkQWord{$ENDIF} :
Result := IntToStr(GetOrdProp(FParent,pinf));
End;
End;
end;
function TPublishedPropertyManager.GetPropertyNames(ADest: TStrings): Integer;
Var
propList : PPropList;
i, propListLen : Integer;
begin
ADest.Clear();
propListLen := GetPropList(PTypeInfo(FParent.ClassInfo),propList);
Try
For i := 0 To Pred(propListLen) Do Begin
If ( propList^[i]^.PropType^.Kind in
[ tkLString{$IFDEF FPC},tkSString,tkAString{$ENDIF},tkWString,
tkEnumeration,
tkInteger,tkInt64{$IFDEF FPC},tkQWord{$ENDIF}
]
)
Then
ADest.Add(propList^[i]^.Name);
End;
Finally
Freemem(propList,propListLen*SizeOf(Pointer));
End;
Result := ADest.Count;
end;
procedure TPublishedPropertyManager.Clear();
begin
end;
procedure TPublishedPropertyManager.Copy(
ASource: IPropertyManager;
const AClearBefore: Boolean
);
Var
lst : TStringList;
i : Integer;
s : string;
begin
If AClearBefore Then
Clear();
If Assigned(ASource) Then Begin
lst := TStringList.Create();
Try
ASource.GetPropertyNames(lst);
For i := 0 To Pred(lst.Count) Do Begin
s := lst[i];
SetProperty(s,ASource.GetProperty(s));
End;
Finally
lst.Free();
End;
End;
end;
constructor TPublishedPropertyManager.Create(AParent: TObject);
begin
Assert(Assigned(AParent));
FParent := AParent;
end;
end.

170
wst/tags/0.4/indy_http_protocol.pas Normal file
View File

@ -0,0 +1,170 @@
{
This file is part of the Web Service Toolkit
Copyright (c) 2006 by Inoussa OUEDRAOGO
This file is provide under modified LGPL licence
( the files COPYING.modifiedLGPL and COPYING.LGPL).
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.
}
unit indy_http_protocol;
{$mode objfpc}{$H+}
//{$DEFINE WST_DBG}
interface
uses
Classes, SysUtils,
service_intf, imp_utils, base_service_intf,
IdHTTP;
Const
sTRANSPORT_NAME = 'HTTP';
Type
{$M+}
{ THTTPTransport }
THTTPTransport = class(TSimpleFactoryItem,ITransport)
Private
FPropMngr : IPropertyManager;
FConnection : TidHttp;
FSoapAction: string;
FContentType: string;
function GetAddress: string;
function GetProxyPassword: string;
function GetProxyPort: Integer;
function GetProxyServer: string;
function GetProxyUsername: string;
procedure SetAddress(const AValue: string);
procedure SetProxyPassword(const AValue: string);
procedure SetProxyPort(const AValue: Integer);
procedure SetProxyServer(const AValue: string);
procedure SetProxyUsername(const AValue: string);
Public
constructor Create();override;
destructor Destroy();override;
function GetPropertyManager():IPropertyManager;
procedure SendAndReceive(ARequest,AResponse:TStream);
Published
property ContentType : string Read FContentType Write FContentType;
property Address : string Read GetAddress Write SetAddress;
property ProxyServer : string Read GetProxyServer Write SetProxyServer;
property ProxyPort : Integer Read GetProxyPort Write SetProxyPort;
property ProxyUsername : string read GetProxyUsername write SetProxyUsername;
property ProxyPassword : string read GetProxyPassword write SetProxyPassword;
property SoapAction : string read FSoapAction write FSoapAction;
End;
{$M+}
procedure INDY_RegisterHTTP_Transport();
implementation
{ THTTPTransport }
function THTTPTransport.GetAddress: string;
begin
Result := FConnection.Request.URL;
end;
function THTTPTransport.GetProxyPassword: string;
begin
Result := FConnection.ProxyParams.ProxyPassword;
end;
function THTTPTransport.GetProxyPort: Integer;
begin
Result := FConnection.ProxyParams.ProxyPort;
end;
function THTTPTransport.GetProxyServer: string;
begin
Result := FConnection.ProxyParams.ProxyServer;
end;
function THTTPTransport.GetProxyUsername: string;
begin
Result := FConnection.ProxyParams.ProxyUsername;
end;
procedure THTTPTransport.SetAddress(const AValue: string);
begin
FConnection.Request.URL := AValue;
end;
procedure THTTPTransport.SetProxyPassword(const AValue: string);
begin
FConnection.ProxyParams.ProxyPassword := AValue;
end;
procedure THTTPTransport.SetProxyPort(const AValue: Integer);
begin
FConnection.ProxyParams.ProxyPort := AValue;
end;
procedure THTTPTransport.SetProxyServer(const AValue: string);
begin
FConnection.ProxyParams.ProxyServer := AValue;
end;
procedure THTTPTransport.SetProxyUsername(const AValue: string);
begin
FConnection.ProxyParams.ProxyUsername := AValue;
end;
constructor THTTPTransport.Create();
begin
FPropMngr := TPublishedPropertyManager.Create(Self);
FConnection := TidHttp.Create(Nil);
end;
destructor THTTPTransport.Destroy();
begin
FreeAndNil(FConnection);
FPropMngr := Nil;
inherited Destroy();
end;
function THTTPTransport.GetPropertyManager(): IPropertyManager;
begin
Result := FPropMngr;
end;
procedure THTTPTransport.SendAndReceive(ARequest, AResponse: TStream);
{$IFDEF WST_DBG}
var
s : string;
i : Int64;
{$ENDIF WST_DBG}
begin
if not ( IsStrEmpty(FConnection.ProxyParams.ProxyUsername) and
IsStrEmpty(FConnection.ProxyParams.ProxyPassword)
)
then begin
FConnection.ProxyParams.BasicAuthentication := True;
end;
FConnection.Request.CustomHeaders.Clear();
FConnection.Request.CustomHeaders.Values['soapAction'] := SoapAction;
FConnection.Request.ContentType := ContentType;
FConnection.Post(Address,ARequest, AResponse);
{$IFDEF WST_DBG}
i := AResponse.Size;
SetLength(s,i);
Move(TMemoryStream(AResponse).Memory^,s[1],i);
WriteLn('--------------------------------------------');
WriteLn(s);
{$ENDIF WST_DBG}
end;
procedure INDY_RegisterHTTP_Transport();
begin
GetTransportRegistry().Register(sTRANSPORT_NAME,TSimpleItemFactory.Create(THTTPTransport) as IItemFactory);
end;
end.

87
wst/tags/0.4/library_base_intf.pas Normal file
View File

@ -0,0 +1,87 @@
{
This file is part of the Web Service Toolkit
Copyright (c) 2006 by Inoussa OUEDRAOGO
This file is provide under modified LGPL licence
( the files COPYING.modifiedLGPL and COPYING.LGPL).
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.
}
unit library_base_intf;
interface
uses base_service_intf;
{$INCLUDE wst.inc}
const
RET_OK = 0;
RET_FALSE = 1;
WST_LIB_HANDLER = 'wstHandleRequest';
type
EwstCheckException = class(EServiceException)
private
FReturnCode: Integer;
public
property ReturnCode : Integer read FReturnCode write FReturnCode;
end;
IwstStream = interface
['{95700F89-3E36-4678-AD84-347162E39288}']
function Read(
ABuffer : Pointer;
const ALenToRead : LongWord;
out AReadedLen : LongWord
):LongInt;
function Write(
ABuffer : Pointer;
const ALenToWrite : LongWord;
out AWrittenLen : LongWord
):LongInt;
function GetSize(out ASize : LongWord):LongInt;
function SetSize(const ANewSize : LongWord):LongInt;
function GetPosition(out APos : LongWord):LongWord;
function SetPosition(const ANewPos : LongWord):LongInt;
end;
TwstLibraryHandlerFunction =
function(
ARequestBuffer : IwstStream;
AErrorBuffer : Pointer;
var AErrorBufferLen : LongInt
):LongInt;
procedure wstCheck(const AReturn : LongInt);overload;
procedure wstCheck(const AReturn : LongInt; const AMsg : string);overload;
implementation
procedure wstCheck(const AReturn : LongInt);
var
e : EwstCheckException;
begin
if ( AReturn <> RET_OK ) then begin
e := EwstCheckException.CreateFmt('wst Check Exception , return = %d',[AReturn]);
e.ReturnCode := AReturn;
raise e;
end;
end;
procedure wstCheck(const AReturn : LongInt; const AMsg : string);
var
e : EwstCheckException;
begin
if ( AReturn <> RET_OK ) then begin
e := EwstCheckException.Create(AMsg);
e.ReturnCode := AReturn;
raise e;
end;
end;
end.

185
wst/tags/0.4/library_imp_utils.pas Normal file
View File

@ -0,0 +1,185 @@
unit library_imp_utils;
interface
uses
Classes, SysUtils;
{$INCLUDE wst.inc}
type
IwstModule = interface
['{A62A9A71-727E-47AD-9B84-0F7CA0AE51D5}']
function GetFileName():string;
function GetProc(const AProcName : string):Pointer;
end;
IwstModuleManager = interface
['{0A49D315-FF3E-40CD-BCA0-F958BCD5C57F}']
function Get(const AFileName : string):IwstModule;
procedure Clear();
end;
var
LibraryManager : IwstModuleManager = nil;
implementation
{$IFDEF FPC}
uses DynLibs;
{$ELSE}
uses Windows;
type TLibHandle = THandle;
const NilHandle = 0;
{$ENDIF}
type
{ TwstModule }
TwstModule = class(TInterfacedObject,IwstModule)
private
FFileName : string;
FHandle : TLibHandle;
private
procedure Load(const ADoLoad : Boolean);
protected
function GetFileName():string;
function GetProc(const AProcName : string):Pointer;
public
constructor Create(const AFileName : string);
destructor Destroy();override;
end;
{ TwstModuleManager }
TwstModuleManager = class(TInterfacedObject,IwstModuleManager)
private
FList : IInterfaceList;
private
function Load(const AFileName : string):IwstModule;
function GetItem(const AIndex : Integer):IwstModule;
function IndexOf(const AFileName : string):Integer;
protected
function Get(const AFileName : string):IwstModule;
procedure Clear();
public
constructor Create();
destructor Destroy();override;
end;
procedure TwstModule.Load(const ADoLoad : Boolean);
begin
if ADoLoad then begin
if ( FHandle = NilHandle ) then begin
{$IFDEF FPC}
FHandle := LoadLibrary(FFileName);
{$ELSE}
FHandle := LoadLibrary(PCHAR(FFileName));
{$ENDIF}
if ( FHandle = NilHandle ) then
raise Exception.CreateFmt('Error while loading : "%s".',[FFileName]);
end;
end else begin
if ( FHandle <> NilHandle ) then begin
FreeLibrary(FHandle);
FHandle := NilHandle;
end;
end;
end;
function TwstModule.GetFileName(): string;
begin
Result := FFileName;
end;
function TwstModule.GetProc(const AProcName: string): Pointer;
begin
{$IFDEF FPC}
Result := GetProcAddress(FHandle,AProcName);
{$ELSE}
Result := GetProcAddress(FHandle,PCHAR(AProcName));
{$ENDIF}
if not Assigned(Result) then
raise Exception.CreateFmt('Procedure "%s" not found in this module( "%s" ).',[AProcName,FFileName]);
end;
constructor TwstModule.Create(const AFileName: string);
begin
if not FileExists(AFileName) then
raise Exception.CreateFmt('File not found : "%s".',[AFileName]);
FHandle := NilHandle;
FFileName := AFileName;
Load(True);
end;
destructor TwstModule.Destroy();
begin
Load(False);
inherited Destroy();
end;
{ TwstModuleManager }
function TwstModuleManager.Get(const AFileName: string): IwstModule;
var
i : Integer;
begin
i := IndexOf(AFileName);
if ( i < 0 ) then
Result := Load(AFileName)
else
Result := GetItem(i);
end;
procedure TwstModuleManager.Clear();
begin
FList.Clear();
end;
function TwstModuleManager.Load(const AFileName: string): IwstModule;
begin
Result := TwstModule.Create(AFileName);
end;
function TwstModuleManager.GetItem(const AIndex: Integer): IwstModule;
begin
Result := FList[AIndex] as IwstModule;
end;
function TwstModuleManager.IndexOf(const AFileName: string): Integer;
begin
for Result := 0 to Pred(FList.Count) do begin
if AnsiSameStr(AFileName,(FList[Result] as IwstModule).GetFileName()) then
Exit;
end;
Result := -1;
end;
constructor TwstModuleManager.Create();
begin
inherited;
FList := TInterfaceList.Create();
end;
destructor TwstModuleManager.Destroy();
begin
FList := nil;
inherited Destroy();
end;
procedure InitLibraryManager();
begin
LibraryManager := TwstModuleManager.Create();
end;
initialization
InitLibraryManager();
finalization
LibraryManager := nil;
end.

245
wst/tags/0.4/library_protocol.pas Normal file
View File

@ -0,0 +1,245 @@
{
This file is part of the Web Service Toolkit
Copyright (c) 2006 by Inoussa OUEDRAOGO
This file is provide under modified LGPL licence
( the files COPYING.modifiedLGPL and COPYING.LGPL).
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.
}
unit library_protocol;
//{$DEFINE WST_DBG}
interface
uses
Classes, SysUtils,{$IFDEF WST_DBG}Dialogs,{$ENDIF}
service_intf, imp_utils, base_service_intf, library_base_intf,
library_imp_utils;
{$INCLUDE wst.inc}
const
sTRANSPORT_NAME = 'LIB';
Type
{$M+}
{ TLIBTransport }
TLIBTransport = class(TSimpleFactoryItem,ITransport)
Private
FPropMngr : IPropertyManager;
FModule : IwstModule;
FHandler : TwstLibraryHandlerFunction;
private
FContentType: string;
FFileName: string;
FTarget: string;
private
procedure SetFileName(const AValue: string);
procedure LoadModule();
public
constructor Create();override;
destructor Destroy();override;
function GetPropertyManager():IPropertyManager;
procedure SendAndReceive(ARequest,AResponse:TStream);
published
property ContentType : string read FContentType write FContentType;
property Target : string read FTarget write FTarget;
property FileName : string read FFileName write SetFileName;
end;
{$M+}
procedure LIB_Register_Transport();
implementation
uses binary_streamer;
type
{ TwstStream }
TwstStream = class(TInterfacedObject,IwstStream)
private
FStream : TStream;
protected
function Read(
ABuffer : Pointer;
const ALenToRead : LongWord;
out AReadedLen : LongWord
):LongInt;
function Write(
ABuffer : Pointer;
const ALenToWrite : LongWord;
out AWrittenLen : LongWord
):LongInt;
function GetSize(out ASize : LongWord):LongInt;
function SetSize(const ANewSize : LongWord):LongInt;
function GetPosition(out APos : LongWord):LongWord;
function SetPosition(const ANewPos : LongWord):LongInt;
public
constructor Create(AStream : TStream);
end;
{ TwstStream }
function TwstStream.Read(
ABuffer : Pointer;
const ALenToRead : LongWord;
out AReadedLen : LongWord
): LongInt;
begin
try
AReadedLen := FStream.Read(ABuffer^,ALenToRead);
Result := RET_OK;
except
Result := RET_FALSE;
end;
end;
function TwstStream.Write(
ABuffer : Pointer;
const ALenToWrite : LongWord;
out AWrittenLen : LongWord
): LongInt;
begin
try
AWrittenLen := FStream.Write(ABuffer^,ALenToWrite);
Result := RET_OK;
except
Result := RET_FALSE;
end;
end;
function TwstStream.GetSize(out ASize: LongWord): LongInt;
begin
ASize := FStream.Size;
Result := RET_OK;
end;
function TwstStream.SetSize(const ANewSize: LongWord): LongInt;
begin
FStream.Size := ANewSize;
Result := RET_OK;
end;
function TwstStream.GetPosition(out APos: LongWord): LongWord;
begin
APos := FStream.Position;
Result := RET_OK;
end;
function TwstStream.SetPosition(const ANewPos: LongWord): LongInt;
begin
FStream.Position := ANewPos;
Result := RET_OK;
end;
constructor TwstStream.Create(AStream: TStream);
begin
Assert(Assigned(AStream));
FStream := AStream;
end;
{ TLIBTransport }
procedure TLIBTransport.SetFileName(const AValue: string);
begin
FFileName := AValue;
if Assigned(FModule) and ( not AnsiSameStr(FFileName,FModule.GetFileName()) ) then begin
FHandler := nil;
FModule := nil;
end;
end;
procedure TLIBTransport.LoadModule();
begin
if ( FModule = nil ) then begin
FModule := LibraryManager.Get(FFileName);
FHandler := TwstLibraryHandlerFunction(FModule.GetProc(WST_LIB_HANDLER));
end;
end;
constructor TLIBTransport.Create();
begin
inherited Create();
FPropMngr := TPublishedPropertyManager.Create(Self);
FModule := nil;
FHandler := nil
end;
destructor TLIBTransport.Destroy();
begin
FPropMngr := Nil;
FModule := nil;
FHandler := nil;
inherited Destroy();
end;
function TLIBTransport.GetPropertyManager(): IPropertyManager;
begin
Result := FPropMngr;
end;
const MAX_ERR_LEN = 500;
procedure TLIBTransport.SendAndReceive(ARequest, AResponse: TStream);
Var
wrtr : IDataStore;
buffStream : TMemoryStream;
strBuff : string;
intfBuffer : IwstStream;
bl : LongInt;
{$IFDEF WST_DBG}
s : string;
i : Int64;
{$ENDIF WST_DBG}
begin
LoadModule();
buffStream := TMemoryStream.Create();
try
wrtr := CreateBinaryWriter(buffStream);
wrtr.WriteInt32S(0);
wrtr.WriteStr(Target);
wrtr.WriteStr(ContentType);
SetLength(strBuff,ARequest.Size);
ARequest.Position := 0;
ARequest.Read(strBuff[1],Length(strBuff));
wrtr.WriteStr(strBuff);
buffStream.Position := 0;
wrtr.WriteInt32S(buffStream.Size-4);
buffStream.Position := 0;
intfBuffer := TwstStream.Create(buffStream);
bl := MAX_ERR_LEN;
strBuff := StringOfChar(#0,bl);
if ( FHandler(intfBuffer,Pointer(strBuff),bl) <> RET_OK ) then
raise Exception.Create(strBuff);
buffStream.Position := 0;
AResponse.Size := 0;
AResponse.CopyFrom(buffStream,0);
AResponse.Position := 0;
{$IFDEF WST_DBG}
i := AResponse.Position;
SetLength(s,AResponse.Size);
AResponse.Read(s[1],AResponse.Size);
if IsConsole then
WriteLn(s)
else
ShowMessage(s);
{$ENDIF WST_DBG}
finally
buffStream.Free();
end;
end;
procedure LIB_Register_Transport();
begin
GetTransportRegistry().Register(sTRANSPORT_NAME,TSimpleItemFactory.Create(TLIBTransport) as IItemFactory);
end;
end.

121
wst/tags/0.4/library_server_intf.pas Normal file
View File

@ -0,0 +1,121 @@
{
This file is part of the Web Service Toolkit
Copyright (c) 2006 by Inoussa OUEDRAOGO
This file is provide under modified LGPL licence
( the files COPYING.modifiedLGPL and COPYING.LGPL).
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.
}
unit library_server_intf;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils,
library_base_intf;
function wstHandleRequest(
ARequestBuffer : IwstStream;
AErrorBuffer : Pointer;
var AErrorBufferLen : LongInt
):LongInt;
implementation
uses base_service_intf, server_service_intf, server_service_imputils, binary_streamer;
function wstHandleRequest(
ARequestBuffer : IwstStream;
AErrorBuffer : Pointer;
var AErrorBufferLen : LongInt
):LongInt;
procedure CopyErrMsg(const AMsg : string);
var
j,m : Integer;
begin
m := AErrorBufferLen;
j := Length(AMsg);
if ( j > 0 ) then begin
if ( j > m ) then
j := m;
try
Move(AMsg[1],AErrorBuffer^,j);
except
end;
end;
end;
Var
buff, trgt,ctntyp : string;
rqst : IRequestBuffer;
rdr : IDataStoreReader;
inStream, bufStream : TMemoryStream;
bs, bytesCount : LongWord;
begin
Result := RET_FALSE;
try
inStream := nil;
bufStream := nil;
if Assigned(ARequestBuffer) then begin
wstCheck(ARequestBuffer.GetSize(bs));
if ( bs > 0 ) then begin
try
inStream := TMemoryStream.Create();
bufStream := TMemoryStream.Create();
bufStream.Size := bs;
wstCheck(ARequestBuffer.SetPosition(0));
wstCheck(ARequestBuffer.Read(bufStream.Memory,bs,bytesCount));
if ( bs <> bytesCount ) then
wstCheck(RET_FALSE,'Invalid buffer operation (READ)');
wstCheck(ARequestBuffer.SetSize(0));
bufStream.Position := 0;
rdr := CreateBinaryReader(bufStream);
if ( rdr.ReadInt32S() <> ( bs - 4 ) ) then
wstCheck(RET_FALSE,'Invalid buffer.');
trgt := rdr.ReadStr();
ctntyp := rdr.ReadStr();
buff := rdr.ReadStr();
rdr := nil;
bufStream.Size := 0;
bufStream.Position := 0;
inStream.Write(buff[1],Length(buff));
SetLength(buff,0);
inStream.Position := 0;
rqst := TRequestBuffer.Create(trgt,ctntyp,inStream,bufStream);
HandleServiceRequest(rqst);
bs := bufStream.Size;
wstCheck(ARequestBuffer.SetSize(bs));
wstCheck(ARequestBuffer.SetPosition(0));
wstCheck(ARequestBuffer.Write(bufStream.Memory,bs,bytesCount));
if ( bs <> bytesCount ) then
wstCheck(RET_FALSE,'Invalid buffer operation (WRITE)');
Result := RET_OK;
finally
bufStream.Free();
inStream.Free();
end;
end;
end;
except
on e : EwstCheckException do begin
Result := e.ReturnCode;
CopyErrMsg(e.Message);
end;
on e : Exception do begin
Result := RET_FALSE;
CopyErrMsg(e.Message);
end else begin
Result := RET_FALSE;
end;
end;
end;
end.

826
wst/tags/0.4/metadata_repository.pas Normal file
View File

@ -0,0 +1,826 @@
{
This file is part of the Web Service Toolkit
Copyright (c) 2006 by Inoussa OUEDRAOGO
This file is provide under modified LGPL licence
( the files COPYING.modifiedLGPL and COPYING.LGPL).
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.
}
unit metadata_repository;
interface
uses
Classes, SysUtils, TypInfo;
{$INCLUDE wst.inc}
const
sWST_SIGNATURE = 'WST_METADATA_0.2.2.0';
sWST_META = 'wst_meta';
sFORMAT = 'FORMAT';
sTRANSPORT = 'TRANSPORT';
type
EMetadataException = class(Exception)
end;
PPropertyData = ^TPropertyData;
TPropertyData = record
Name : string;
Data : string;
Next : PPropertyData;
end;
TOperationParamFlag = ( opfNone, opfIn, opfVar, opfOut );
POperationParam = ^TOperationParam;
TOperationParam = record
Name : ShortString;
TypeName : ShortString;
Modifier : TOperationParamFlag;
end;
PServiceOperation = ^TServiceOperation;
TServiceOperation = record
Name : ShortString;
ParamsCount : Byte;
Params : POperationParam;
Properties : PPropertyData;
end;
PService = ^TService;
TService = record
Name : ShortString;
OperationsCount : Byte;
Operations : PServiceOperation;
Properties : PPropertyData;
end;
PServiceRepository = ^TServiceRepository;
TServiceRepository = record
NameSpace : ShortString;
Name : ShortString;
RootAddress : ShortString;
ServicesCount : Byte;
Services : PService;
end;
IModuleMetadataMngr = interface
['{B10ACF6A-A599-45A3-B083-BEEFB810C889}']
function IndexOfName(const ARepName : shortstring):Integer;
function GetCount():Integer;
function GetRepositoryName(const AIndex : Integer):shortstring;
procedure SetRepositoryNameSpace(const ARepName,ANameSpace : shortstring);
function LoadRepositoryName(
const ARepName,ARootAddress : shortstring;
out ARepository : PServiceRepository
):Integer;
procedure ClearRepository(var ARepository : PServiceRepository);
procedure SetServiceCustomData(
const ARepName : shortstring;
const AServiceName : shortstring;
const ADataName,
AData : string
);
procedure SetOperationCustomData(
const ARepName : shortstring;
const AServiceName : shortstring;
const AOperationName : shortstring;
const ADataName,
AData : string
);
//---------------------------------
function GetServiceMetadata(const ARepName,AServiceName : shortstring) : PService;
procedure ClearServiceMetadata(var AService : PService);
end;
function GetModuleMetadataMngr():IModuleMetadataMngr;
function LoadRepositoryData(
const AStream : TStream;
out ARepository : PServiceRepository
):LongInt;
procedure ClearRepositoryData(var ARepository : PServiceRepository);
function Find(const AProps : PPropertyData; const APropName : string) : PPropertyData;
function GetServiceDefaultAddress(AServiceTyp : PTypeInfo):string;
function GetServiceDefaultFormatProperties(AServiceTyp : PTypeInfo):string;
implementation
uses wst_resources_imp, binary_streamer, imp_utils;
{$INCLUDE wst_rtl_imp.inc}
const sADDRESS = 'Address';
function GetServiceDefaultAddress(AServiceTyp : PTypeInfo):string;
var
typData : PTypeData;
servcMdt : PService;
propData : PPropertyData;
begin
Result := '';
if Assigned(AServiceTyp) and (AServiceTyp^.Kind = tkInterface) then begin
typData := GetTypeData(AServiceTyp);
if Assigned(typData) then begin
servcMdt := GetModuleMetadataMngr().GetServiceMetadata(typData^.IntfUnit,AServiceTyp^.Name);
if Assigned(AServiceTyp) then begin
propData := Find(servcMdt^.Properties,sTRANSPORT + '_' + sADDRESS);
if Assigned(propData) then
Result := propData^.Data;
end;
end;
end;
end;
function GetServiceDefaultFormatProperties(AServiceTyp : PTypeInfo):string;
var
typData : PTypeData;
servcMdt : PService;
propData : PPropertyData;
strName : string;
begin
Result := '';
if Assigned(AServiceTyp) and (AServiceTyp^.Kind = tkInterface) then begin
typData := GetTypeData(AServiceTyp);
if Assigned(typData) then begin
servcMdt := GetModuleMetadataMngr().GetServiceMetadata(typData^.IntfUnit,AServiceTyp^.Name);
if Assigned(AServiceTyp) then begin
propData := servcMdt^.Properties;
while Assigned(propData) do begin
if ( AnsiPos(sFORMAT + '_',propData^.Name) = 1 ) then begin
strName := ExtractOptionName(propData^.Name);
if ( Length(strName) > 0 ) then begin
Result := Format('%s%s=%s;',[Result,strName,propData^.Data]);
end;
end;
propData := propData^.Next;
end;
if not IsStrEmpty(Result) then begin
Delete(Result,Length(Result),1);
end;
end;
end;
end;
end;
procedure ClearProperties(var AProps : PPropertyData);
var
c : Integer;
q, p : PPropertyData;
begin
if not Assigned(AProps) then
Exit;
c := SizeOf(TPropertyData);
p := AProps;
while Assigned(p) do begin
q := p;
p := p^.Next;
q^.Name := '';
q^.Data := '';
Freemem(q,c);
end;
AProps := nil;
end;
function CloneProperties(const AProps : PPropertyData) : PPropertyData;
var
c : Integer;
p,q, q0 : PPropertyData;
begin
Result := nil;
if not Assigned(AProps) then
Exit;
c := SizeOf(TPropertyData);
q0 := wst_GetMem(c);
q := q0;
p := AProps;
while Assigned(p) do begin
q^.Next := wst_GetMem(c);
FillChar(q^.Next^,c,#0);
q := q^.Next;
q^.Name := p^.Name;
q^.Data := p^.Data;
p := p^.Next;
end;
Result := q0^.Next;
Freemem(q0,c);
end;
function Find(const AProps : PPropertyData; const APropName : string) : PPropertyData;
begin
if Assigned(AProps) then begin
Result := AProps;
while Assigned(Result) do begin
if AnsiSameText(APropName,Result^.Name) then
Exit;
Result := Result^.Next;
end;
end;
Result := nil;
end;
function Add(
var AProps : PPropertyData;
const APropName,
APropData : string
) : PPropertyData;
begin
if not Assigned(AProps) then begin
AProps := wst_GetMem(SizeOf(TPropertyData));
FillChar(AProps^,SizeOf(TPropertyData),#0);
AProps^.Next := nil;
Result := AProps;
end else begin
Result := Find(AProps,APropName);
if not Assigned(Result) then begin
Result := wst_GetMem(SizeOf(TPropertyData));
FillChar(Result^,SizeOf(TPropertyData),#0);
Result^.Next := AProps;
AProps := Result;
end;
end;
Result^.Name := APropName;
Result^.Data := APropData;
end;
procedure ClearService(AService : PService; const AFreeService : Boolean);
procedure ClearOperation(AOperation : PServiceOperation);
var
cc : LongInt;
begin
cc := AOperation^.ParamsCount;
if ( cc > 0 ) then begin
Freemem(AOperation^.Params, cc * SizeOf(TOperationParam) );
end;
ClearProperties(AOperation^.Properties);
end;
var
j, k : LongInt;
po : PServiceOperation;
begin
if not Assigned(AService) then
Exit;
k := AService^.OperationsCount;
if ( k > 0 ) then begin
po := AService^.Operations;
for j := 0 to Pred(k) do begin
//ClearOperation(@(po[j]));
ClearOperation(po);
Inc(po);
end;
Freemem(AService^.Operations, k * SizeOf(TServiceOperation) );
AService^.Operations := nil;
ClearProperties(AService^.Properties);
AService^.Properties := nil;
end;
if AFreeService then
Freemem(AService,SizeOf(TService));
end;
procedure ClearRepositoryData(var ARepository : PServiceRepository);
var
i, c : LongInt;
ps : PService;
begin
if Assigned(ARepository) then begin
c := ARepository^.ServicesCount;
if ( c > 0 ) then begin
ps := ARepository^.Services;
for i := 0 to Pred(c) do begin
//ClearService(@(ps[i]),false);
ClearService(ps,false);
Inc(ps);
end;
Freemem(ARepository^.Services, c * SizeOf(TService) );
end;
Freemem(ARepository,SizeOf(TServiceRepository));
ARepository := nil;
end;
end;
function LoadRepositoryData(
const AStream : TStream;
out ARepository : PServiceRepository
):LongInt;
var
rdr : IDataStoreReader;
procedure LoadService(AService : PService);
procedure LoadOperation(AOperation : PServiceOperation);
procedure LoadParam(APrm : POperationParam);
begin
APrm^.Name := rdr.ReadStr();
APrm^.TypeName := rdr.ReadStr();
APrm^.Modifier := TOperationParamFlag(rdr.ReadEnum());
end;
var
ii, cc : LongInt;
pp : POperationParam;
begin
AOperation^.Name := rdr.ReadStr();
AOperation^.Properties := nil;
cc := rdr.ReadInt8U();
if ( cc > 0 ) then begin
AOperation^.Params := wst_GetMem( cc * SizeOf(TOperationParam) );
FillChar(AOperation^.Params^, cc * SizeOf(TOperationParam), #0);
AOperation^.ParamsCount := cc;
pp := AOperation^.Params;
for ii := 0 to Pred(cc) do begin
//LoadParam(@(pp[ii]));
LoadParam(pp);
Inc(pp);
end;
end;
end;
var
j, k : LongInt;
po : PServiceOperation;
begin
AService^.Name := rdr.ReadStr();
AService^.Properties := nil;
k := rdr.ReadInt8U();
if ( k > 0 ) then begin
AService^.Operations := wst_GetMem( k * SizeOf(TServiceOperation) );
AService^.OperationsCount := k;
FillChar(AService^.Operations^,k * SizeOf(TServiceOperation), #0);
po := AService^.Operations;
for j := 0 to Pred(k) do begin
//LoadOperation(@(po[j]));
LoadOperation(po);
Inc(po);
end;
end;
end;
var
buf : string;
i, c : LongInt;
ps : PService;
begin
ARepository := nil;
Result := 0;
rdr := CreateBinaryReader(AStream);
buf := rdr.ReadStr();
if ( sWST_SIGNATURE <> buf ) then
raise EMetadataException.CreateFmt('Invalid Metadata signature : "%s"',[buf]);
c := SizeOf(TServiceRepository);
ARepository := wst_GetMem(c);
try
FillChar(ARepository^,c,#0);
ARepository^.Name := rdr.ReadStr();
c := rdr.ReadInt8U();
if ( c > 0 ) then begin
ARepository^.Services := wst_GetMem( c * SizeOf(TService) );
ARepository^.ServicesCount := c;
FillChar(ARepository^.Services^,c * SizeOf(TService),#0);
ps := ARepository^.Services;
for i := 0 to Pred(c) do begin
//LoadService(@(ps[i]));
LoadService(ps);
Inc(ps);
end;
end;
Result := c;
except
ClearRepositoryData(ARepository);
raise;
end;
end;
procedure CopyService(ASrcService,ADestService : PService);
procedure CopyOperation(ASrcOperation, ADstOperation : PServiceOperation);
procedure CopyParam(ASrcPrm, ADstPrm : POperationParam);
begin
ADstPrm^ := ASrcPrm^;
end;
var
ii, cc : LongInt;
ppSrc, pp : POperationParam;
begin
ADstOperation^.Name := ASrcOperation^.Name;
ADstOperation^.Properties := CloneProperties(ASrcOperation^.Properties);
cc := ASrcOperation^.ParamsCount;
if ( cc > 0 ) then begin
ADstOperation^.Params := wst_GetMem( cc * SizeOf(TOperationParam) );
FillChar(ADstOperation^.Params^, cc * SizeOf(TOperationParam), #0);
ADstOperation^.ParamsCount := cc;
ppSrc := ASrcOperation^.Params;
pp := ADstOperation^.Params;
for ii := 0 to Pred(cc) do begin
//CopyParam(@(ASrcOperation^.Params[ii]),@(pp[ii]));
CopyParam(ppSrc,pp);
Inc(ppSrc);
Inc(pp);
end;
end;
end;
var
j, k : LongInt;
poSrc, po : PServiceOperation;
begin
ADestService^.Name := ASrcService^.Name;
ADestService^.Properties := CloneProperties(ASrcService^.Properties);
k := ASrcService^.OperationsCount;
if ( k > 0 ) then begin
ADestService^.Operations := wst_GetMem( k * SizeOf(TServiceOperation) );
ADestService^.OperationsCount := k;
FillChar(ADestService^.Operations^,k * SizeOf(TServiceOperation), #0);
po := ADestService^.Operations;
poSrc := ASrcService^.Operations;
for j := 0 to Pred(k) do begin
//CopyOperation(@(ASrcService^.Operations[j]),@(po[j]));
CopyOperation(poSrc,po);
Inc(poSrc);
Inc(po);
end;
end;
end;
function CloneService(const ASrcService : PService) : PService;
var
c : Integer;
begin
c := SizeOf(TService);
Result := wst_GetMem(c);
FillChar(Result^,c,#0);
CopyService(ASrcService,Result);
end;
procedure CloneRepository(
const ASource : PServiceRepository;
out ADest : PServiceRepository
);
var
i, c : LongInt;
psSrc, ps : PService;
begin
ADest := nil;
if not Assigned(ASource) then
Exit;
c := SizeOf(TServiceRepository);
ADest := wst_GetMem(c);
try
FillChar(ADest^,c,#0);
ADest^.Name := ASource^.Name;
ADest^.NameSpace := ASource^.NameSpace;
ADest^.RootAddress := ASource^.RootAddress;
c := ASource^.ServicesCount;
if ( c > 0 ) then begin
ADest^.Services := wst_GetMem( c * SizeOf(TService) );
ADest^.ServicesCount := c;
FillChar(ADest^.Services^,c * SizeOf(TService),#0);
ps := ADest^.Services;
psSrc := ASource^.Services;
for i := 0 to Pred(c) do begin
//CopyService(@(ASource^.Services[i]),@(ps[i]));
CopyService(psSrc,ps);
end;
end;
except
ClearRepositoryData(ADest);
raise;
end;
end;
type
{ TModuleMetadataMngr }
TModuleMetadataMngr = class(TInterfacedObject,IInterface,IModuleMetadataMngr)
private
FList : TStringList;
FRepositories : array of PServiceRepository;
private
procedure LoadRegisteredNames();
procedure ClearList();
function FindInnerListIndex(const ARepName : shortstring):Integer;
function InternalLoadRepository(const ARepName : shortstring):Integer;
protected
function IndexOfName(const ARepName : shortstring):Integer;
procedure RegisterRepository(const ARepName : shortstring);
function GetCount():Integer;
function GetRepositoryName(const AIndex : Integer):shortstring;
procedure SetRepositoryNameSpace(const ARepName,ANameSpace : shortstring);
function LoadRepositoryName(
const ARepName,ARootAddress : shortstring;
out ARepository : PServiceRepository
):Integer;
procedure ClearRepository(var ARepository : PServiceRepository);
procedure SetServiceCustomData(
const ARepName : shortstring;
const AServiceName : shortstring;
const ADataName,
AData : string
);
procedure SetOperationCustomData(
const ARepName : shortstring;
const AServiceName : shortstring;
const AOperationName : shortstring;
const ADataName,
AData : string
);
function GetServiceMetadata(const ARepName,AServiceName : shortstring) : PService;
procedure ClearServiceMetadata(var AService : PService);
public
constructor Create();
destructor Destroy();override;
end;
var
ModuleMetadataMngrInst : IModuleMetadataMngr = nil;
function GetModuleMetadataMngr():IModuleMetadataMngr;
begin
if not Assigned(ModuleMetadataMngrInst) then
ModuleMetadataMngrInst := TModuleMetadataMngr.Create() as IModuleMetadataMngr;
Result := ModuleMetadataMngrInst;
end;
{ TModuleMetadataMngr }
procedure TModuleMetadataMngr.LoadRegisteredNames();
var
i : Integer;
L : TStrings;
begin
L:=TStringList.Create;
Try
GetWSTResourceManager.GetResourceList(L);
For I:=0 to L.Count-1 do
RegisterRepository(L[i]);
finally
L.Free;
end;
end;
procedure TModuleMetadataMngr.ClearList();
var
i : Integer;
begin
for i := 0 to Length(FRepositories) - 1 do begin
ClearRepository(FRepositories[i]);
end;
SetLength(FRepositories,0);
end;
function TModuleMetadataMngr.FindInnerListIndex(const ARepName: shortstring): Integer;
begin
for Result := 0 to Pred(Length(FRepositories)) do begin
if AnsiSameText(ARepName,FRepositories[Result]^.Name) then
Exit;
end;
Result := -1;
end;
function TModuleMetadataMngr.InternalLoadRepository(const ARepName: shortstring): Integer;
var
tmpStrm : TMemoryStream;
strBuffer : string;
i : Integer;
tmpRes : PServiceRepository;
begin
If not GetWSTResourceManager.HasResource(ARepName) then
raise EMetadataException.CreateFmt('Repository not registered : "%s"',[ARepName]);
Result := FindInnerListIndex(ARepName);
if ( Result < 0 ) then begin
tmpStrm := TMemoryStream.Create();
try
strBuffer := GetWSTResourceManager.ResourceAsString(ARepName);
i := Length(strBuffer);
tmpStrm.Write(strBuffer[1],i);
tmpStrm.Position := 0;
LoadRepositoryData(tmpStrm,tmpRes);
if Assigned(tmpRes) then begin
Result := Length(FRepositories);
SetLength(FRepositories, ( Result + 1 ) );
FRepositories[Result] := tmpRes;
i := Length(tmpRes^.RootAddress);
if ( i = 0 ) or ( tmpRes^.RootAddress[i] <> '/' ) then
tmpRes^.RootAddress := tmpRes^.RootAddress + '/';
tmpRes^.RootAddress := tmpRes^.RootAddress + 'services/';
tmpRes^.NameSpace := FList.Values[tmpRes^.Name];
if ( Length(tmpRes^.NameSpace) = 0 ) then
tmpRes^.NameSpace := 'urn:' + tmpRes^.Name;
end;
finally
tmpStrm.Free();
end;
end;
end;
function TModuleMetadataMngr.IndexOfName(const ARepName: shortstring): Integer;
begin
Result := FList.IndexOfName(ARepName);
end;
procedure TModuleMetadataMngr.RegisterRepository(const ARepName: shortstring);
begin
if ( FList.IndexOfName(ARepName) = -1 ) then begin
FList.Values[ARepName] := 'urn:' + ARepName;
end;
end;
function TModuleMetadataMngr.GetCount(): Integer;
begin
Result := FList.Count;
end;
function TModuleMetadataMngr.GetRepositoryName(const AIndex: Integer): shortstring;
begin
Result := FList.Names[AIndex];
end;
procedure TModuleMetadataMngr.SetRepositoryNameSpace(const ARepName,ANameSpace: shortstring);
var
i : Integer;
begin
FList.Values[ARepName] := ANameSpace;
i := FindInnerListIndex(ARepName);
if ( i >= 0 ) then
FRepositories[i]^.NameSpace := ANameSpace;
end;
function TModuleMetadataMngr.LoadRepositoryName(
const ARepName,ARootAddress : shortstring;
out ARepository : PServiceRepository
): Integer;
var
strBuffer : string;
i : Integer;
begin
Result := 0;
ARepository := nil;
i := FindInnerListIndex(ARepName);
if ( i < 0 ) then begin
i := InternalLoadRepository(ARepName);
end;
if ( Length(ARootAddress) > 0 ) and ( AnsiPos(ARootAddress,FRepositories[i]^.RootAddress) <> 1 ) then begin
strBuffer := ARootAddress;
if ( strBuffer[Length(strBuffer)] = '/' ) then
Delete(strBuffer,Length(strBuffer),1);
FRepositories[i]^.RootAddress := strBuffer + FRepositories[i]^.RootAddress;
end;
if ( i >= 0 ) then begin
CloneRepository(FRepositories[i],ARepository);
Exit;
end;
end;
procedure TModuleMetadataMngr.ClearRepository(var ARepository: PServiceRepository);
begin
ClearRepositoryData(ARepository);
end;
function FindService(
const ARep : PServiceRepository;
const AServiceName : shortstring
) : PService;
var
i : Integer;
srv : PService;
begin
srv := ARep^.Services;
for i := 0 to Pred(ARep^.ServicesCount) do begin
//if AnsiSameText(AServiceName,ARep^.Services[i].Name) then begin
if AnsiSameText(AServiceName,srv^.Name) then begin
Result := srv;
Exit;
end;
Inc(srv);
end;
Result := nil;
end;
procedure TModuleMetadataMngr.SetServiceCustomData(
const ARepName : shortstring;
const AServiceName : shortstring;
const ADataName,
AData : string
);
var
i : Integer;
rp : PServiceRepository;
sp : PService;
begin
i := FindInnerListIndex(ARepName);
if ( i < 0 ) then
i := InternalLoadRepository(ARepName);
rp := FRepositories[i];
sp := FindService(rp,AServiceName);
if not Assigned(sp) then
raise EMetadataException.CreateFmt('Service non found : "%s"',[AServiceName]);
Add(sp^.Properties,ADataName,AData);
end;
function FindOperation(
const AServ : PService;
const AOperationName : shortstring
) : PServiceOperation;
var
i : Integer;
sop : PServiceOperation;
begin
sop := AServ^.Operations;
for i := 0 to Pred(AServ^.OperationsCount) do begin
if AnsiSameText(AOperationName,sop^.Name) then begin
Result := sop;
Exit;
end;
Inc(sop);
end;
Result := nil;
end;
procedure TModuleMetadataMngr.SetOperationCustomData(
const ARepName : shortstring;
const AServiceName : shortstring;
const AOperationName : shortstring;
const ADataName,
AData : string
);
var
i : Integer;
rp : PServiceRepository;
sp : PService;
sop : PServiceOperation;
begin
i := FindInnerListIndex(ARepName);
if ( i < 0 ) then
i := InternalLoadRepository(ARepName);
rp := FRepositories[i];
sp := FindService(rp,AServiceName);
if not Assigned(sp) then
raise EMetadataException.CreateFmt('Service non found : "%s"',[AServiceName]);
sop := FindOperation(sp,AOperationName);
if not Assigned(sop) then
raise EMetadataException.CreateFmt('Operation non found : "%s"',[AOperationName]);
Add(sop^.Properties,ADataName,AData);
end;
function TModuleMetadataMngr.GetServiceMetadata(const ARepName,AServiceName: shortstring): PService;
var
i : Integer;
rp : PServiceRepository;
begin
Result := nil;
i := FindInnerListIndex(ARepName);
if ( i < 0 ) then
i := InternalLoadRepository(ARepName);
rp := FRepositories[i];
Result := FindService(rp,AServiceName);
if ( Result <> nil ) then begin
Result := CloneService(Result);
end;
end;
procedure TModuleMetadataMngr.ClearServiceMetadata(var AService: PService);
begin
ClearService(AService,True);
AService := nil;
end;
constructor TModuleMetadataMngr.Create();
begin
inherited Create();
FRepositories := nil;
FList := TStringList.Create();
LoadRegisteredNames();
end;
destructor TModuleMetadataMngr.Destroy();
begin
ClearList();
FreeAndNil(FList);
inherited Destroy();
end;
initialization
finalization
ModuleMetadataMngrInst := nil;
End.

254
wst/tags/0.4/metadata_service.pas Normal file
View File

@ -0,0 +1,254 @@
{
This file is part of the Web Service Toolkit
Copyright (c) 2006 by Inoussa OUEDRAOGO
This file is provide under modified LGPL licence
( the files COPYING.modifiedLGPL and COPYING.LGPL).
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.
}
unit metadata_service;
{$INCLUDE wst.inc}
interface
uses
Classes, SysUtils,
base_service_intf, metadata_repository;
type
TWSTMtdOperationParam = class(TBaseComplexRemotable)
private
FModifier: TOperationParamFlag;
FName: string;
FTypeName: string;
published
property Name : string read FName write FName;
property TypeName : string read FTypeName write FTypeName;
property Modifier : TOperationParamFlag read FModifier write FModifier;
end;
TWSTMtdOperationParamArray = class(TBaseObjectArrayRemotable)
protected
function GetParam(AIndex: Integer): TWSTMtdOperationParam;
public
class function GetItemClass():TBaseRemotableClass;override;
property Item[AIndex:Integer] : TWSTMtdOperationParam read GetParam;default;
end;
TWSTMtdServiceOperation = class(TBaseComplexRemotable)
private
FName: string;
FParams: TWSTMtdOperationParamArray;
function GetParams: TWSTMtdOperationParamArray;
procedure SetParams(const AValue: TWSTMtdOperationParamArray);
public
constructor Create();override;
destructor Destroy();override;
published
property Name : string read FName write FName;
property Params : TWSTMtdOperationParamArray read GetParams write SetParams;
end;
TWSTMtdServiceOperationArray = class(TBaseObjectArrayRemotable)
private
function GetOperation(AIndex: Integer): TWSTMtdServiceOperation;
public
class function GetItemClass():TBaseRemotableClass;override;
property Item[AIndex:Integer] : TWSTMtdServiceOperation read GetOperation;default;
end;
TWSTMtdService = class(TBaseComplexRemotable)
private
FName: string;
FOperations: TWSTMtdServiceOperationArray;
function GetOperations: TWSTMtdServiceOperationArray;
procedure SetOperations(const AValue: TWSTMtdServiceOperationArray);
public
constructor Create();override;
destructor Destroy();override;
published
property Name : string read FName write FName;
property Operations : TWSTMtdServiceOperationArray read GetOperations write SetOperations;
end;
TWSTMtdServiceArray = class(TBaseObjectArrayRemotable)
protected
function GetService(AIndex: Integer): TWSTMtdService;
public
class function GetItemClass():TBaseRemotableClass;override;
Property Item[AIndex:Integer] : TWSTMtdService Read GetService;Default;
end;
TWSTMtdRepository = class(TBaseComplexRemotable)
private
FName: string;
FNameSpace: string;
FServices : TWSTMtdServiceArray;
function GetServices: TWSTMtdServiceArray;
procedure SetServices(const AValue: TWSTMtdServiceArray);
public
constructor Create();override;
destructor Destroy();override;
published
property Name : string read FName write FName;
property NameSpace : string read FNameSpace write FNameSpace;
property Services : TWSTMtdServiceArray read GetServices write SetServices;
end;
{The unique metadata public service}
IWSTMetadataService = interface
['{804A3825-ADA5-4499-87BF-CF5491BFD674}']
function GetRepositoryList():TArrayOfStringRemotable;
function GetRepositoryInfo(const AName : string):TWSTMtdRepository;
end;
procedure Register_metadata_service_NameSpace();
implementation
procedure Register_metadata_service_NameSpace();
begin
GetModuleMetadataMngr().SetRepositoryNameSpace('metadata_service',sWST_BASE_NS);
end;
procedure Register_metadata_service_Types();
var
r : TTypeRegistry;
begin
r := GetTypeRegistry();
r.Register(sWST_BASE_NS,TypeInfo(TOperationParamFlag),'TOperationParamFlag');
r.Register(sWST_BASE_NS,TypeInfo(TWSTMtdOperationParam),'TWSTMtdOperationParam');
r.Register(sWST_BASE_NS,TypeInfo(TWSTMtdOperationParamArray),'TWSTMtdOperationParamArray');
r.Register(sWST_BASE_NS,TypeInfo(TWSTMtdOperationParam),'TWSTMtdOperationParam');
r.Register(sWST_BASE_NS,TypeInfo(TWSTMtdOperationParamArray),'TWSTMtdOperationParamArray');
r.Register(sWST_BASE_NS,TypeInfo(TWSTMtdServiceOperation),'TWSTMtdServiceOperation');
r.Register(sWST_BASE_NS,TypeInfo(TWSTMtdServiceOperationArray),'TWSTMtdServiceOperationArray');
r.Register(sWST_BASE_NS,TypeInfo(TWSTMtdService),'TWSTMtdService');
r.Register(sWST_BASE_NS,TypeInfo(TWSTMtdServiceArray),'TWSTMtdServiceArray');
r.Register(sWST_BASE_NS,TypeInfo(TWSTMtdRepository),'TWSTMtdRepository');
end;
{ TWSTMtdServiceArray }
function TWSTMtdServiceArray.GetService(AIndex: Integer): TWSTMtdService;
begin
Result := inherited Item[AIndex] as TWSTMtdService;
end;
class function TWSTMtdServiceArray.GetItemClass(): TBaseRemotableClass;
begin
Result := TWSTMtdService;
end;
{ TWSTMtdRepository }
function TWSTMtdRepository.GetServices: TWSTMtdServiceArray;
begin
Result := FServices;
end;
procedure TWSTMtdRepository.SetServices(const AValue: TWSTMtdServiceArray);
begin
FServices.Assign(AValue);
end;
constructor TWSTMtdRepository.Create();
begin
inherited Create();
FServices := TWSTMtdServiceArray.Create();
end;
destructor TWSTMtdRepository.Destroy();
begin
FreeAndNil(FServices);
inherited Destroy();
end;
{ TWSTMtdOperationParamArray }
function TWSTMtdOperationParamArray.GetParam(AIndex: Integer): TWSTMtdOperationParam;
begin
Result := inherited Item[AIndex] as TWSTMtdOperationParam;
end;
class function TWSTMtdOperationParamArray.GetItemClass(): TBaseRemotableClass;
begin
Result := TWSTMtdOperationParam;
end;
{ TWSTMtdServiceOperation }
function TWSTMtdServiceOperation.GetParams: TWSTMtdOperationParamArray;
begin
Result := FParams;
end;
procedure TWSTMtdServiceOperation.SetParams(const AValue: TWSTMtdOperationParamArray);
begin
FParams.Assign(AValue);
end;
constructor TWSTMtdServiceOperation.Create();
begin
inherited Create();
FParams := TWSTMtdOperationParamArray.Create();
end;
destructor TWSTMtdServiceOperation.Destroy();
begin
FreeAndNil(FParams);
inherited Destroy();
end;
{ TWSTMtdServiceOperationArray }
function TWSTMtdServiceOperationArray.GetOperation(AIndex: Integer): TWSTMtdServiceOperation;
begin
Result := inherited Item[AIndex] as TWSTMtdServiceOperation;
end;
class function TWSTMtdServiceOperationArray.GetItemClass(): TBaseRemotableClass;
begin
Result := TWSTMtdServiceOperation;
end;
{ TWSTMtdService }
function TWSTMtdService.GetOperations: TWSTMtdServiceOperationArray;
begin
Result := FOperations;
end;
procedure TWSTMtdService.SetOperations(const AValue: TWSTMtdServiceOperationArray);
begin
FOperations.Assign(AValue);
end;
constructor TWSTMtdService.Create();
begin
FOperations := TWSTMtdServiceOperationArray.Create();
inherited Create();
end;
destructor TWSTMtdService.Destroy();
begin
FreeAndNil(FOperations);
inherited Destroy();
end;
initialization
Register_metadata_service_Types();
end.

7
wst/tags/0.4/metadata_service.wst Normal file
View File

@ -0,0 +1,7 @@
GetWSTResourceManager().AddResource('METADATA_SERVICE',
#0#0#0#20'WST_METADATA_0.2.2.0'#0#0#0#16'metadata_service'#1#0#0#0#19'IWSTMe'
+'tadataService'#2#0#0#0#17'GetRepositoryList'#1#0#0#0#6'result'#0#0#0#23'TAr'
+'rayOfStringRemotable'#0#0#0#0#0#0#0#3#0#0#0#17'GetRepositoryInfo'#2#0#0#0#5
+'AName'#0#0#0#6'string'#0#0#0#0#0#0#0#1#0#0#0#6'result'#0#0#0#17'TWSTMtdRepo'
+'sitory'#0#0#0#0#0#0#0#3''
);

BIN
wst/tags/0.4/metadata_service.wst_meta Normal file
View File

Binary file not shown.

129
wst/tags/0.4/metadata_service_binder.pas Normal file
View File

@ -0,0 +1,129 @@
{
This unit has been produced by ws_helper.
Input unit name : "metadata_service".
This unit name : "metadata_service_binder".
Date : "12/11/2006 11:12".
}
unit metadata_service_binder;
{$INCLUDE wst.inc}
interface
uses SysUtils, Classes, base_service_intf, server_service_intf, metadata_service;
type
TWSTMetadataService_ServiceBinder=class(TBaseServiceBinder)
Protected
procedure GetRepositoryListHandler(AFormatter:IFormatterResponse);
procedure GetRepositoryInfoHandler(AFormatter:IFormatterResponse);
Public
constructor Create();
End;
TWSTMetadataService_ServiceBinderFactory = class(TInterfacedObject,IItemFactory)
protected
function CreateInstance():IInterface;
End;
procedure Server_service_RegisterWSTMetadataServiceService();
Implementation
uses TypInfo, wst_resources_imp,metadata_repository;
{ TWSTMetadataService_ServiceBinder implementation }
procedure TWSTMetadataService_ServiceBinder.GetRepositoryListHandler(AFormatter:IFormatterResponse);
Var
cllCntrl : ICallControl;
tmpObj : IWSTMetadataService;
callCtx : ICallContext;
strPrmName : string;
procName,trgName : string;
returnVal : TArrayOfStringRemotable;
Begin
callCtx := GetCallContext();
If ( PTypeInfo(TypeInfo(TArrayOfStringRemotable))^.Kind in [tkClass,tkInterface] ) Then
Pointer(returnVal) := Nil;
tmpObj := Self.GetFactory().CreateInstance() as IWSTMetadataService;
if Supports(tmpObj,ICallControl,cllCntrl) then
cllCntrl.SetCallContext(GetCallContext());
returnVal := tmpObj.GetRepositoryList();
If ( PTypeInfo(TypeInfo(TArrayOfStringRemotable))^.Kind = tkClass ) And Assigned(Pointer(returnVal)) Then
callCtx.AddObjectToFree(TObject(returnVal));
procName := AFormatter.GetCallProcedureName();
trgName := AFormatter.GetCallTarget();
AFormatter.Clear();
AFormatter.BeginCallResponse(procName,trgName);
AFormatter.Put('return',TypeInfo(TArrayOfStringRemotable),returnVal);
AFormatter.EndCallResponse();
callCtx := Nil;
End;
procedure TWSTMetadataService_ServiceBinder.GetRepositoryInfoHandler(AFormatter:IFormatterResponse);
Var
cllCntrl : ICallControl;
tmpObj : IWSTMetadataService;
callCtx : ICallContext;
strPrmName : string;
procName,trgName : string;
AName : string;
returnVal : TWSTMtdRepository;
Begin
callCtx := GetCallContext();
Pointer(returnVal) := Nil;
strPrmName := 'AName'; AFormatter.Get(TypeInfo(string),strPrmName,AName);
tmpObj := Self.GetFactory().CreateInstance() as IWSTMetadataService;
if Supports(tmpObj,ICallControl,cllCntrl) then
cllCntrl.SetCallContext(GetCallContext());
returnVal := tmpObj.GetRepositoryInfo(AName);
If Assigned(Pointer(returnVal)) Then
callCtx.AddObjectToFree(TObject(returnVal));
procName := AFormatter.GetCallProcedureName();
trgName := AFormatter.GetCallTarget();
AFormatter.Clear();
AFormatter.BeginCallResponse(procName,trgName);
AFormatter.Put('return',TypeInfo(TWSTMtdRepository),returnVal);
AFormatter.EndCallResponse();
callCtx := Nil;
End;
constructor TWSTMetadataService_ServiceBinder.Create();
Begin
Inherited Create(GetServiceImplementationRegistry().FindFactory('IWSTMetadataService'));
RegisterVerbHandler('GetRepositoryList',@GetRepositoryListHandler);
RegisterVerbHandler('GetRepositoryInfo',@GetRepositoryInfoHandler);
End;
{ TWSTMetadataService_ServiceBinderFactory }
function TWSTMetadataService_ServiceBinderFactory.CreateInstance():IInterface;
Begin
Result := TWSTMetadataService_ServiceBinder.Create() as IInterface;
End;
procedure Server_service_RegisterWSTMetadataServiceService();
Begin
GetServerServiceRegistry().Register('IWSTMetadataService',TWSTMetadataService_ServiceBinderFactory.Create() as IItemFactory);
End;
initialization
{$IF DECLARED(Register_metadata_service_NameSpace)}
Register_metadata_service_NameSpace();
{$ENDIF}
{$i metadata_service.wst}
End.

126
wst/tags/0.4/metadata_service_imp.pas Normal file
View File

@ -0,0 +1,126 @@
{
This unit has been produced by ws_helper.
Input unit name : "metadata_service".
This unit name : "metadata_service_imp".
Date : "01/07/2006 22:14".
}
Unit metadata_service_imp;
{$INCLUDE wst.inc}
Interface
Uses SysUtils, Classes,
base_service_intf, server_service_intf, server_service_imputils, metadata_service;
Type
TWSTMetadataService_ServiceImp=class(TSimpleFactoryItem,IWSTMetadataService)
Protected
function GetRepositoryList():TArrayOfStringRemotable;
function GetRepositoryInfo(
Const AName : string
):TWSTMtdRepository;
End;
procedure RegisterWSTMetadataServiceImplementationFactory();
Implementation
uses metadata_repository;
{ TWSTMetadataService_ServiceImp implementation }
function TWSTMetadataService_ServiceImp.GetRepositoryList():TArrayOfStringRemotable;
var
i, c : Integer;
mn : IModuleMetadataMngr;
Begin
Result := TArrayOfStringRemotable.Create();
try
mn := GetModuleMetadataMngr();
c := mn.GetCount();
Result.SetLength(c);
for i := 0 to Pred(c) do
Result[i] := mn.GetRepositoryName(i);
except
FreeAndNil(Result);
raise;
end;
End;
function TWSTMetadataService_ServiceImp.GetRepositoryInfo(Const AName : string):TWSTMtdRepository;
procedure LoadService(ARawServ : PService; AObjServ : TWSTMtdService);
procedure LoadOperation(ARawOper : PServiceOperation; AObjOper : TWSTMtdServiceOperation);
procedure LoadParam(ARawParam : POperationParam; AObjPrm : TWSTMtdOperationParam);
begin
if Assigned(ARawParam) and Assigned(AObjPrm) then begin
AObjPrm.Name :=ARawParam^.Name;
AObjPrm.TypeName := ARawParam^.TypeName;
AObjPrm.Modifier := ARawParam^.Modifier;
end;
end;
var
ii, cc : Integer;
begin
if Assigned(ARawOper) and Assigned(AObjOper) then begin
AObjOper.Name :=ARawOper^.Name;
cc := ARawOper^.ParamsCount;
AObjOper.Params.SetLength(cc);
for ii := 0 to Pred(cc) do
LoadParam(@(ARawOper^.Params[ii]),AObjOper.Params[ii]);
end;
end;
var
k, d : Integer;
begin
if Assigned(ARawServ) and Assigned(AObjServ) then begin
AObjServ.Name :=ARawServ^.Name;
d := ARawServ^.OperationsCount;
AObjServ.Operations.SetLength(d);
for k := 0 to Pred(d) do
LoadOperation(@(ARawServ^.Operations[k]),AObjServ.Operations[k]);
end;
end;
var
repData : PServiceRepository;
mn : IModuleMetadataMngr;
i, c : Integer;
Begin
Result := nil;
mn := GetModuleMetadataMngr();
mn.LoadRepositoryName(AName,'/',repData);
if Assigned(repData) then begin
try
try
Result := TWSTMtdRepository.Create();
Result.Name := repData^.Name;
Result.NameSpace := repData^.NameSpace;
c := repData^.ServicesCount;
Result.Services.SetLength(c);
if ( c > 0 ) then begin
for i := 0 to Pred(c) do begin
LoadService(@(repData^.Services[i]),Result.Services[i]);
end;
end;
except
FreeAndNil(Result);
raise;
end;
finally
mn.ClearRepository(repData);
end;
end;
End;
procedure RegisterWSTMetadataServiceImplementationFactory();
Begin
GetServiceImplementationRegistry().Register('IWSTMetadataService',TImplementationFactory.Create(TWSTMetadataService_ServiceImp) as IServiceImplementationFactory);
End;
End.

90
wst/tags/0.4/metadata_service_proxy.pas Normal file
View File

@ -0,0 +1,90 @@
{
This unit has been produced by ws_helper.
Input unit name : "metadata_service".
This unit name : "metadata_service_proxy".
Date : "12/11/2006 11:12".
}
Unit metadata_service_proxy;
{$mode objfpc}{$H+}
Interface
Uses SysUtils, Classes, TypInfo, base_service_intf, service_intf, metadata_service;
Type
TWSTMetadataService_Proxy=class(TBaseProxy,IWSTMetadataService)
Protected
class function GetServiceType() : PTypeInfo;override;
function GetRepositoryList():TArrayOfStringRemotable;
function GetRepositoryInfo(
Const AName : string
):TWSTMtdRepository;
End;
Implementation
uses wst_resources_imp, metadata_repository;
{ TWSTMetadataService_Proxy implementation }
class function TWSTMetadataService_Proxy.GetServiceType() : PTypeInfo;
begin
result := TypeInfo(IWSTMetadataService);
end;
function TWSTMetadataService_Proxy.GetRepositoryList():TArrayOfStringRemotable;
Var
locSerializer : IFormatterClient;
strPrmName : string;
Begin
locSerializer := GetSerializer();
Try
locSerializer.BeginCall('GetRepositoryList', GetTarget(),(Self as ICallContext));
locSerializer.EndCall();
MakeCall();
locSerializer.BeginCallRead((Self as ICallContext));
If ( PTypeInfo(TypeInfo(TArrayOfStringRemotable))^.Kind in [tkClass,tkInterface] ) Then
Pointer(Result) := Nil;
strPrmName := 'return';
locSerializer.Get(TypeInfo(TArrayOfStringRemotable), strPrmName, result);
Finally
locSerializer.Clear();
End;
End;
function TWSTMetadataService_Proxy.GetRepositoryInfo(
Const AName : string
):TWSTMtdRepository;
Var
locSerializer : IFormatterClient;
strPrmName : string;
Begin
locSerializer := GetSerializer();
Try
locSerializer.BeginCall('GetRepositoryInfo', GetTarget(),(Self as ICallContext));
locSerializer.Put('AName', TypeInfo(string), AName);
locSerializer.EndCall();
MakeCall();
locSerializer.BeginCallRead((Self as ICallContext));
Pointer(Result) := Nil;
strPrmName := 'return';
locSerializer.Get(TypeInfo(TWSTMtdRepository), strPrmName, result);
Finally
locSerializer.Clear();
End;
End;
initialization
{$i metadata_service.wst}
{$IF DECLARED(Register_metadata_service_ServiceMetadata)}
Register_metadata_service_ServiceMetadata();
{$ENDIF}
End.

825
wst/tags/0.4/metadata_wsdl.pas Normal file
View File

@ -0,0 +1,825 @@
{
This file is part of the Web Service Toolkit
Copyright (c) 2006 by Inoussa OUEDRAOGO
This file is provide under modified LGPL licence
( the files COPYING.modifiedLGPL and COPYING.LGPL).
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.
}
unit metadata_wsdl;
{$INCLUDE wst.inc}
interface
uses
Classes, SysUtils, TypInfo,
DOM,
base_service_intf, metadata_repository;
type
IWsdlTypeHandler = interface
['{DA9AF8B1-392B-49A8-91CC-6B5C5131E6FA}']
procedure Generate(
const APascalTypeName : string;
AWsdlDocument : TDOMDocument
);
end;
IWsdlTypeHandlerRegistry = Interface
['{A2FA2FE4-933D-44CC-B266-BF48674DECE9}']
function Find(const APascalTypeName : string):IWsdlTypeHandler;
procedure Register(
const APascalTypeName : string;
AFactory : IItemFactory
);
procedure RegisterDefaultHandler(
const ATypeKind : TTypeKind;
AFactory : IItemFactory
);
End;
{ TEnumTypeHandler }
TEnumTypeHandler = class(TSimpleFactoryItem,IWsdlTypeHandler)
protected
procedure Generate(
const APascalTypeName : string;
AWsdlDocument : TDOMDocument
);
end;
{ TBaseComplexRemotable_TypeHandler }
TBaseComplexRemotable_TypeHandler = class(TSimpleFactoryItem,IWsdlTypeHandler)
protected
procedure Generate(
const APascalTypeName : string;
AWsdlDocument : TDOMDocument
);
end;
{ TBaseObjectArrayRemotable_TypeHandler }
TBaseArrayRemotable_TypeHandler = class(TSimpleFactoryItem,IWsdlTypeHandler)
protected
procedure Generate(
const APascalTypeName : string;
AWsdlDocument : TDOMDocument
);
end;
procedure GenerateWSDL(AMdtdRep : PServiceRepository; ADoc : TDOMDocument);
function GetWsdlTypeHandlerRegistry():IWsdlTypeHandlerRegistry;
implementation
const
sWSDL_NS = 'http://schemas.xmlsoap.org/wsdl/';
sSOAP_NS = 'http://schemas.xmlsoap.org/wsdl/soap/';
sSOAP = 'soap';
sSOAP_ENC_NS = 'http://schemas.xmlsoap.org/soap/encoding/';
sXMLNS = 'xmlns';
sXSD_NS = 'http://www.w3.org/2001/XMLSchema';
sXSD = 'xsd';
sTNS = 'tns';
sSOAP_ACTION = 'soapAction';
sSOAP_ENCODED = 'encoded';
sSOAP_ENCODING_STYLE = 'encodingStyle';
sSOAP_RPC = 'rpc';
sSOAP_TRANSPORT = 'http://schemas.xmlsoap.org/soap/http';
sSOAP_USE = 'use';
sADDRESS = 'address';
sATTRIBUTE = 'attribute';
sBASE = 'base';
sBINDING = 'binding';
sBODY = 'body';
sCOMPLEX_TYPE = 'complexType';
sELEMENT = 'element';
sENUMERATION = 'enumeration';
sITEM = 'item';
sLOCATION = 'location';
sMIN_OCCURS = 'minOccurs';
sMAX_OCCURS = 'maxOccurs';
sNAME = 'name';
sNAME_SPACE = 'namespace';
sPORT_TYPE = 'portType';
sRESTRICTION = 'restriction';
sSEQUENCE = 'sequence';
sSERVICE = 'service';
sSIMPLE_TYPE = 'simpleType';
sSTYLE = 'style';
sTRANSPORT = 'transport';
sTYPE = 'type';
sUNBOUNDED = 'unbounded';
sUSE = 'use';
sVALUE = 'value';
sWSDL_DEFINITIONS = 'definitions';
sWSDL_INPUT = 'input';
sWSDL_MESSAGE = 'message';
sWSDL_NAME = 'name';
sWSDL_OPERATION = 'operation';
sWSDL_OUTPUT = 'output';
sWSDL_PART = 'part';
sWSDL_PORT = 'port';
sWSDL_PORT_TYPE = sPORT_TYPE;
sWSDL_SCHEMA = 'schema';
sWSDL_TARGET_NS = 'targetNamespace';
sWSDL_TYPE = sTYPE;
sWSDL_TYPES = 'types';
sFORMAT_Input_EncodingStyle = 'FORMAT_Input_EncodingStyle';
sFORMAT_Input_EncodingStyleURI = 'FORMAT_Input_EncodingStyleURI';
var
WsdlTypeHandlerRegistryInst : IWsdlTypeHandlerRegistry;
type
{ TWsdlTypeHandlerRegistry }
TWsdlTypeHandlerRegistry = class(TBaseFactoryRegistry,IInterface,IWsdlTypeHandlerRegistry)
private
FDefaultHandlerTable : Array[TTypeKind] of IItemFactory;
private
function FindNearestClass(const AClassType : TClass):IItemFactory;
protected
function Find(const APascalTypeName : string):IWsdlTypeHandler;
procedure RegisterDefaultHandler(
const ATypeKind : TTypeKind;
AFactory : IItemFactory
);
public
destructor Destroy();override;
End;
{ TWsdlTypeHandlerRegistry }
function DistanceFromChildToParent(AChildClass,AParentClass : TClass):Integer;
var
ch : TClass;
begin
if Assigned(AChildClass) and Assigned(AParentClass) then begin
Result := 0;
ch := AChildClass;
while Assigned(ch) do begin
if ( ch = AParentClass ) then
Exit;
Inc(Result);
ch := ch.ClassParent;
end;
end;
Result := MaxInt;
end;
function TWsdlTypeHandlerRegistry.FindNearestClass(const AClassType : TClass):IItemFactory;
var
i,c, foundIndex,tmpScore, score : Integer;
itm : TBaseFactoryRegistryItem;
typData : PTypeData;
r : TTypeRegistry;
ri : TTypeRegistryItem;
begin
Result := nil;
foundIndex := -1;
score := MaxInt;
r := GetTypeRegistry();
c := Count;
for i := 0 to Pred(c) do begin
itm := Item[i];
ri := r.Find(itm.Name);
if Assigned(ri) and ( ri.DataType^.Kind = tkClass ) then begin
typData := GetTypeData(ri.DataType);
tmpScore := DistanceFromChildToParent(AClassType,typData^.ClassType);
if ( tmpScore < score ) then begin
foundIndex := i;
score := tmpScore;
end;
end;
end;
if ( foundIndex >= 0 ) then begin
Result := Item[foundIndex].Factory;
end;
end;
function TWsdlTypeHandlerRegistry.Find(const APascalTypeName: string): IWsdlTypeHandler;
Var
fct : IItemFactory;
ri : TTypeRegistryItem;
begin
Result := nil;
fct := FindFactory(APascalTypeName);
if not Assigned(fct) then begin
ri := GetTypeRegistry().Find(APascalTypeName);
if Assigned(ri) then begin
if ( ri.DataType^.Kind = tkClass ) then
fct := FindNearestClass(GetTypeData(ri.DataType)^.ClassType);
if not Assigned(fct) then
fct := FDefaultHandlerTable[ri.DataType^.Kind];
end;
end;
if Assigned(fct) then
Result := fct.CreateInstance() as IWsdlTypeHandler;
end;
procedure TWsdlTypeHandlerRegistry.RegisterDefaultHandler(
const ATypeKind: TTypeKind;
AFactory: IItemFactory
);
begin
FDefaultHandlerTable[ATypeKind] := AFactory;
end;
destructor TWsdlTypeHandlerRegistry.Destroy();
var
i : TTypeKind;
begin
for i := Low(TTypeKind) to High(TTypeKind) do
FDefaultHandlerTable[i] := nil;
inherited Destroy();
end;
function CreateElement(const ANodeName : DOMString; AParent : TDOMNode; ADoc : TDOMDocument):TDOMElement;//inline;
begin
Result := ADoc.CreateElement(ANodeName);
AParent.AppendChild(Result);
end;
function FindAttributeByValueInNode(
const AAttValue : string;
const ANode : TDOMNode;
out AResAtt : string;
const AStartIndex : Integer = 0;
const AStartingWith : string = ''
):boolean;
var
i,c : Integer;
b : Boolean;
begin
AResAtt := '';
if Assigned(ANode) and Assigned(ANode.Attributes) then begin
b := ( Length(AStartingWith) = 0);
c := Pred(ANode.Attributes.Length);
if ( AStartIndex >= 0 ) then
i := AStartIndex;
for i := 0 to c do begin
if AnsiSameText(AAttValue,ANode.Attributes.Item[i].NodeValue) and
( b or ( Pos(AStartingWith,ANode.Attributes.Item[i].NodeName) = 1 ))
then begin
AResAtt := ANode.Attributes.Item[i].NodeName;
Result := True;
Exit;
end;
end;
end;
Result := False;
end;
function GetNameSpaceShortName(
const ANameSpace : string;
AWsdlDocument : TDOMDocument
):string;//inline;
begin
if FindAttributeByValueInNode(ANameSpace,AWsdlDocument.DocumentElement,Result,0,sXMLNS) then begin
Result := Copy(Result,Length(sXMLNS+':')+1,MaxInt);
end else begin
Result := Format('ns%d',[AWsdlDocument.DocumentElement.Attributes.{$IFNDEF FPC_211}Count{$ELSE}Length{$ENDIF}]) ;
AWsdlDocument.DocumentElement.SetAttribute(Format('%s:%s',[sXMLNS,Result]),ANameSpace);
end;
end;
type TServiceElementType = ( setPortType, setBinding, setPort, setService,setAddress );
function GetServicePartName(AService : PService; const AServicePart : TServiceElementType):string;
const PART_NAME_MAP : array[TServiceElementType] of shortstring = ('', 'Binding', 'Port', '','');
begin
Result := AService^.Name + PART_NAME_MAP[AServicePart];
end;
procedure GenerateWSDL(AMdtdRep : PServiceRepository; ADoc : TDOMDocument);
procedure GenerateServiceMessages(
AService : PService;
ARootNode : TDOMElement
);
procedure GenerateOperationMessage(AOperation : PServiceOperation);
procedure GenerateParam(APrm : POperationParam; AMsgNode : TDOMElement);
var
tmpNode : TDOMElement;
typItm : TTypeRegistryItem;
ns_shortName, s : string;
begin
tmpNode := CreateElement(sWSDL_PART,AMsgNode,ADoc);
tmpNode.SetAttribute(sWSDL_NAME,APrm^.Name);
typItm := GetTypeRegistry().Find(APrm^.TypeName);
if not Assigned(typItm) then
raise EMetadataException.CreateFmt('Type not registered : "%s".',[APrm^.TypeName]);
//Assert(Assigned(typItm),APrm^.TypeName);
ns_shortName := GetNameSpaceShortName(typItm.NameSpace,ADoc);
s := Format('%s:%s',[ns_shortName,typItm.DeclaredName]);
tmpNode.SetAttribute(sWSDL_TYPE,s);
end;
var
qryNode, rspNode : TDOMElement;
ii, cc : Integer;
pp : POperationParam;
begin
qryNode := CreateElement(sWSDL_MESSAGE,ARootNode,ADoc);
qryNode.SetAttribute(sWSDL_NAME,Format('%s',[AOperation^.Name]));
rspNode := CreateElement(sWSDL_MESSAGE,ARootNode,ADoc);
rspNode.SetAttribute(sWSDL_NAME,Format('%sResponse',[AOperation^.Name]));
cc := AOperation^.ParamsCount;
for ii := 0 to Pred(cc) do begin
pp := @(AOperation^.Params[ii]);
if ( pp^.Modifier in [opfNone, opfIn] ) then
GenerateParam(pp,qryNode)
else if ( pp^.Modifier in [opfVar, opfOut] ) then
GenerateParam(pp,rspNode);
end;
end;
Var
j, k : Integer;
po : PServiceOperation;
begin
k := AService^.OperationsCount;
if ( k > 0 ) then begin
po := AService^.Operations;
for j := 0 to pred(k) do
GenerateOperationMessage(@(po[j]));
end;
end;
procedure GenerateServicePortType(AService : PService; ARootNode : TDOMElement);
procedure GenerateOperation(AOperation : PServiceOperation; APrtTypeNode : TDOMElement);
var
opNode, inNode, outNode : TDOMElement;
begin
opNode := CreateElement(sWSDL_OPERATION,APrtTypeNode,ADoc);
opNode.SetAttribute(sWSDL_NAME,AOperation^.Name);
inNode := CreateElement(sWSDL_INPUT,opNode,ADoc);
inNode.SetAttribute(sWSDL_MESSAGE,Format('%s:%s',[sTNS,AOperation^.Name]));
outNode := CreateElement(sWSDL_OUTPUT,opNode,ADoc);
outNode.SetAttribute(sWSDL_MESSAGE,Format('%s:%sResponse',[sTNS,AOperation^.Name]));
end;
var
prtTypeNode : TDOMElement;
j, k : Integer;
po : PServiceOperation;
begin
prtTypeNode := CreateElement(sWSDL_PORT_TYPE,ARootNode,ADoc);
prtTypeNode.SetAttribute(sWSDL_NAME,GetServicePartName(AService,setPortType));
k := AService^.OperationsCount;
if ( k > 0 ) then begin
po := AService^.Operations;
for j := 0 to pred(k) do begin
GenerateOperation(@(po[j]),prtTypeNode);
end;
end;
end;
procedure GenerateServiceBinding(AService : PService; ARootNode : TDOMElement);
procedure GenerateOperation(AOperation : PServiceOperation; ABndngNode : TDOMElement);
var
opNode, inNode, outNode, bdyNode : TDOMElement;
strBuff : string;
propData : PPropertyData;
encdStyl,encdStylURI : string;
begin
strBuff := Format('%s:%s',[sSOAP,sWSDL_OPERATION]);
//CreateElement(strBuff,ABndngNode,ADoc).SetAttribute(sSOAP_ACTION,Format('%s/%s%s',[AMdtdRep^.NameSpace,AService^.Name,AOperation^.Name]));
opNode := CreateElement(sWSDL_OPERATION,ABndngNode,ADoc);
opNode.SetAttribute(sWSDL_NAME,AOperation^.Name);
CreateElement(strBuff,opNode,ADoc).SetAttribute(sSOAP_ACTION,Format('%s/%s%s',[AMdtdRep^.NameSpace,AService^.Name,AOperation^.Name]));
inNode := CreateElement(sWSDL_INPUT,opNode,ADoc);
strBuff := Format('%s:%s',[sSOAP,sBODY]);
bdyNode := CreateElement(strBuff,inNode,ADoc);
encdStyl := 'literal';
encdStylURI := '';
propData := Find(AOperation^.Properties,sFORMAT_Input_EncodingStyle);
if Assigned(propData) and ( Length(Trim(propData^.Data)) > 0 ) then begin
encdStyl := Trim(propData^.Data);
end;
bdyNode.SetAttribute(sSOAP_USE,encdStyl);
bdyNode.SetAttribute(sNAME_SPACE,Format('%s',[AMdtdRep^.NameSpace]));
propData := Find(AOperation^.Properties,sFORMAT_Input_EncodingStyleURI);
if Assigned(propData) and ( Length(Trim(propData^.Data)) > 0 ) then begin
encdStylURI := Trim(propData^.Data);
end;
if ( Length(encdStylURI) > 0 ) then
bdyNode.SetAttribute(sSOAP_ENCODING_STYLE,encdStylURI);
outNode := CreateElement(sWSDL_OUTPUT,opNode,ADoc);
strBuff := Format('%s:%s',[sSOAP,sBODY]);
bdyNode := CreateElement(strBuff,outNode,ADoc);
bdyNode.SetAttribute(sSOAP_USE,encdStyl);
bdyNode.SetAttribute(sNAME_SPACE,Format('%s',[AMdtdRep^.NameSpace]));
if ( Length(encdStylURI) > 0 ) then
bdyNode.SetAttribute(sSOAP_ENCODING_STYLE,encdStylURI);
end;
var
bndgNode, soapbndgNode : TDOMElement;
j, k : Integer;
po : PServiceOperation;
strBuf : string;
begin
bndgNode := CreateElement(sBINDING,ARootNode,ADoc);
bndgNode.SetAttribute(sWSDL_NAME,GetServicePartName(AService,setBinding));
bndgNode.SetAttribute(sWSDL_TYPE,Format('%s:%s',[sTNS,GetServicePartName(AService,setPortType)]));
strBuf := Format('%s:%s',[sSOAP,sBINDING]);
soapbndgNode := CreateElement(strBuf,bndgNode,ADoc);
soapbndgNode.SetAttribute(sSTYLE,sSOAP_RPC);
soapbndgNode.SetAttribute(sTRANSPORT,sSOAP_TRANSPORT);
k := AService^.OperationsCount;
if ( k > 0 ) then begin
po := AService^.Operations;
for j := 0 to pred(k) do begin
GenerateOperation(@(po[j]),bndgNode);
end;
end;
end;
procedure GenerateServicePublication(AService : PService; ARootNode : TDOMElement);
var
srvcNode, portNode, soapAdrNode : TDOMElement;
strBuf : string;
begin
srvcNode := CreateElement(sSERVICE,ARootNode,ADoc);
srvcNode.SetAttribute(sWSDL_NAME,GetServicePartName(AService,setService));
strBuf := Format('%s',[sWSDL_PORT]);
portNode := CreateElement(strBuf,srvcNode,ADoc);
portNode.SetAttribute(sWSDL_NAME,GetServicePartName(AService,setPort));
portNode.SetAttribute(sBINDING,Format('%s:%s',[sTNS,GetServicePartName(AService,setBinding)]));
strBuf := Format('%s:%s',[sSOAP,sADDRESS]);
soapAdrNode := CreateElement(strBuf,portNode,ADoc);
soapAdrNode.SetAttribute(sLOCATION,Format('%s%s',[AMdtdRep^.RootAddress,GetServicePartName(AService,setAddress)]));
end;
procedure GenerateServiceTypes();
var
j, k : Integer;
tr : TTypeRegistry;
tri : TTypeRegistryItem;
g : IWsdlTypeHandler;
gr : IWsdlTypeHandlerRegistry;
begin
tr := GetTypeRegistry();
gr := GetWsdlTypeHandlerRegistry();
k := tr.Count;
for j := 0 to Pred(k) do begin
tri := tr[j];
if ( not ( trioNonVisibleToMetadataService in tri.Options ) ) and
AnsiSameText(AMdtdRep^.NameSpace,tri.NameSpace)
then begin
g := gr.Find(tri.DataType^.Name);
if assigned(g) then
g.Generate(tri.DataType^.Name,ADoc);
end;
end;
end;
function CreateRootNode():TDOMElement;
begin
Result := CreateElement(sWSDL_DEFINITIONS,ADoc,ADoc);
Result.SetAttribute(sWSDL_NAME,AMdtdRep^.Name);
Result.SetAttribute(sWSDL_TARGET_NS,AMdtdRep^.NameSpace);
Result.SetAttribute(Format('%s:%s',[sXMLNS,sSOAP]),sSOAP_NS);
Result.SetAttribute(Format('%s:%s',[sXMLNS,sXSD]),sXSD_NS);
Result.SetAttribute(Format('%s:%s',[sXMLNS,sTNS]),AMdtdRep^.NameSpace);
Result.SetAttribute(sXMLNS,sWSDL_NS);
end;
function CreateTypesRootNode(ARootNode : TDOMNode):TDOMElement;
begin
Result := CreateElement(sWSDL_TYPES,ARootNode,ADoc);
//Result.SetAttribute(sWSDL_TARGET_NS,AMdtdRep^.NameSpace);
end;
var
defNode, typesNode, schNode : TDOMElement;
i, c : Integer;
ps : PService;
begin
if not ( Assigned(AMdtdRep) and Assigned(ADoc)) then
Exit;
defNode := CreateRootNode();
typesNode := CreateTypesRootNode(defNode);
schNode := CreateElement(sXSD + ':' + sWSDL_SCHEMA,typesNode,ADoc);
schNode.SetAttribute(sXMLNS,sXSD_NS);
schNode.SetAttribute(sWSDL_TARGET_NS,AMdtdRep^.NameSpace);
GenerateServiceTypes();
c := AMdtdRep^.ServicesCount;
if ( c > 0 ) then begin
ps := AMdtdRep^.Services;
for i := 0 to Pred(c) do begin
GenerateServiceMessages(@(ps[i]),defNode);
end;
for i := 0 to Pred(c) do begin
GenerateServicePortType(@(ps[i]),defNode);
end;
for i := 0 to Pred(c) do begin
GenerateServiceBinding(@(ps[i]),defNode);
end;
for i := 0 to Pred(c) do begin
GenerateServicePublication(@(ps[i]),defNode);
end;
end;
end;
function GetWsdlTypeHandlerRegistry():IWsdlTypeHandlerRegistry;
begin
Result := WsdlTypeHandlerRegistryInst;
end;
type
{ TFakeTypeHandler }
TFakeTypeHandler = class(TSimpleFactoryItem,IWsdlTypeHandler)
protected
procedure Generate(
const APascalTypeName : string;
AWsdlDocument : TDOMDocument
);
end;
{ TBaseComplexRemotable_TypeHandler }
procedure TBaseComplexRemotable_TypeHandler.Generate(
const APascalTypeName : string;
AWsdlDocument : TDOMDocument
);
var
typItm, propTypItm : TTypeRegistryItem;
s, prop_ns_shortName : string;
defTypesNode, defSchemaNode, cplxNode, sqcNode, propNode, eltNode : TDOMElement;
i : Integer;
propList : PPropList;
propCount, propListLen : Integer;
p : PPropInfo;
persistType : TPropStoreType;
objTypeData : PTypeData;
clsTyp : TBaseComplexRemotableClass;
attProp : Boolean;
begin
typItm := GetTypeRegistry().Find(APascalTypeName);
if Assigned(typItm) and
( typItm.DataType^.Kind = tkClass )
then begin
GetNameSpaceShortName(typItm.NameSpace,AWsdlDocument);
defTypesNode := AWsdlDocument.DocumentElement.FindNode(sWSDL_TYPES) as TDOMElement;
Assert(Assigned(defTypesNode));
defSchemaNode := defTypesNode.FirstChild as TDOMElement;
s := Format('%s:%s',[sXSD,sELEMENT]);
eltNode := CreateElement(s,defSchemaNode,AWsdlDocument);
eltNode.SetAttribute(sNAME, typItm.DeclaredName) ;
s := Format('%s:%s',[sXSD,sCOMPLEX_TYPE]);
cplxNode := CreateElement(s,eltNode,AWsdlDocument);
//cplxNode.SetAttribute(sNAME, typItm.DeclaredName) ;
s := Format('%s:%s',[sXSD,sSEQUENCE]);
sqcNode := CreateElement(s,cplxNode,AWsdlDocument);
objTypeData := GetTypeData(typItm.DataType);
clsTyp := TBaseComplexRemotableClass(objTypeData^.ClassType);
propCount := objTypeData^.PropCount;
if ( propCount > 0 ) then begin
propListLen := GetPropList(typItm.DataType,propList);
try
for i := 0 to Pred(propCount) do begin
p := propList^[i];
persistType := IsStoredPropClass(objTypeData^.ClassType,p);
if ( persistType in [pstOptional,pstAlways] ) then begin
attProp := clsTyp.IsAttributeProperty(p^.Name);
if attProp then begin
s := Format('%s:%s',[sXSD,sATTRIBUTE]);
propNode := CreateElement(s,cplxNode,AWsdlDocument)
end else begin
s := Format('%s:%s',[sXSD,sELEMENT]);
propNode := CreateElement(s,sqcNode,AWsdlDocument);
end;
propNode.SetAttribute(sNAME,p^.Name);
propTypItm := GetTypeRegistry().Find(p^.PropType^.Name);
if Assigned(propTypItm) then begin
prop_ns_shortName := GetNameSpaceShortName(propTypItm.NameSpace,AWsdlDocument);
propNode.SetAttribute(sTYPE,Format('%s:%s',[prop_ns_shortName,propTypItm.DeclaredName]));
if attProp then begin
if ( persistType = pstOptional ) then
propNode.SetAttribute(sATTRIBUTE,'optional')
else
propNode.SetAttribute(sATTRIBUTE,'required');
end else begin
if ( persistType = pstOptional ) then
propNode.SetAttribute(sMIN_OCCURS,'0')
else
propNode.SetAttribute(sMIN_OCCURS,'1');
propNode.SetAttribute(sMAX_OCCURS,'1');
end;
end;
end;
end;
finally
Freemem(propList,propListLen*SizeOf(Pointer));
end;
end;
end;
end;
{ TEnumTypeHandler }
procedure TEnumTypeHandler.Generate(
const APascalTypeName: string;
AWsdlDocument: TDOMDocument
);
var
typItm : TTypeRegistryItem;
ns_shortName, s : string;
defTypesNode, defSchemaNode, resNode, restrictNode, eltNode : TDOMElement;
i, c : Integer;
begin
typItm := GetTypeRegistry().Find(APascalTypeName);
if Assigned(typItm) and
( typItm.DataType^.Kind = tkEnumeration )
then begin
if FindAttributeByValueInNode(typItm.NameSpace,AWsdlDocument.DocumentElement,ns_shortName) then begin
ns_shortName := Copy(ns_shortName,Length(sXMLNS+':')+1,MaxInt);
end else begin
ns_shortName := Format('ns%d',[AWsdlDocument.DocumentElement.Attributes.{$IFNDEF FPC_211}Count{$ELSE}Length{$ENDIF}]) ;
AWsdlDocument.DocumentElement.SetAttribute(Format('%s:%s',[sXMLNS,ns_shortName]),typItm.NameSpace);
end;
defTypesNode := AWsdlDocument.DocumentElement.FindNode(sWSDL_TYPES) as TDOMElement;
Assert(Assigned(defTypesNode));
defSchemaNode := defTypesNode.FirstChild as TDOMElement;
//s := Format('%s:%s',[sXSD,sELEMENT]);
//eltNode := CreateElement(s,defSchemaNode,AWsdlDocument);
//eltNode.SetAttribute(sNAME, typItm.DeclaredName) ;
s := Format('%s:%s',[sXSD,sSIMPLE_TYPE]);
resNode := CreateElement(s,defSchemaNode,AWsdlDocument);
resNode.SetAttribute(sNAME, typItm.DeclaredName) ;
s := Format('%s:%s',[sXSD,sRESTRICTION]);
restrictNode := CreateElement(s,resNode,AWsdlDocument);
restrictNode.SetAttribute(sBASE,Format('%s:%s',[sXSD,'string'])) ;
c := GetEnumNameCount(typItm.DataType);
for i := 0 to pred(c) do begin
s := Format('%s:%s',[sXSD,sENUMERATION]);
//CreateElement(s,restrictNode,AWsdlDocument).SetAttribute(sVALUE,GetEnumName(typItm.DataType,i));
CreateElement(s,restrictNode,AWsdlDocument).SetAttribute(
sVALUE,
typItm.GetExternalPropertyName(GetEnumName(typItm.DataType,i))
);
end;
end;
end;
{ TFakeTypeHandler }
procedure TFakeTypeHandler.Generate(
const APascalTypeName: string;
AWsdlDocument: TDOMDocument
);
begin
end;
procedure RegisterFondamentalTypes();
var
r : IWsdlTypeHandlerRegistry;
begin
r := GetWsdlTypeHandlerRegistry();
r.RegisterDefaultHandler(tkInteger,TSimpleItemFactory.Create(TFakeTypeHandler) as IItemFactory);
r.RegisterDefaultHandler(tkInt64,TSimpleItemFactory.Create(TFakeTypeHandler) as IItemFactory);
r.RegisterDefaultHandler(tkQWord,TSimpleItemFactory.Create(TFakeTypeHandler) as IItemFactory);
r.RegisterDefaultHandler(tkSString,TSimpleItemFactory.Create(TFakeTypeHandler) as IItemFactory);
r.RegisterDefaultHandler(tkLString,TSimpleItemFactory.Create(TFakeTypeHandler) as IItemFactory);
r.RegisterDefaultHandler(tkAString,TSimpleItemFactory.Create(TFakeTypeHandler) as IItemFactory);
r.RegisterDefaultHandler(tkWString,TSimpleItemFactory.Create(TFakeTypeHandler) as IItemFactory);
r.RegisterDefaultHandler(tkWString,TSimpleItemFactory.Create(TFakeTypeHandler) as IItemFactory);
r.RegisterDefaultHandler(tkBool,TSimpleItemFactory.Create(TFakeTypeHandler) as IItemFactory);
r.RegisterDefaultHandler(tkEnumeration,TSimpleItemFactory.Create(TEnumTypeHandler) as IItemFactory);
r.RegisterDefaultHandler(tkClass,TSimpleItemFactory.Create(TBaseComplexRemotable_TypeHandler) as IItemFactory);
r.Register('TBaseArrayRemotable',TSimpleItemFactory.Create(TBaseArrayRemotable_TypeHandler) as IItemFactory);
{ r.Register('Integer',TSimpleItemFactory.Create(TFakeTypeHandler) as IItemFactory);
r.Register('LongWord',TSimpleItemFactory.Create(TFakeTypeHandler) as IItemFactory);
r.Register('string',TSimpleItemFactory.Create(TFakeTypeHandler) as IItemFactory);
r.Register('shortstring',TSimpleItemFactory.Create(TFakeTypeHandler) as IItemFactory);
r.Register('ansistring',TSimpleItemFactory.Create(TFakeTypeHandler) as IItemFactory);
r.Register('boolean',TSimpleItemFactory.Create(TFakeTypeHandler) as IItemFactory);
r.Register('Byte',TSimpleItemFactory.Create(TFakeTypeHandler) as IItemFactory);
r.Register('ShortInt',TSimpleItemFactory.Create(TFakeTypeHandler) as IItemFactory);
r.Register('Word',TSimpleItemFactory.Create(TFakeTypeHandler) as IItemFactory);
r.Register('SmallInt',TSimpleItemFactory.Create(TFakeTypeHandler) as IItemFactory);
r.Register('Int64',TSimpleItemFactory.Create(TFakeTypeHandler) as IItemFactory);
r.Register('QWord',TSimpleItemFactory.Create(TFakeTypeHandler) as IItemFactory);
r.Register('Single',TSimpleItemFactory.Create(TFakeTypeHandler) as IItemFactory);
r.Register('Currency',TSimpleItemFactory.Create(TFakeTypeHandler) as IItemFactory);
r.Register('Comp',TSimpleItemFactory.Create(TFakeTypeHandler) as IItemFactory);
r.Register('Double',TSimpleItemFactory.Create(TFakeTypeHandler) as IItemFactory);
r.Register('Extended',TSimpleItemFactory.Create(TFakeTypeHandler) as IItemFactory);
}
end;
{ TBaseArrayRemotable_TypeHandler }
procedure TBaseArrayRemotable_TypeHandler.Generate(
const APascalTypeName: string;
AWsdlDocument: TDOMDocument
);
function GetNameSpaceShortName(const ANameSpace : string):string;//inline;
begin
if FindAttributeByValueInNode(ANameSpace,AWsdlDocument.DocumentElement,Result,0,sXMLNS) then begin
Result := Copy(Result,Length(sXMLNS+':')+1,MaxInt);
end else begin
Result := Format('ns%d',[AWsdlDocument.DocumentElement.Attributes.{$IFNDEF FPC_211}Count{$ELSE}Length{$ENDIF}]) ;
AWsdlDocument.DocumentElement.SetAttribute(Format('%s:%s',[sXMLNS,Result]),ANameSpace);
end;
end;
var
typItm, propTypItm : TTypeRegistryItem;
s, prop_ns_shortName : string;
defTypesNode, defSchemaNode, cplxNode, sqcNode, propNode, eltNode : TDOMElement;
arrayTypeData : PTypeData;
arrayTypeClass : TBaseArrayRemotableClass;
begin
typItm := GetTypeRegistry().Find(APascalTypeName);
if not Assigned(typItm) then
Exit;
arrayTypeData := GetTypeData(typItm.DataType);
if Assigned(typItm) and
( typItm.DataType^.Kind = tkClass ) and
( arrayTypeData^.ClassType.InheritsFrom(TBaseArrayRemotable) )
then begin
GetNameSpaceShortName(typItm.NameSpace);
defTypesNode := AWsdlDocument.DocumentElement.FindNode(sWSDL_TYPES) as TDOMElement;
Assert(Assigned(defTypesNode));
defSchemaNode := defTypesNode.FirstChild as TDOMElement;
s := Format('%s:%s',[sXSD,sELEMENT]);
eltNode := CreateElement(s,defSchemaNode,AWsdlDocument);
eltNode.SetAttribute(sNAME, typItm.DeclaredName) ;
s := Format('%s:%s',[sXSD,sCOMPLEX_TYPE]);
cplxNode := CreateElement(s,eltNode,AWsdlDocument);
//cplxNode.SetAttribute(sNAME, typItm.DeclaredName) ;
s := Format('%s:%s',[sXSD,sSEQUENCE]);
sqcNode := CreateElement(s,cplxNode,AWsdlDocument);
arrayTypeClass := TBaseArrayRemotableClass(arrayTypeData^.ClassType);
propTypItm := GetTypeRegistry().Find(arrayTypeClass.GetItemTypeInfo()^.Name);
s := Format('%s:%s',[sXSD,sELEMENT]);
propNode := CreateElement(s,sqcNode,AWsdlDocument);
propNode.SetAttribute(sNAME,sITEM);
if Assigned(propTypItm) then begin
prop_ns_shortName := GetNameSpaceShortName(propTypItm.NameSpace);
propNode.SetAttribute(sTYPE,Format('%s:%s',[prop_ns_shortName,propTypItm.DeclaredName]));
propNode.SetAttribute(sMIN_OCCURS,'0');
propNode.SetAttribute(sMAX_OCCURS,sUNBOUNDED);
end;
end;
end;
initialization
WsdlTypeHandlerRegistryInst := TWsdlTypeHandlerRegistry.Create() as IWsdlTypeHandlerRegistry;
RegisterFondamentalTypes();
finalization
WsdlTypeHandlerRegistryInst := nil;
end.

94
wst/tags/0.4/same_process_protocol.pas Normal file
View File

@ -0,0 +1,94 @@
{
This file is part of the Web Service Toolkit
Copyright (c) 2006 by Inoussa OUEDRAOGO
This file is provide under modified LGPL licence
( the files COPYING.modifiedLGPL and COPYING.LGPL).
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.
}
unit same_process_protocol;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils,
service_intf, imp_utils,
server_service_intf, server_service_imputils, base_service_intf;
Const
sTRANSPORT_NAME = 'SAME_PROCESS';
Type
{$M+}
{ TInProcessTransport }
TInProcessTransport = class(TSimpleFactoryItem,ITransport)
Private
FAdress: string;
FContentType: string;
FPropMngr : IPropertyManager;
Public
constructor Create();override;
destructor Destroy();override;
function GetPropertyManager():IPropertyManager;
procedure SendAndReceive(ARequest,AResponse:TStream);
Published
property ContentType : string Read FContentType Write FContentType;
property Adress : string Read FAdress Write FAdress;
End;
{$M+}
procedure SAME_PROCESS_Register_Local_Transport();
implementation
{ TInProcessTransport }
constructor TInProcessTransport.Create();
begin
FPropMngr := TPublishedPropertyManager.Create(Self);
end;
destructor TInProcessTransport.Destroy();
begin
FPropMngr := Nil;
inherited Destroy();
end;
function TInProcessTransport.GetPropertyManager(): IPropertyManager;
begin
Result := FPropMngr;
end;
procedure TInProcessTransport.SendAndReceive(ARequest, AResponse: TStream);
Var
bffr : IRequestBuffer;
{$IFDEF WST_DBG}
s : string;
i : Int64;
{$ENDIF WST_DBG}
begin
bffr := TRequestBuffer.Create(Adress,ContentType,ARequest,AResponse);
HandleServiceRequest(bffr);
{$IFDEF WST_DBG}
i := AResponse.Position;
SetLength(s,AResponse.Size);
AResponse.Read(s[1],AResponse.Size);
WriteLn(s);
{$ENDIF WST_DBG}
end;
procedure SAME_PROCESS_Register_Local_Transport();
begin
GetTransportRegistry().Register(sTRANSPORT_NAME,TSimpleItemFactory.Create(TInProcessTransport) as IItemFactory);
end;
end.

20241
wst/tags/0.4/samples/amazon/AWSECommerceService.pas Normal file
View File

File diff suppressed because it is too large Load Diff

579
wst/tags/0.4/samples/amazon/AWSECommerceService_proxy.pas Normal file
View File

@ -0,0 +1,579 @@
{
This unit has been produced by ws_helper.
Input unit name : "AWSECommerceService".
This unit name : "AWSECommerceService_proxy".
Date : "6-5-07 19:37:08".
}
Unit AWSECommerceService_proxy;
{$IFDEF FPC} {$mode objfpc}{$H+} {$ENDIF}
Interface
Uses SysUtils, Classes, TypInfo, base_service_intf, service_intf, AWSECommerceService;
Type
TAWSECommerceServicePortType_Proxy=class(TBaseProxy,AWSECommerceServicePortType)
Protected
class function GetServiceType() : PTypeInfo;override;
function Help(
Const HelpParam : Help_Type
):HelpResponse_Type;
function ItemSearch(
Const ItemSearchParam : ItemSearch_Type
):ItemSearchResponse_Type;
function ItemLookup(
Const ItemLookupParam : ItemLookup_Type
):ItemLookupResponse_Type;
function BrowseNodeLookup(
Const BrowseNodeLookupParam : BrowseNodeLookup_Type
):BrowseNodeLookupResponse_Type;
function ListSearch(
Const ListSearchParam : ListSearch_Type
):ListSearchResponse_Type;
function ListLookup(
Const ListLookupParam : ListLookup_Type
):ListLookupResponse_Type;
function CustomerContentSearch(
Const CustomerContentSearchParam : CustomerContentSearch_Type
):CustomerContentSearchResponse_Type;
function CustomerContentLookup(
Const CustomerContentLookupParam : CustomerContentLookup_Type
):CustomerContentLookupResponse_Type;
function SimilarityLookup(
Const SimilarityLookupParam : SimilarityLookup_Type
):SimilarityLookupResponse_Type;
function SellerLookup(
Const SellerLookupParam : SellerLookup_Type
):SellerLookupResponse_Type;
function CartGet(
Const CartGetParam : CartGet_Type
):CartGetResponse_Type;
function CartAdd(
Const CartAddParam : CartAdd_Type
):CartAddResponse_Type;
function CartCreate(
Const CartCreateParam : CartCreate_Type
):CartCreateResponse_Type;
function CartModify(
Const CartModifyParam : CartModify_Type
):CartModifyResponse_Type;
function CartClear(
Const CartClearParam : CartClear_Type
):CartClearResponse_Type;
function TransactionLookup(
Const TransactionLookupParam : TransactionLookup_Type
):TransactionLookupResponse_Type;
function SellerListingSearch(
Const SellerListingSearchParam : SellerListingSearch_Type
):SellerListingSearchResponse_Type;
function SellerListingLookup(
Const SellerListingLookupParam : SellerListingLookup_Type
):SellerListingLookupResponse_Type;
function MultiOperation(
Const MultiOperationParam : MultiOperationType
):MultiOperationResponse;
End;
Function wst_CreateInstance_AWSECommerceServicePortType(const AFormat : string = 'SOAP:'; const ATransport : string = 'HTTP:'):AWSECommerceServicePortType;
Implementation
uses wst_resources_imp, metadata_repository;
Function wst_CreateInstance_AWSECommerceServicePortType(const AFormat : string; const ATransport : string):AWSECommerceServicePortType;
Begin
Result := TAWSECommerceServicePortType_Proxy.Create('AWSECommerceServicePortType',AFormat+GetServiceDefaultFormatProperties(TypeInfo(AWSECommerceServicePortType)),ATransport + 'address=' + GetServiceDefaultAddress(TypeInfo(AWSECommerceServicePortType)));
End;
{ TAWSECommerceServicePortType_Proxy implementation }
class function TAWSECommerceServicePortType_Proxy.GetServiceType() : PTypeInfo;
begin
result := TypeInfo(AWSECommerceServicePortType);
end;
function TAWSECommerceServicePortType_Proxy.Help(
Const HelpParam : Help_Type
):HelpResponse_Type;
Var
locSerializer : IFormatterClient;
strPrmName : string;
Begin
locSerializer := GetSerializer();
Try
locSerializer.BeginCall('Help', GetTarget(),(Self as ICallContext));
locSerializer.Put('Help', TypeInfo(Help_Type), HelpParam);
locSerializer.EndCall();
MakeCall();
locSerializer.BeginCallRead((Self as ICallContext));
TObject(Result) := Nil;
strPrmName := 'HelpResponse';
locSerializer.Get(TypeInfo(HelpResponse_Type), strPrmName, Result);
Finally
locSerializer.Clear();
End;
End;
function TAWSECommerceServicePortType_Proxy.ItemSearch(
Const ItemSearchParam : ItemSearch_Type
):ItemSearchResponse_Type;
Var
locSerializer : IFormatterClient;
strPrmName : string;
Begin
locSerializer := GetSerializer();
Try
locSerializer.BeginCall('ItemSearch', GetTarget(),(Self as ICallContext));
locSerializer.Put('ItemSearch', TypeInfo(ItemSearch_Type), ItemSearchParam);
locSerializer.EndCall();
MakeCall();
locSerializer.BeginCallRead((Self as ICallContext));
TObject(Result) := Nil;
strPrmName := 'ItemSearchResponse';
locSerializer.Get(TypeInfo(ItemSearchResponse_Type), strPrmName, Result);
Finally
locSerializer.Clear();
End;
End;
function TAWSECommerceServicePortType_Proxy.ItemLookup(
Const ItemLookupParam : ItemLookup_Type
):ItemLookupResponse_Type;
Var
locSerializer : IFormatterClient;
strPrmName : string;
Begin
locSerializer := GetSerializer();
Try
locSerializer.BeginCall('ItemLookup', GetTarget(),(Self as ICallContext));
locSerializer.Put('ItemLookup', TypeInfo(ItemLookup_Type), ItemLookupParam);
locSerializer.EndCall();
MakeCall();
locSerializer.BeginCallRead((Self as ICallContext));
TObject(Result) := Nil;
strPrmName := 'ItemLookupResponse';
locSerializer.Get(TypeInfo(ItemLookupResponse_Type), strPrmName, Result);
Finally
locSerializer.Clear();
End;
End;
function TAWSECommerceServicePortType_Proxy.BrowseNodeLookup(
Const BrowseNodeLookupParam : BrowseNodeLookup_Type
):BrowseNodeLookupResponse_Type;
Var
locSerializer : IFormatterClient;
strPrmName : string;
Begin
locSerializer := GetSerializer();
Try
locSerializer.BeginCall('BrowseNodeLookup', GetTarget(),(Self as ICallContext));
locSerializer.Put('BrowseNodeLookup', TypeInfo(BrowseNodeLookup_Type), BrowseNodeLookupParam);
locSerializer.EndCall();
MakeCall();
locSerializer.BeginCallRead((Self as ICallContext));
TObject(Result) := Nil;
strPrmName := 'BrowseNodeLookupResponse';
locSerializer.Get(TypeInfo(BrowseNodeLookupResponse_Type), strPrmName, Result);
Finally
locSerializer.Clear();
End;
End;
function TAWSECommerceServicePortType_Proxy.ListSearch(
Const ListSearchParam : ListSearch_Type
):ListSearchResponse_Type;
Var
locSerializer : IFormatterClient;
strPrmName : string;
Begin
locSerializer := GetSerializer();
Try
locSerializer.BeginCall('ListSearch', GetTarget(),(Self as ICallContext));
locSerializer.Put('ListSearch', TypeInfo(ListSearch_Type), ListSearchParam);
locSerializer.EndCall();
MakeCall();
locSerializer.BeginCallRead((Self as ICallContext));
TObject(Result) := Nil;
strPrmName := 'ListSearchResponse';
locSerializer.Get(TypeInfo(ListSearchResponse_Type), strPrmName, Result);
Finally
locSerializer.Clear();
End;
End;
function TAWSECommerceServicePortType_Proxy.ListLookup(
Const ListLookupParam : ListLookup_Type
):ListLookupResponse_Type;
Var
locSerializer : IFormatterClient;
strPrmName : string;
Begin
locSerializer := GetSerializer();
Try
locSerializer.BeginCall('ListLookup', GetTarget(),(Self as ICallContext));
locSerializer.Put('ListLookup', TypeInfo(ListLookup_Type), ListLookupParam);
locSerializer.EndCall();
MakeCall();
locSerializer.BeginCallRead((Self as ICallContext));
TObject(Result) := Nil;
strPrmName := 'ListLookupResponse';
locSerializer.Get(TypeInfo(ListLookupResponse_Type), strPrmName, Result);
Finally
locSerializer.Clear();
End;
End;
function TAWSECommerceServicePortType_Proxy.CustomerContentSearch(
Const CustomerContentSearchParam : CustomerContentSearch_Type
):CustomerContentSearchResponse_Type;
Var
locSerializer : IFormatterClient;
strPrmName : string;
Begin
locSerializer := GetSerializer();
Try
locSerializer.BeginCall('CustomerContentSearch', GetTarget(),(Self as ICallContext));
locSerializer.Put('CustomerContentSearch', TypeInfo(CustomerContentSearch_Type), CustomerContentSearchParam);
locSerializer.EndCall();
MakeCall();
locSerializer.BeginCallRead((Self as ICallContext));
TObject(Result) := Nil;
strPrmName := 'CustomerContentSearchResponse';
locSerializer.Get(TypeInfo(CustomerContentSearchResponse_Type), strPrmName, Result);
Finally
locSerializer.Clear();
End;
End;
function TAWSECommerceServicePortType_Proxy.CustomerContentLookup(
Const CustomerContentLookupParam : CustomerContentLookup_Type
):CustomerContentLookupResponse_Type;
Var
locSerializer : IFormatterClient;
strPrmName : string;
Begin
locSerializer := GetSerializer();
Try
locSerializer.BeginCall('CustomerContentLookup', GetTarget(),(Self as ICallContext));
locSerializer.Put('CustomerContentLookup', TypeInfo(CustomerContentLookup_Type), CustomerContentLookupParam);
locSerializer.EndCall();
MakeCall();
locSerializer.BeginCallRead((Self as ICallContext));
TObject(Result) := Nil;
strPrmName := 'CustomerContentLookupResponse';
locSerializer.Get(TypeInfo(CustomerContentLookupResponse_Type), strPrmName, Result);
Finally
locSerializer.Clear();
End;
End;
function TAWSECommerceServicePortType_Proxy.SimilarityLookup(
Const SimilarityLookupParam : SimilarityLookup_Type
):SimilarityLookupResponse_Type;
Var
locSerializer : IFormatterClient;
strPrmName : string;
Begin
locSerializer := GetSerializer();
Try
locSerializer.BeginCall('SimilarityLookup', GetTarget(),(Self as ICallContext));
locSerializer.Put('SimilarityLookup', TypeInfo(SimilarityLookup_Type), SimilarityLookupParam);
locSerializer.EndCall();
MakeCall();
locSerializer.BeginCallRead((Self as ICallContext));
TObject(Result) := Nil;
strPrmName := 'SimilarityLookupResponse';
locSerializer.Get(TypeInfo(SimilarityLookupResponse_Type), strPrmName, Result);
Finally
locSerializer.Clear();
End;
End;
function TAWSECommerceServicePortType_Proxy.SellerLookup(
Const SellerLookupParam : SellerLookup_Type
):SellerLookupResponse_Type;
Var
locSerializer : IFormatterClient;
strPrmName : string;
Begin
locSerializer := GetSerializer();
Try
locSerializer.BeginCall('SellerLookup', GetTarget(),(Self as ICallContext));
locSerializer.Put('SellerLookup', TypeInfo(SellerLookup_Type), SellerLookupParam);
locSerializer.EndCall();
MakeCall();
locSerializer.BeginCallRead((Self as ICallContext));
TObject(Result) := Nil;
strPrmName := 'SellerLookupResponse';
locSerializer.Get(TypeInfo(SellerLookupResponse_Type), strPrmName, Result);
Finally
locSerializer.Clear();
End;
End;
function TAWSECommerceServicePortType_Proxy.CartGet(
Const CartGetParam : CartGet_Type
):CartGetResponse_Type;
Var
locSerializer : IFormatterClient;
strPrmName : string;
Begin
locSerializer := GetSerializer();
Try
locSerializer.BeginCall('CartGet', GetTarget(),(Self as ICallContext));
locSerializer.Put('CartGet', TypeInfo(CartGet_Type), CartGetParam);
locSerializer.EndCall();
MakeCall();
locSerializer.BeginCallRead((Self as ICallContext));
TObject(Result) := Nil;
strPrmName := 'CartGetResponse';
locSerializer.Get(TypeInfo(CartGetResponse_Type), strPrmName, Result);
Finally
locSerializer.Clear();
End;
End;
function TAWSECommerceServicePortType_Proxy.CartAdd(
Const CartAddParam : CartAdd_Type
):CartAddResponse_Type;
Var
locSerializer : IFormatterClient;
strPrmName : string;
Begin
locSerializer := GetSerializer();
Try
locSerializer.BeginCall('CartAdd', GetTarget(),(Self as ICallContext));
locSerializer.Put('CartAdd', TypeInfo(CartAdd_Type), CartAddParam);
locSerializer.EndCall();
MakeCall();
locSerializer.BeginCallRead((Self as ICallContext));
TObject(Result) := Nil;
strPrmName := 'CartAddResponse';
locSerializer.Get(TypeInfo(CartAddResponse_Type), strPrmName, Result);
Finally
locSerializer.Clear();
End;
End;
function TAWSECommerceServicePortType_Proxy.CartCreate(
Const CartCreateParam : CartCreate_Type
):CartCreateResponse_Type;
Var
locSerializer : IFormatterClient;
strPrmName : string;
Begin
locSerializer := GetSerializer();
Try
locSerializer.BeginCall('CartCreate', GetTarget(),(Self as ICallContext));
locSerializer.Put('CartCreate', TypeInfo(CartCreate_Type), CartCreateParam);
locSerializer.EndCall();
MakeCall();
locSerializer.BeginCallRead((Self as ICallContext));
TObject(Result) := Nil;
strPrmName := 'CartCreateResponse';
locSerializer.Get(TypeInfo(CartCreateResponse_Type), strPrmName, Result);
Finally
locSerializer.Clear();
End;
End;
function TAWSECommerceServicePortType_Proxy.CartModify(
Const CartModifyParam : CartModify_Type
):CartModifyResponse_Type;
Var
locSerializer : IFormatterClient;
strPrmName : string;
Begin
locSerializer := GetSerializer();
Try
locSerializer.BeginCall('CartModify', GetTarget(),(Self as ICallContext));
locSerializer.Put('CartModify', TypeInfo(CartModify_Type), CartModifyParam);
locSerializer.EndCall();
MakeCall();
locSerializer.BeginCallRead((Self as ICallContext));
TObject(Result) := Nil;
strPrmName := 'CartModifyResponse';
locSerializer.Get(TypeInfo(CartModifyResponse_Type), strPrmName, Result);
Finally
locSerializer.Clear();
End;
End;
function TAWSECommerceServicePortType_Proxy.CartClear(
Const CartClearParam : CartClear_Type
):CartClearResponse_Type;
Var
locSerializer : IFormatterClient;
strPrmName : string;
Begin
locSerializer := GetSerializer();
Try
locSerializer.BeginCall('CartClear', GetTarget(),(Self as ICallContext));
locSerializer.Put('CartClear', TypeInfo(CartClear_Type), CartClearParam);
locSerializer.EndCall();
MakeCall();
locSerializer.BeginCallRead((Self as ICallContext));
TObject(Result) := Nil;
strPrmName := 'CartClearResponse';
locSerializer.Get(TypeInfo(CartClearResponse_Type), strPrmName, Result);
Finally
locSerializer.Clear();
End;
End;
function TAWSECommerceServicePortType_Proxy.TransactionLookup(
Const TransactionLookupParam : TransactionLookup_Type
):TransactionLookupResponse_Type;
Var
locSerializer : IFormatterClient;
strPrmName : string;
Begin
locSerializer := GetSerializer();
Try
locSerializer.BeginCall('TransactionLookup', GetTarget(),(Self as ICallContext));
locSerializer.Put('TransactionLookup', TypeInfo(TransactionLookup_Type), TransactionLookupParam);
locSerializer.EndCall();
MakeCall();
locSerializer.BeginCallRead((Self as ICallContext));
TObject(Result) := Nil;
strPrmName := 'TransactionLookupResponse';
locSerializer.Get(TypeInfo(TransactionLookupResponse_Type), strPrmName, Result);
Finally
locSerializer.Clear();
End;
End;
function TAWSECommerceServicePortType_Proxy.SellerListingSearch(
Const SellerListingSearchParam : SellerListingSearch_Type
):SellerListingSearchResponse_Type;
Var
locSerializer : IFormatterClient;
strPrmName : string;
Begin
locSerializer := GetSerializer();
Try
locSerializer.BeginCall('SellerListingSearch', GetTarget(),(Self as ICallContext));
locSerializer.Put('SellerListingSearch', TypeInfo(SellerListingSearch_Type), SellerListingSearchParam);
locSerializer.EndCall();
MakeCall();
locSerializer.BeginCallRead((Self as ICallContext));
TObject(Result) := Nil;
strPrmName := 'SellerListingSearchResponse';
locSerializer.Get(TypeInfo(SellerListingSearchResponse_Type), strPrmName, Result);
Finally
locSerializer.Clear();
End;
End;
function TAWSECommerceServicePortType_Proxy.SellerListingLookup(
Const SellerListingLookupParam : SellerListingLookup_Type
):SellerListingLookupResponse_Type;
Var
locSerializer : IFormatterClient;
strPrmName : string;
Begin
locSerializer := GetSerializer();
Try
locSerializer.BeginCall('SellerListingLookup', GetTarget(),(Self as ICallContext));
locSerializer.Put('SellerListingLookup', TypeInfo(SellerListingLookup_Type), SellerListingLookupParam);
locSerializer.EndCall();
MakeCall();
locSerializer.BeginCallRead((Self as ICallContext));
TObject(Result) := Nil;
strPrmName := 'SellerListingLookupResponse';
locSerializer.Get(TypeInfo(SellerListingLookupResponse_Type), strPrmName, Result);
Finally
locSerializer.Clear();
End;
End;
function TAWSECommerceServicePortType_Proxy.MultiOperation(
Const MultiOperationParam : MultiOperationType
):MultiOperationResponse;
Var
locSerializer : IFormatterClient;
strPrmName : string;
Begin
locSerializer := GetSerializer();
Try
locSerializer.BeginCall('MultiOperation', GetTarget(),(Self as ICallContext));
locSerializer.Put('MultiOperation', TypeInfo(MultiOperationType), MultiOperationParam);
locSerializer.EndCall();
MakeCall();
locSerializer.BeginCallRead((Self as ICallContext));
TObject(Result) := Nil;
strPrmName := 'MultiOperationResponse';
locSerializer.Get(TypeInfo(MultiOperationResponse), strPrmName, Result);
Finally
locSerializer.Clear();
End;
End;
initialization
{$i AWSECommerceService.wst}
{$IF DECLARED(Register_AWSECommerceService_ServiceMetadata)}
Register_AWSECommerceService_ServiceMetadata();
{$IFEND}
End.

141
wst/tags/0.4/samples/amazon/amazon_sample.lpi Normal file
View File

@ -0,0 +1,141 @@
<?xml version="1.0"?>
<CONFIG>
<ProjectOptions>
<PathDelim Value="/"/>
<Version Value="5"/>
<General>
<Flags>
<MainUnitHasUsesSectionForAllUnits Value="False"/>
<MainUnitHasCreateFormStatements Value="False"/>
<MainUnitHasTitleStatement Value="False"/>
</Flags>
<MainUnit Value="0"/>
<IconPath Value="./"/>
<TargetFileExt Value=".exe"/>
<ActiveEditorIndexAtStart Value="0"/>
</General>
<VersionInfo>
<ProjectVersion Value=""/>
</VersionInfo>
<PublishOptions>
<Version Value="2"/>
<IgnoreBinaries Value="False"/>
<IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/>
<ExcludeFileFilter Value="*.(bak|ppu|ppw|o|so);*~;backup"/>
</PublishOptions>
<RunParams>
<local>
<FormatVersion Value="1"/>
<LaunchingApplication PathPlusParams="/usr/X11R6/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/>
</local>
</RunParams>
<Units Count="6">
<Unit0>
<Filename Value="amazon_sample.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="amazon_sample"/>
<CursorPos X="33" Y="12"/>
<TopLine Value="1"/>
<EditorIndex Value="0"/>
<UsageCount Value="20"/>
<Loaded Value="True"/>
</Unit0>
<Unit1>
<Filename Value="../../synapse_http_protocol.pas"/>
<UnitName Value="synapse_http_protocol"/>
<CursorPos X="9" Y="23"/>
<TopLine Value="2"/>
<EditorIndex Value="4"/>
<UsageCount Value="10"/>
<Loaded Value="True"/>
</Unit1>
<Unit2>
<Filename Value="AWSECommerceService.pas"/>
<UnitName Value="AWSECommerceService"/>
<CursorPos X="1" Y="1"/>
<TopLine Value="1"/>
<EditorIndex Value="2"/>
<UsageCount Value="10"/>
<Loaded Value="True"/>
</Unit2>
<Unit3>
<Filename Value="AWSECommerceService_proxy.pas"/>
<UnitName Value="AWSECommerceService_proxy"/>
<CursorPos X="1" Y="1"/>
<TopLine Value="1"/>
<EditorIndex Value="1"/>
<UsageCount Value="10"/>
<Loaded Value="True"/>
</Unit3>
<Unit4>
<Filename Value="../../../../../lazarus23_213/others_package/synapse/httpsend.pas"/>
<UnitName Value="httpsend"/>
<CursorPos X="27" Y="2"/>
<TopLine Value="1"/>
<UsageCount Value="10"/>
</Unit4>
<Unit5>
<Filename Value="../../base_service_intf.pas"/>
<UnitName Value="base_service_intf"/>
<CursorPos X="1" Y="4148"/>
<TopLine Value="4118"/>
<EditorIndex Value="3"/>
<UsageCount Value="10"/>
<Loaded Value="True"/>
</Unit5>
</Units>
<JumpHistory Count="0" HistoryIndex="-1"/>
</ProjectOptions>
<CompilerOptions>
<Version Value="5"/>
<Target>
<Filename Value="amazon_sample"/>
</Target>
<SearchPaths>
<OtherUnitFiles Value="../../;$(LazarusDir)/others_package/synapse/"/>
<UnitOutputDirectory Value="obj"/>
</SearchPaths>
<CodeGeneration>
<Generate Value="Faster"/>
</CodeGeneration>
<Other>
<CompilerPath Value="$(CompPath)"/>
</Other>
</CompilerOptions>
<Debugging>
<BreakPoints Count="4">
<Item1>
<Source Value="D:/lazarusClean/fpcsrc/rtl/inc/getopts.pp"/>
<Line Value="230"/>
</Item1>
<Item2>
<Source Value="D:/lazarusClean/fpcsrc/rtl/inc/getopts.pp"/>
<Line Value="193"/>
</Item2>
<Item3>
<Source Value="D:/lazarusClean/fpcsrc/rtl/inc/getopts.pp"/>
<Line Value="198"/>
</Item3>
<Item4>
<Source Value="../../ws_helper/wsdl2pas_imp.pas"/>
<Line Value="606"/>
</Item4>
</BreakPoints>
<Watches Count="2">
<Item1>
<Expression Value="locStrFilter"/>
</Item1>
<Item2>
<Expression Value="i"/>
</Item2>
</Watches>
<Exceptions Count="2">
<Item1>
<Name Value="ECodetoolError"/>
</Item1>
<Item2>
<Name Value="EFOpenError"/>
</Item2>
</Exceptions>
</Debugging>
</CONFIG>

97
wst/tags/0.4/samples/amazon/amazon_sample.pas Normal file
View File

@ -0,0 +1,97 @@
program amazon_sample;
{$mode objfpc}{$H+}
uses
Classes, SysUtils,
soap_formatter,
synapse_http_protocol,
metadata_repository,
AWSECommerceService, AWSECommerceService_proxy;
const sACCES_ID = <your key here>;
function ReadEntry(const APromp : string):string ;
begin
Result := '';
Write(APromp);
while True do begin
ReadLn(Result);
Result := Trim(Result);
if ( Length(Result) > 0 ) then
Break;
end;
end;
var
locService : AWSECommerceServicePortType;
rqst : ItemSearch_Type;
rsps : ItemSearchResponse_Type;
rspsItem : Items_Type;
i, j, k : Integer;
itm : Item_Type;
begin
SYNAPSE_RegisterHTTP_Transport();
WriteLn('Web Services Toolkit Amazon sample');
WriteLn('This sample demonstrates the "ItemSearch" method of the Amazon web service');
WriteLn();
rqst := ItemSearch_Type.Create();
try
locService := wst_CreateInstance_AWSECommerceServicePortType();
rqst.AWSAccessKeyId := sACCES_ID;
while True do begin
rqst.Request.SetLength(1);
rqst.Request[0].SearchIndex := ReadEntry('Enter the Search Index : ');
rqst.Request[0].Availability := Available;
rqst.Request[0].Count := 10;
rqst.Request[0].MerchantId := 'Amazon';
rqst.Request[0].ItemPage := 1;
rqst.Request[0].Keywords := ReadEntry('Enter the Keywords : ');
rsps := locService.ItemSearch(rqst);
if ( rsps.OperationRequest.Errors.Length > 0 ) then begin
WriteLn(Format('Errors ( %d ) : ',[rsps.OperationRequest.Errors.Length]));
for i := 0 to Pred(rsps.OperationRequest.Errors.Length) do begin
WriteLn(Format(' Error[%d] :',[i]));
WriteLn(' ' + rsps.OperationRequest.Errors[i].Code);
WriteLn(' ' + rsps.OperationRequest.Errors[i].Message);
end;
end else begin
WriteLn(Format('Response ( %d ) : ',[rsps.Items.Length]));
if Assigned(rsps) then begin
for i := 0 to Pred(rsps.Items.Length) do begin
rspsItem := rsps.Items[i];
WriteLn(' TotalPages :' + IntToStr(rspsItem.TotalPages));
WriteLn(' TotalResults :' + IntToStr(rspsItem.TotalResults));
WriteLn(' Items :' + IntToStr(rspsItem._Item.Length));
WriteLn('');
for j := 0 to Pred(rspsItem._Item.Length) do begin
itm := rspsItem._Item[j];;
WriteLn(' ASIN :' + itm.ASIN);
WriteLn(' DetailPageURL :' + itm.DetailPageURL);
if Assigned(itm.ItemAttributes) then begin
WriteLn(' Title :' + itm.ItemAttributes.Title);
for k := 0 to Pred(itm.ItemAttributes.Author.Length) do begin
WriteLn(' Author[ ' + IntToStr(k) + ' ] ' + itm.ItemAttributes.Author.Item[k]);
end;
WriteLn(' Manufacturer :' + itm.ItemAttributes.Manufacturer);
WriteLn(' ProductGroup :' + itm.ItemAttributes.ProductGroup);
end;
WriteLn('');
end;
end;
end else begin
WriteLn('Unexpected service response : Invalid response');
end;
end;
WriteLn();
WriteLn();
if ( UpperCase(ReadEntry('Continue ( Y/N ) :'))[1] <> 'Y' ) then
Break;
end;
finally
FreeAndNil(rqst);
FreeAndNil(rsps);
end;
ReadLn;
end.

1
wst/tags/0.4/samples/amazon/parseWSDL.bat Normal file
View File

@ -0,0 +1 @@
..\..\ws_helper\ws_helper.exe -uA -p -o. AWSECommerceService.wsdl >parsing.res.txt

7
wst/tags/0.4/samples/apache_module/ReadMe.txt Normal file
View File

@ -0,0 +1,7 @@
Appache module configuration :
LoadModule wst_module modules/mod_wst.so
<Location /wst>
SetHandler wst-handler
</Location>

211
wst/tags/0.4/samples/apache_module/mod_wst.lpi Normal file
View File

@ -0,0 +1,211 @@
<?xml version="1.0"?>
<CONFIG>
<ProjectOptions>
<PathDelim Value="\"/>
<Version Value="5"/>
<General>
<MainUnit Value="0"/>
<IconPath Value="./"/>
<TargetFileExt Value=".exe"/>
<ActiveEditorIndexAtStart Value="0"/>
</General>
<VersionInfo>
<ProjectVersion Value=""/>
</VersionInfo>
<PublishOptions>
<Version Value="2"/>
<IgnoreBinaries Value="False"/>
<IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/>
<ExcludeFileFilter Value="*.(bak|ppu|ppw|o|so);*~;backup"/>
</PublishOptions>
<RunParams>
<local>
<FormatVersion Value="1"/>
<LaunchingApplication PathPlusParams="/usr/X11R6/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/>
</local>
</RunParams>
<Units Count="7">
<Unit0>
<Filename Value="mod_wst.lpr"/>
<IsPartOfProject Value="True"/>
<UnitName Value="mod_wst"/>
<CursorPos X="1" Y="52"/>
<TopLine Value="25"/>
<EditorIndex Value="0"/>
<UsageCount Value="33"/>
<Loaded Value="True"/>
</Unit0>
<Unit1>
<Filename Value="wst_apache_binding.pas"/>
<UnitName Value="wst_apache_binding"/>
<CursorPos X="46" Y="15"/>
<TopLine Value="1"/>
<EditorIndex Value="1"/>
<UsageCount Value="16"/>
<Loaded Value="True"/>
</Unit1>
<Unit2>
<Filename Value="..\..\metadata_wsdl.pas"/>
<UnitName Value="metadata_wsdl"/>
<CursorPos X="70" Y="30"/>
<TopLine Value="16"/>
<EditorIndex Value="2"/>
<UsageCount Value="16"/>
<Loaded Value="True"/>
</Unit2>
<Unit3>
<Filename Value="..\user_service_intf_imp.pas"/>
<UnitName Value="user_service_intf_imp"/>
<CursorPos X="71" Y="20"/>
<TopLine Value="1"/>
<EditorIndex Value="3"/>
<UsageCount Value="16"/>
<Loaded Value="True"/>
</Unit3>
<Unit4>
<Filename Value="..\..\..\..\..\lazarus23_213\fpc\2.1.3\source\packages\base\httpd\httpd-1.3\httpd.pas"/>
<UnitName Value="httpd"/>
<CursorPos X="5" Y="26"/>
<TopLine Value="25"/>
<UsageCount Value="9"/>
</Unit4>
<Unit5>
<Filename Value="..\..\..\..\..\lazarus23_213\fpc\2.1.3\source\packages\base\httpd\httpd-1.3\httpd.inc"/>
<CursorPos X="1" Y="1"/>
<TopLine Value="75"/>
<UsageCount Value="9"/>
</Unit5>
<Unit6>
<Filename Value="..\..\..\..\..\lazarus23_213\fpc\2.1.3\source\packages\base\httpd\httpd-2.2\httpd.pas"/>
<UnitName Value="httpd"/>
<CursorPos X="35" Y="44"/>
<TopLine Value="61"/>
<UsageCount Value="9"/>
</Unit6>
</Units>
<JumpHistory Count="15" HistoryIndex="14">
<Position1>
<Filename Value="mod_wst.lpr"/>
<Caret Line="5" Column="1" TopLine="1"/>
</Position1>
<Position2>
<Filename Value="mod_wst.lpr"/>
<Caret Line="52" Column="5" TopLine="25"/>
</Position2>
<Position3>
<Filename Value="mod_wst.lpr"/>
<Caret Line="18" Column="28" TopLine="1"/>
</Position3>
<Position4>
<Filename Value="wst_apache_binding.pas"/>
<Caret Line="1" Column="1" TopLine="1"/>
</Position4>
<Position5>
<Filename Value="..\..\metadata_wsdl.pas"/>
<Caret Line="1" Column="1" TopLine="1"/>
</Position5>
<Position6>
<Filename Value="..\..\metadata_wsdl.pas"/>
<Caret Line="30" Column="70" TopLine="16"/>
</Position6>
<Position7>
<Filename Value="..\user_service_intf_imp.pas"/>
<Caret Line="1" Column="1" TopLine="1"/>
</Position7>
<Position8>
<Filename Value="wst_apache_binding.pas"/>
<Caret Line="29" Column="68" TopLine="10"/>
</Position8>
<Position9>
<Filename Value="wst_apache_binding.pas"/>
<Caret Line="312" Column="42" TopLine="291"/>
</Position9>
<Position10>
<Filename Value="mod_wst.lpr"/>
<Caret Line="6" Column="22" TopLine="25"/>
</Position10>
<Position11>
<Filename Value="mod_wst.lpr"/>
<Caret Line="52" Column="1" TopLine="25"/>
</Position11>
<Position12>
<Filename Value="mod_wst.lpr"/>
<Caret Line="30" Column="6" TopLine="25"/>
</Position12>
<Position13>
<Filename Value="mod_wst.lpr"/>
<Caret Line="11" Column="7" TopLine="1"/>
</Position13>
<Position14>
<Filename Value="wst_apache_binding.pas"/>
<Caret Line="273" Column="27" TopLine="260"/>
</Position14>
<Position15>
<Filename Value="mod_wst.lpr"/>
<Caret Line="7" Column="1" TopLine="1"/>
</Position15>
</JumpHistory>
</ProjectOptions>
<CompilerOptions>
<Version Value="5"/>
<PathDelim Value="\"/>
<Target>
<Filename Value="mod_wst.so"/>
</Target>
<SearchPaths>
<OtherUnitFiles Value="$(FPCSrcDir)\packages\base\httpd\httpd-2.2\;..\;..\..\;..\..\wst_rtti_filter\"/>
<UnitOutputDirectory Value="obj"/>
</SearchPaths>
<CodeGeneration>
<Generate Value="Faster"/>
</CodeGeneration>
<Linking>
<Options>
<ExecutableType Value="Library"/>
</Options>
</Linking>
<Other>
<CompilerPath Value="$(CompPath)"/>
</Other>
</CompilerOptions>
<Debugging>
<BreakPoints Count="5">
<Item1>
<Source Value="D:\lazarusClean\fpcsrc\rtl\inc\getopts.pp"/>
<Line Value="230"/>
</Item1>
<Item2>
<Source Value="D:\lazarusClean\fpcsrc\rtl\inc\getopts.pp"/>
<Line Value="193"/>
</Item2>
<Item3>
<Source Value="D:\lazarusClean\fpcsrc\rtl\inc\getopts.pp"/>
<Line Value="198"/>
</Item3>
<Item4>
<Source Value="..\..\ws_helper\wsdl2pas_imp.pas"/>
<Line Value="606"/>
</Item4>
<Item5>
<Source Value="..\user_service_intf_imp.pas"/>
<Line Value="176"/>
</Item5>
</BreakPoints>
<Watches Count="2">
<Item1>
<Expression Value="locStrFilter"/>
</Item1>
<Item2>
<Expression Value="i"/>
</Item2>
</Watches>
<Exceptions Count="2">
<Item1>
<Name Value="ECodetoolError"/>
</Item1>
<Item2>
<Name Value="EFOpenError"/>
</Item2>
</Exceptions>
</Debugging>
</CONFIG>

52
wst/tags/0.4/samples/apache_module/mod_wst.lpr Normal file
View File

@ -0,0 +1,52 @@
library mod_wst;
{$mode objfpc}{$H+}
{$IFDEF WIN32}
{$DEFINE WINDOWS}
{$ENDIF}
uses
SysUtils,
httpd, apr, apriconv, aprutil, wst_apache_binding;
var
wst_module: module; {$ifdef Unix} public name 'wst_module'; {$endif}
default_module_ptr: Pmodule;
const
MODULE_NAME = 'mod_wst.so';
{$ifdef WINDOWS}
exports
wst_module name 'wst_module';
{$endif}
function DefaultHandler(r: Prequest_rec): Integer; cdecl;
begin
if not SameText(r^.handler, 'wst-handler') then
begin
Result := DECLINED;
Exit;
end;
Result := wst_RequestHandler(r);
end;
procedure RegisterHooks(p: Papr_pool_t); cdecl;
begin
ap_hook_handler(@DefaultHandler, nil, nil, APR_HOOK_MIDDLE);
end;
begin
default_module_ptr := @wst_module;
FillChar(default_module_ptr^, SizeOf(default_module_ptr^), 0);
STANDARD20_MODULE_STUFF(default_module_ptr^);
with wst_module do
begin
name := MODULE_NAME;
magic := MODULE_MAGIC_COOKIE;
register_hooks := @RegisterHooks;
end;
end.

318
wst/tags/0.4/samples/apache_module/wst_apache_binding.pas Normal file
View File

@ -0,0 +1,318 @@
//{$DEFINE WST_DBG}
unit wst_apache_binding;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils,
httpd, apr, apriconv, aprutil;
const
sWST_ROOT = 'wst';
sSEPARATOR = '/';
sSERVICES_PREFIXE = 'services';
sWSDL = 'WSDL';
sHTTP_BINARY_CONTENT_TYPE = 'application/octet-stream';
sCONTENT_TYPE = 'Content-Type';
function wst_RequestHandler(r: Prequest_rec): Integer;
implementation
uses base_service_intf,
server_service_intf, server_service_imputils,
server_service_soap, server_binary_formatter,
metadata_repository, metadata_wsdl, DOM, XMLWrite,
user_service_intf, user_service_intf_binder, user_service_intf_imp,
metadata_service, metadata_service_binder, metadata_service_imp;
type
TRequestInfo = record
Root : string;
URI : string;
ContentType : string;
Buffer : string;
end;
TResponseInfo = record
ContentText : string;
ContentType : string;
end;
procedure SaveStringToFile(const AStr,AFile:string;const AKeepExisting : Boolean);
begin
with TMemoryStream.Create() do try
if AKeepExisting and FileExists(AFile) then begin
LoadFromFile(AFile);
Position := Size;
end;
if ( Length(AStr) > 0 ) then
Write(AStr[1],Length(AStr));
SaveToFile(AFile);
finally
Free();
end;
end;
function ReadBuffer(r : Prequest_rec; out rbuf : string ) : Integer;
var
argsbuffer : string;
rsize, len_read, rpos : Integer;
loc_length : Integer;
begin
rbuf := '';
Result := ap_setup_client_block(r, REQUEST_CHUNKED_ERROR);
if ( Result <> OK ) then
Exit;
if ( ap_should_client_block(r) <> 0 ) then begin
SetLength(argsbuffer,HUGE_STRING_LEN);
FillChar(argsbuffer[1],Length(argsbuffer),0);
rsize := 0; len_read := 0; rpos := 0;
loc_length := r^.remaining;
SetLength(rbuf, loc_length );
while True do begin
len_read := ap_get_client_block(r, @(argsbuffer[1]), Length(argsbuffer));
if ( len_read <= 0 ) then
Exit;
if ( ( rpos + len_read ) > loc_length ) then
rsize := loc_length - rpos
else
rsize := len_read;
Move(argsbuffer[1],rbuf[ ( 1 + rpos ) ], rsize);
Inc(rpos,rsize);
end;
end;
end;
function ExtractNextPathElement(var AFullPath : string):string;
var
i : SizeInt;
begin
Result := '';
if ( Length(AFullPath) > 0 ) then begin
while ( Length(AFullPath) > 0 ) and ( AFullPath[1] = sSEPARATOR ) do begin
Delete(AFullPath,1,1);
end;
i := Pos(sSEPARATOR,AFullPath);
if ( i < 1 ) then begin
Result := AFullPath;
AFullPath := '';
end else begin
Result := Copy(AFullPath,1,Pred(i));
Delete(AFullPath,1,i);
end;
end;
end;
function GetWSDL(const ARepName, ARootAddress: shortstring):string;
var
strm : TMemoryStream;
rep : PServiceRepository;
doc :TXMLDocument;
i : SizeInt;
s : string;
begin
Result := '';
rep := nil;
doc := Nil;
i := GetModuleMetadataMngr().IndexOfName(ARepName);
if ( i < 0 ) then
Exit;
strm := TMemoryStream.Create();
try
s := GetModuleMetadataMngr().GetRepositoryName(i);
GetModuleMetadataMngr().LoadRepositoryName(s,ARootAddress,rep);
strm.Clear();
doc := TXMLDocument.Create();
GenerateWSDL(rep,doc);
WriteXMLFile(doc,strm);
i := strm.Size;
if ( i > 0 ) then begin
SetLength(Result,i);
Move(strm.memory^,Result[1],i);
end;
finally
doc.Free();
strm.Free();
GetModuleMetadataMngr().ClearRepository(rep);
end;
end;
function GenerateWSDLTable(): string;
var
r : IModuleMetadataMngr;
i : Integer;
begin
r := GetModuleMetadataMngr();
Result := '<html>' +
'<head>'+
'<title>'+
'The Web Service Toolkit generated Metadata table'+
'</title>'+
'<body>' +
'<p BGCOLOR="#DDEEFF"><FONT FACE="Arial" COLOR="#0000A0" SIZE="+2">The following repositories has available. Click on the link to view the corresponding WSDL.</FONT></p>'+
'<table width="100%">';
for i := 0 to Pred(r.GetCount()) do
Result := Result + '<tr>' +
'<td>' +
Format('<a href="%s">',[sSEPARATOR+sWST_ROOT+sSEPARATOR+sSERVICES_PREFIXE+sSEPARATOR+sWSDL+sSEPARATOR+r.GetRepositoryName(i)])+
r.GetRepositoryName(i) +
'</a>'+
'</td>' +
'</tr>';
Result := Result +
'</tr>'+
'</table>'+
'</body>'+
'</head>'+
'</html>';
end;
procedure ProcessWSDLRequest(
const ARequestInfo : TRequestInfo;
out AResponseInfo : TResponseInfo
);
var
locRepName, strBuff, locPath : string;
i : Integer;
begin
FillChar(AResponseInfo,SizeOf(TResponseInfo),#0);
locPath := ARequestInfo.URI;
locRepName := ExtractNextPathElement(locPath);
if AnsiSameText(sWSDL,locRepName) then
locRepName := ExtractNextPathElement(locPath);
strBuff := GetWSDL(locRepName,ARequestInfo.Root);
i := Length(strBuff);
if ( i > 0 ) then begin
AResponseInfo.ContentType := 'text/xml';
AResponseInfo.ContentText := strBuff;
Exit;
end;
AResponseInfo.ContentText := GenerateWSDLTable();
AResponseInfo.ContentType := 'text/html';
end;
function ProcessServiceRequest(
const ARequestInfo : TRequestInfo;
out AResponseInfo : TResponseInfo
):Boolean;
var
trgt,ctntyp, loc_path : string;
rqst : IRequestBuffer;
inStream, outStream: TMemoryStream;
i : Integer;
begin
FillChar(AResponseInfo,SizeOf(TResponseInfo),#0);
loc_path := ARequestInfo.URI;
trgt := ExtractNextPathElement(loc_path);
Result := False;
if AnsiSameText(sWSDL,trgt) then
Exit;
Result := True;
inStream := nil;
outStream := nil;
try
inStream := TMemoryStream.Create();
outStream := TMemoryStream.Create();
ctntyp := ARequestInfo.ContentType;
i := Length(ARequestInfo.Buffer);
if ( i > 0 ) then
inStream.Write(ARequestInfo.Buffer[1],i);
inStream.Position := 0;
if AnsiSameText(sBINARY_CONTENT_TYPE,ctntyp) then
AResponseInfo.ContentType := sHTTP_BINARY_CONTENT_TYPE
else
AResponseInfo.ContentType := ctntyp;
rqst := TRequestBuffer.Create(trgt,ctntyp,inStream,outStream);
HandleServiceRequest(rqst);
i := outStream.Size;
if ( i > 0 ) then begin
SetLength(AResponseInfo.ContentText,i);
Move(outStream.Memory^,AResponseInfo.ContentText[1],i);
end;
finally
outStream.Free();
inStream.Free();
{$IFDEF WST_DBG}
{SaveStringToFile('RequestInfo.ContentType=' + ARequestInfo.ContentType + LineEnding,'E:\Inoussa\Sources\lazarus\wst\v0.3\tests\apache_module\log.log',False);
SaveStringToFile('RequestInfo.Buffer=' + ARequestInfo.Buffer + LineEnding,'E:\Inoussa\Sources\lazarus\wst\v0.3\tests\apache_module\log.log',True);
SaveStringToFile('RequestInfo.URI=' + ARequestInfo.URI + LineEnding,'E:\Inoussa\Sources\lazarus\wst\v0.3\tests\apache_module\log.log',True);
SaveStringToFile('ResponseInfo.ContentType=' + AResponseInfo.ContentType + LineEnding,'E:\Inoussa\Sources\lazarus\wst\v0.3\tests\apache_module\log.log',True);
SaveStringToFile('ResponseInfo.ContentText=' + AResponseInfo.ContentText + LineEnding,'E:\Inoussa\Sources\lazarus\wst\v0.3\tests\apache_module\log.log',True);
}
{$ENDIF}
end;
end;
function wst_RequestHandler(r: Prequest_rec): Integer;
function FillRequestInfo(var ARequestInfo : TRequestInfo):Integer;
begin
ARequestInfo.ContentType := apr_table_get(r^.headers_in,sCONTENT_TYPE);
ARequestInfo.Root := ap_get_server_name(r) + sSEPARATOR + sWST_ROOT + sSEPARATOR;
ARequestInfo.URI := r^.uri;
Result := ReadBuffer(r,ARequestInfo.Buffer);
end;
var
sInputBuffer : string;
iRet, iLen : Integer;
loc_RequestInfo : TRequestInfo;
loc_ResponseInfo : TResponseInfo;
begin
Result := FillRequestInfo(loc_RequestInfo);
if not AnsiSameText(sWST_ROOT,ExtractNextPathElement(loc_RequestInfo.URI)) then
Result := DECLINED;
if ( Result <> OK ) then
Exit;
try
if AnsiSameText(sSERVICES_PREFIXE,ExtractNextPathElement(loc_RequestInfo.URI)) then begin
if not ProcessServiceRequest(loc_RequestInfo,loc_ResponseInfo) then
ProcessWSDLRequest(loc_RequestInfo,loc_ResponseInfo);
end else begin
ProcessWSDLRequest(loc_RequestInfo,loc_ResponseInfo);
end;
ap_set_content_type(r, PCHAR(loc_ResponseInfo.ContentType));
if AnsiSameText(sHTTP_BINARY_CONTENT_TYPE,loc_ResponseInfo.ContentType) then begin
ap_set_content_length(r,Length(loc_ResponseInfo.ContentText));
ap_rwrite(@(loc_ResponseInfo.ContentText[1]),Length(loc_ResponseInfo.ContentText),r);
ap_rflush(r);
end else begin
ap_rputs(PCHAR(loc_ResponseInfo.ContentText), r);
end;
Result := OK;
Exit;
except
on e : Exception do begin
ap_set_content_type(r, 'text/html');
ap_rputs('<HTML><HEAD> <TITLE>Error</TITLE></HEAD>' + LineEnding, r);
ap_rputs('<BODY></BODY></HTML>',r);
ap_rprintf(r, '<BODY><H1>"%s"</H1></BODY></HTML>' + LineEnding, [PCHAR(e.Message)]);
Exit;
end;
end;
end;
initialization
RegisterStdTypes();
Server_service_RegisterBinaryFormat();
Server_service_RegisterSoapFormat();
RegisterUserServiceImplementationFactory();
Server_service_RegisterUserServiceService();
Server_service_RegisterWSTMetadataServiceService();
RegisterWSTMetadataServiceImplementationFactory();
end.

43
wst/tags/0.4/samples/delphi/user_client_console/user_client_console.cfg Normal file
View File

@ -0,0 +1,43 @@
-$A8
-$B-
-$C+
-$D+
-$E-
-$F-
-$G+
-$H+
-$I+
-$J-
-$K-
-$L+
-$M-
-$N+
-$O+
-$P+
-$Q-
-$R-
-$S-
-$T-
-$U-
-$V+
-$W-
-$X+
-$YD
-$Z1
-cg
-AWinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE;
-H+
-W+
-M
-$M16384,1048576
-K$00400000
-N"obj"
-LE"c:\program files\borland\delphi7\Projects\Bpl"
-LN"c:\program files\borland\delphi7\Projects\Bpl"
-U"..\..\;..\..\..\;C:\Program Files\Borland\Delphi7\plate_forme\synapse"
-O"..\..\;..\..\..\;C:\Program Files\Borland\Delphi7\plate_forme\synapse"
-I"..\..\;..\..\..\;C:\Program Files\Borland\Delphi7\plate_forme\synapse"
-R"..\..\;..\..\..\;C:\Program Files\Borland\Delphi7\plate_forme\synapse"
-w-UNSAFE_TYPE
-w-UNSAFE_CODE
-w-UNSAFE_CAST

156
wst/tags/0.4/samples/delphi/user_client_console/user_client_console.dof Normal file
View File

@ -0,0 +1,156 @@
[FileVersion]
Version=7.0
[Compiler]
A=8
B=0
C=1
D=1
E=0
F=0
G=1
H=1
I=1
J=0
K=0
L=1
M=0
N=1
O=1
P=1
Q=0
R=0
S=0
T=0
U=0
V=1
W=0
X=1
Y=1
Z=1
ShowHints=1
ShowWarnings=1
UnitAliases=WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE;
NamespacePrefix=
SymbolDeprecated=1
SymbolLibrary=1
SymbolPlatform=1
UnitLibrary=1
UnitPlatform=1
UnitDeprecated=1
HResultCompat=1
HidingMember=1
HiddenVirtual=1
Garbage=1
BoundsError=1
ZeroNilCompat=1
StringConstTruncated=1
ForLoopVarVarPar=1
TypedConstVarPar=1
AsgToTypedConst=1
CaseLabelRange=1
ForVariable=1
ConstructingAbstract=1
ComparisonFalse=1
ComparisonTrue=1
ComparingSignedUnsigned=1
CombiningSignedUnsigned=1
UnsupportedConstruct=1
FileOpen=1
FileOpenUnitSrc=1
BadGlobalSymbol=1
DuplicateConstructorDestructor=1
InvalidDirective=1
PackageNoLink=1
PackageThreadVar=1
ImplicitImport=1
HPPEMITIgnored=1
NoRetVal=1
UseBeforeDef=1
ForLoopVarUndef=1
UnitNameMismatch=1
NoCFGFileFound=1
MessageDirective=1
ImplicitVariants=1
UnicodeToLocale=1
LocaleToUnicode=1
ImagebaseMultiple=1
SuspiciousTypecast=1
PrivatePropAccessor=1
UnsafeType=0
UnsafeCode=0
UnsafeCast=0
[Linker]
MapFile=0
OutputObjs=0
ConsoleApp=1
DebugInfo=0
RemoteSymbols=0
MinStackSize=16384
MaxStackSize=1048576
ImageBase=4194304
ExeDescription=
[Directories]
OutputDir=
UnitOutputDir=obj
PackageDLLOutputDir=
PackageDCPOutputDir=
SearchPath=..\..\;..\..\..\;C:\Program Files\Borland\Delphi7\plate_forme\synapse
Packages=vcl;rtl;vclx;indy;inet;xmlrtl;vclie;inetdbbde;inetdbxpress;dbrtl;dsnap;dsnapcon;vcldb;soaprtl;VclSmp;dbexpress;dbxcds;inetdb;bdertl;vcldbx;webdsnap;websnap;adortl;ibxpress;teeui;teedb;tee;dss;visualclx;visualdbclx;vclactnband;vclshlctrls;IntrawebDB_50_70;Intraweb_50_70;Rave50CLX;Rave50VCL;dclOfficeXP;FIBDBMidas7;Jcl;JclVcl;JvCoreD7R;JvSystemD7R;JvStdCtrlsD7R;JvAppFrmD7R;JvBandsD7R;JvDBD7R;JvDlgsD7R;JvBDED7R;JvCmpD7R;JvCryptD7R;JvCtrlsD7R;JvCustomD7R;JvDockingD7R;JvDotNetCtrlsD7R;JvEDID7R;JvGlobusD7R;JvHMID7R;JvInterpreterD7R;JvJansD7R;JvManagedThreadsD7R;JvMMD7R;JvNetD7R;JvPageCompsD7R;JvPluginD7R;JvPrintPreviewD7R;JvRuntimeDesignD7R;JvTimeFrameworkD7R;JvUIBD7R;JvValidatorsD7R;JvWizardD7R;JvXPCtrlsD7R;dxForumLibD7;cxLibraryVCLD7;cxPageControlVCLD7;dxBarD7;dxComnD7;dxBarDBNavD7;dxBarExtItemsD7;dxBarExtDBItemsD7;dxsbD7;dxmdsD7;dxdbtrD7;dxtrmdD7;dxorgcD7;dxdborD7;dxEdtrD7;EQTLD7;ECQDBCD7;EQDBTLD7;EQGridD7;dxGrEdD7;dxExELD7;dxELibD7;cxEditorsVCLD7;cxGridVCLD7;dxThemeD7;cxDataD7;cxGridUtilsVCLD7;dxPSCoreD7;dxPsPrVwAdvD7;dxPSLnksD7;dxPSTeeChartD7;dxPSDBTeeChartD7;dxPSdxDBTVLnkD7;dxPSdxOCLnkD7;dxPSdxDBOCLnkD7;dxPScxGridLnkD7;dxPSTLLnkD7;qrpt
Conditionals=
DebugSourceDirs=
UsePackages=0
[Parameters]
RunParams=
HostApplication=
Launcher=
UseLauncher=0
DebugCWD=
[Language]
ActiveLang=
ProjectLang=
RootDir=C:\Program Files\Borland\Delphi7\Bin\
[Version Info]
IncludeVerInfo=0
AutoIncBuild=0
MajorVer=1
MinorVer=0
Release=0
Build=0
Debug=0
PreRelease=0
Special=0
Private=0
DLL=0
Locale=1036
CodePage=1252
[Version Info Keys]
CompanyName=
FileDescription=
FileVersion=1.0.0.0
InternalName=
LegalCopyright=
LegalTrademarks=
OriginalFilename=
ProductName=
ProductVersion=1.0.0.0
Comments=
[Excluded Packages]
C:\Program Files\Developer Express Inc\ExpressPrinting System\Delphi 7\Lib\dxPSdxDBTLLnkD7.bpl=ExpressPrinting System ReportLink for ExpressQuantumDBTreeList by Developer Express Inc.
C:\Program Files\Developer Express Inc\ExpressPrinting System\Delphi 7\Lib\dxPSdxDBGrLnkD7.bpl=ExpressPrinting System ReportLink for ExpressQuantumGrid by Developer Express Inc.
C:\Program Files\Developer Express Inc\ExpressPrinting System\Delphi 7\Lib\dxPSdxInsLnkD7.bpl=ExpressPrinting System ReportLink for ExpressInspector by Developer Express Inc.
C:\Program Files\Developer Express Inc\ExpressPrinting System\Delphi 7\Lib\dxPSdxOILnkD7.bpl=ExpressPrinting System ReportLink for ExpressRTTIInspector by Developer Express Inc.
C:\Program Files\Developer Express Inc\ExpressPrinting System\Delphi 7\Lib\dxPSdxMVLnkD7.bpl=ExpressPrinting System ReportLink for ExpressMasterView by Developer Express Inc.
C:\Program Files\Developer Express Inc\ExpressPrinting System\Delphi 7\Lib\dxPSdxFCLnkD7.bpl=ExpressPrinting System ReportLinks for ExpressFlowChart by Developer Express Inc.
C:\Program Files\Developer Express Inc\ExpressPrinting System\Delphi 7\Lib\dxPScxSSLnkD7.bpl=ExpressPrinting System ReportLink for ExpressSpreadSheet by Developer Express Inc.
[HistoryLists\hlUnitAliases]
Count=1
Item0=WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE;
[HistoryLists\hlSearchPath]
Count=4
Item0=..\..\;..\..\..\;C:\Program Files\Borland\Delphi7\plate_forme\synapse
Item1=..\..\;..\..\..\
Item2=..\..\
Item3=..\
[HistoryLists\hlUnitOutputDirectory]
Count=1
Item0=obj

196
wst/tags/0.4/samples/delphi/user_client_console/user_client_console.dpr Normal file
View File

@ -0,0 +1,196 @@
program user_client_console;
{$APPTYPE CONSOLE}
uses
Classes, SysUtils, TypInfo,
user_service_intf_proxy,
synapse_tcp_protocol, synapse_http_protocol, library_protocol,
binary_formatter,
user_service_intf;
{$INCLUDE wst.inc}
var
UserServiceInst : UserService;
procedure ShowUser(AUser : TUser);
begin
if ( AUser <> nil ) then begin
WriteLn(' Name = ',AUser.UserName);
WriteLn(' Category = ',GetEnumName(TypeInfo(TUserCategory),Ord(AUser.Category)));
WriteLn(' e-Mail = ',AUser.eMail);
WriteLn(' Preferences = ',AUser.Preferences);
end else begin
WriteLn('<Empty User>');
end;
end;
procedure ShowUserArray(AArray : TUserArray);
var
i, c : Integer;
usr : TUser;
begin
if ( AArray <> nil ) then begin
c := AArray.Length;
for i := 0 to Pred(c) do begin
usr := AArray[i];
WriteLn;
WriteLn(Format('User[%d] : ',[(i+1)]));
ShowUser(usr);
end;
end;
end;
procedure HandleShowAll();
var
userArray : TUserArray;
begin
userArray := UserServiceInst.GetList();
try
if ( userArray <> nil ) and ( userArray.Length > 0 ) then begin
ShowUserArray(userArray);
end else begin
WriteLn('Empty Array.');
end;
finally
FreeAndNil(userArray);
end;
end;
procedure HandleAdd();
function ReadItem(const APrompt : string; const ANonNull : Boolean):string ;
begin
Result := '';
Write(APrompt);
ReadLn(Result);
Result := Trim(Result);
if ANonNull and ( Length(Result) = 0 ) then
Raise Exception.Create('Invalid User Name!');
end;
var
usr : TUser;
buff : string;
begin
buff := '';
WriteLn('Adding a user :');
try
usr := TUser.Create();
try
usr.UserName := ReadItem('Enter user name : ',True);
buff := UpperCase(ReadItem('Enter user Category( A : Admin; N : normal ) : ',True));
if ( buff[1] = 'A' ) then
usr.Category:= Admin
else
usr.Category:= Normal;
usr.eMail := ReadItem('Enter user e-mail : ',False);
usr.Preferences := ReadItem('Enter user Preferences : ',False);
UserServiceInst.Add(usr);
finally
FreeAndNil(usr);
end;
except
on e : Exception do begin
WriteLn(e.Message);
end;
end;
end;
procedure HandleFindUser();
var
user : TUser;
buff : string;
begin
Write('Enter User Name : ');
ReadLn(buff);
user := UserServiceInst.Find(buff);
try
ShowUser(user);
finally
FreeAndNil(user);
end;
end;
type TTransportType = ( ttLibrary, ttTCP, ttHTTP );
procedure CreateProxy(const ATransportType :TTransportType);
const ADDRESS_MAP : array[TTransportType] of string = (
'LIB:FileName=..\..\library_server\lib_server.dll;target=UserService',
'TCP:Address=127.0.0.1;Port=1234;target=UserService',
//'http:Address=http://127.0.0.1:8080/wst/services/UserService'
'http:Address=http://127.0.0.1:8000/services/UserService'
);
var
buff : string;
begin
buff := ADDRESS_MAP[ATransportType];
if ( ATransportType = ttLibrary ) then
buff := StringReplace(buff,'\',PathDelim,[rfReplaceAll, rfIgnoreCase]);
UserServiceInst := TUserService_Proxy.Create(
'UserService',
'binary:',
buff
);
end;
function ReadTransportType():TTransportType;
var
buff : string;
begin
WriteLn;
WriteLn('Select a transport protocol : ');
WriteLn(' L : Library, the lib_server project must have been built');
WriteLn(' T : TCP, the tcp_server must have been built');
WriteLn(' H : HTTP, the http_server must have been built');
WriteLn;
Write('Your selection : ');
while True do begin
ReadLn(buff);
buff := UpperCase(Trim(buff));
if ( Length(buff) > 0 ) and ( buff[1] in ['L','T', 'H'] ) then begin
case buff[1] of
'L' : Result := ttLibrary;
'T' : Result := ttTCP;
'H' : Result := ttHTTP;
end;
Break;
end;
end;
end;
var
strBuffer : string;
tt : TTransportType;
begin
SYNAPSE_RegisterTCP_Transport();
SYNAPSE_RegisterHTTP_Transport();
LIB_Register_Transport();
WriteLn('Sample Application using Web Services Toolkit');
CreateProxy(ReadTransportType());
WriteLn('Menu :');
WriteLn(' L : Show the user list');
WriteLn(' A : Add a new user');
WriteLn(' F : Find a new');
WriteLn(' C : Change the communication protocol');
WriteLn(' X : Exit');
WriteLn;
Write('Choose a item : ');
while True do begin
strBuffer := '';
ReadLn(strBuffer);
strBuffer := UpperCase(Trim(strBuffer));
if ( Length(strBuffer) > 0 ) then begin
case strBuffer[1] of
'L' : HandleShowAll();
'A' : HandleAdd();
'F' : HandleFindUser();
'C' : CreateProxy(ReadTransportType());
'X' : Break;
end;
WriteLn;
Write('Choose a item : ');
end;
end;
end.

1
wst/tags/0.4/samples/extract_binder.bat Normal file
View File

@ -0,0 +1 @@
..\..\wst\ws_helper\ws_helper -b -o. "user_service_intf.wsdl" >extract_bind.res.txt

1
wst/tags/0.4/samples/extract_imp.bat Normal file
View File

@ -0,0 +1 @@
..\..\wst\ws_helper\ws_helper -i -o. "user_service_intf.wsdl" >extract_imp.res.txt

1
wst/tags/0.4/samples/extract_intf.bat Normal file
View File

@ -0,0 +1 @@
..\..\wst\ws_helper\ws_helper -uA -p -o. "user_service_intf.wsdl" >extract_intf.res.txt

1
wst/tags/0.4/samples/extract_proxy.bat Normal file
View File

@ -0,0 +1 @@
..\..\wst\ws_helper\ws_helper -p -o. "user_service_intf.wsdl" >extract_proxy.res.txt

309
wst/tags/0.4/samples/http_server/app_object.pas Normal file
View File

@ -0,0 +1,309 @@
{
This file is part of the Web Service Toolkit
Copyright (c) 2006 by Inoussa OUEDRAOGO
This file is provide under modified LGPL licence
( the files COPYING.modifiedLGPL and COPYING.LGPL).
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.
}
unit app_object;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils,
IdCustomHTTPServer,
IdHTTPServer, IdContext, IdSocketHandle;
type
{ TwstWebApplication }
TwstWebApplication = class(TObject)
private
FHTTPServerObject: TIdHTTPServer;
FRootAddress : string;
private
function GenerateWSDLTable():string;
procedure ProcessWSDLRequest(
AContext : TIdContext;
ARequestInfo : TIdHTTPRequestInfo;
AResponseInfo : TIdHTTPResponseInfo;
var APath : string
);
procedure ProcessServiceRequest(
AContext : TIdContext;
ARequestInfo : TIdHTTPRequestInfo;
AResponseInfo : TIdHTTPResponseInfo;
var APath : string
);
private
procedure Handler_CommandGet(
AContext : TIdContext;
ARequestInfo : TIdHTTPRequestInfo;
AResponseInfo : TIdHTTPResponseInfo
);
public
constructor Create();
destructor Destroy(); override;
procedure Display(const AMsg : string);
end;
implementation
uses base_service_intf,
server_service_intf, server_service_imputils,
server_service_soap, server_binary_formatter,
metadata_repository, metadata_wsdl, DOM, XMLWrite,
metadata_service, metadata_service_binder, metadata_service_imp,
user_service_intf, user_service_intf_binder, user_service_intf_imp;
const
sSEPARATOR = '/';
sSERVICES_PREFIXE = 'services';
sWSDL = 'WSDL';
function ExtractNextPathElement(var AFullPath : string):string;
var
i : SizeInt;
begin
Result := '';
if ( Length(AFullPath) > 0 ) then begin
while ( Length(AFullPath) > 0 ) and ( AFullPath[1] = sSEPARATOR ) do begin
Delete(AFullPath,1,1);
end;
i := Pos(sSEPARATOR,AFullPath);
if ( i < 1 ) then begin
Result := AFullPath;
AFullPath := '';
end else begin
Result := Copy(AFullPath,1,Pred(i));
Delete(AFullPath,1,i);
end;
end;
end;
function GetWSDL(const ARepName, ARootAddress: shortstring):string;
var
strm : TMemoryStream;
rep : PServiceRepository;
doc :TXMLDocument;
i : SizeInt;
s : string;
begin
Result := '';
rep := nil;
doc := Nil;
i := GetModuleMetadataMngr().IndexOfName(ARepName);
if ( i < 0 ) then
Exit;
strm := TMemoryStream.Create();
try
s := GetModuleMetadataMngr().GetRepositoryName(i);
GetModuleMetadataMngr().LoadRepositoryName(s,ARootAddress,rep);
//if ( GetModuleMetadataMngr().LoadRepositoryName(s,rep) > 0 ) then
//rep^.namespace := 'urn:wst';
strm.Clear();
doc := TXMLDocument.Create();
GenerateWSDL(rep,doc);
WriteXMLFile(doc,strm);
i := strm.Size;
if ( i > 0 ) then begin
SetLength(Result,i);
Move(strm.memory^,Result[1],i);
end;
finally
doc.Free();
strm.Free();
GetModuleMetadataMngr().ClearRepository(rep);
end;
end;
{ TwstWebApplication }
function TwstWebApplication.GenerateWSDLTable(): string;
var
r : IModuleMetadataMngr;
i : Integer;
begin
r := GetModuleMetadataMngr();
Result := '<html>' +
'<head>'+
'<title>'+
'The Web Service Toolkit generated Metadata table'+
'</title>'+
'<body>' +
'<p BGCOLOR="#DDEEFF"><FONT FACE="Arial" COLOR="#0000A0" SIZE="+2">The following repositories has available. Click on the link to view the corresponding WSDL.</FONT></p>'+
'<table width="100%">' +
'<tr>';
for i := 0 to Pred(r.GetCount()) do
Result := Result + '<td align="center">' +
Format('<a href="%s">',[sSEPARATOR+sSERVICES_PREFIXE+sSEPARATOR+sWSDL+sSEPARATOR+r.GetRepositoryName(i)])+
r.GetRepositoryName(i) +
'</a>'+
'</td>';
Result := Result +
'</tr>'+
'</table>'+
'</body>'+
'</head>'+
'</html>';
end;
procedure TwstWebApplication.ProcessWSDLRequest(
AContext : TIdContext;
ARequestInfo : TIdHTTPRequestInfo;
AResponseInfo : TIdHTTPResponseInfo;
var APath : string
);
var
locRepName, strBuff : string;
i : Integer;
begin
locRepName := ExtractNextPathElement(APath);
if AnsiSameText(sWSDL,locRepName) then
locRepName := ExtractNextPathElement(APath);
strBuff := GetWSDL(locRepName,FRootAddress);
i := Length(strBuff);
if ( i > 0 ) then begin
AResponseInfo.ContentType := 'text/xml';
if not Assigned(AResponseInfo.ContentStream) then
AResponseInfo.ContentStream := TMemoryStream.Create();
AResponseInfo.ContentStream.Write(strBuff[1],i);
Exit;
end;
AResponseInfo.ContentText := GenerateWSDLTable();
AResponseInfo.ContentType := 'text/html';
end;
procedure TwstWebApplication.ProcessServiceRequest(
AContext : TIdContext;
ARequestInfo : TIdHTTPRequestInfo;
AResponseInfo : TIdHTTPResponseInfo;
var APath : string
);
var
trgt,ctntyp : string;
rqst : IRequestBuffer;
inStream: TMemoryStream;
begin
trgt := ExtractNextPathElement(APath);
if AnsiSameText(sWSDL,trgt) then begin
ProcessWSDLRequest(AContext,ARequestInfo,AResponseInfo,APath);
Exit;
end;
inStream := nil;
try
try
inStream := TMemoryStream.Create();
AResponseInfo.ContentStream := TMemoryStream.Create();
ctntyp := ARequestInfo.ContentType;
inStream.CopyFrom(ARequestInfo.PostStream,0);
inStream.Position := 0;
AResponseInfo.ContentType := ctntyp;
rqst := TRequestBuffer.Create(trgt,ctntyp,inStream,AResponseInfo.ContentStream);
HandleServiceRequest(rqst);
finally
inStream.Free();
end;
except
on e : Exception do begin
Display('ProcessData()>> Exception = '+e.Message);
raise;
end;
end;
end;
procedure TwstWebApplication.Handler_CommandGet(
AContext : TIdContext;
ARequestInfo : TIdHTTPRequestInfo;
AResponseInfo : TIdHTTPResponseInfo
);
var
locPath, locPathPart, s : string;
j : SizeInt;
begin
if Assigned(ARequestInfo.PostStream) and ( ARequestInfo.PostStream.Size > 0 ) then begin
j := ARequestInfo.PostStream.Size;
SetLength(s,j);
ARequestInfo.PostStream.Read(s[1],j);
Display('----------- QUERY ----------------------');
Display(s);
end;
locPath := ARequestInfo.Document;
locPathPart := ExtractNextPathElement(locPath);
if AnsiSameText(sSERVICES_PREFIXE,locPathPart) then begin
ProcessServiceRequest(AContext,ARequestInfo,AResponseInfo,locPath);
if Assigned(AResponseInfo.ContentStream) and ( AResponseInfo.ContentStream.Size > 0 ) then begin
j := AResponseInfo.ContentStream.Size;
SetLength(s,j);
AResponseInfo.ContentStream.Position := 0;
AResponseInfo.ContentStream.Read(s[1],j);
Display('--------- RESPONSE ------------------------');
Display(s);
end;
Exit;
end;
ProcessWSDLRequest(AContext,ARequestInfo,AResponseInfo,locPath);
end;
constructor TwstWebApplication.Create();
var
b : TIdSocketHandle;
begin
inherited Create();
FHTTPServerObject := TIdHTTPServer.Create();
b := FHTTPServerObject.Bindings.Add();
b.IP:='127.0.0.1';
b.port:=8000;
FRootAddress := 'http://127.0.0.1:8000/';
FHTTPServerObject.DefaultPort := 25000;
FHTTPServerObject.ServerSoftware := 'Web Service Toolkit Sample WebServer';
FHTTPServerObject.Active := True;
FHTTPServerObject.OnCommandGet := @Handler_CommandGet;
Server_service_RegisterUserServiceService();
RegisterUserServiceImplementationFactory();
end;
destructor TwstWebApplication.Destroy();
begin
FreeAndNil(FHTTPServerObject);
inherited Destroy();
end;
procedure TwstWebApplication.Display(const AMsg: string);
begin
WriteLn(AMsg);
end;
initialization
RegisterStdTypes();
Server_service_RegisterBinaryFormat();
Server_service_RegisterSoapFormat();
Server_service_RegisterUserServiceService();
RegisterUserServiceImplementationFactory();
Register_user_service_intf_ServiceMetadata();
Server_service_RegisterWSTMetadataServiceService();
RegisterWSTMetadataServiceImplementationFactory();
end.

187
wst/tags/0.4/samples/http_server/http_server.lpi Normal file
View File

@ -0,0 +1,187 @@
<?xml version="1.0"?>
<CONFIG>
<ProjectOptions>
<PathDelim Value="\"/>
<Version Value="5"/>
<General>
<Flags>
<MainUnitHasUsesSectionForAllUnits Value="False"/>
<MainUnitHasCreateFormStatements Value="False"/>
<MainUnitHasTitleStatement Value="False"/>
</Flags>
<MainUnit Value="0"/>
<IconPath Value="./"/>
<TargetFileExt Value=".exe"/>
<ActiveEditorIndexAtStart Value="0"/>
</General>
<VersionInfo>
<ProjectVersion Value=""/>
</VersionInfo>
<PublishOptions>
<Version Value="2"/>
<IgnoreBinaries Value="False"/>
<IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/>
<ExcludeFileFilter Value="*.(bak|ppu|ppw|o|so);*~;backup"/>
</PublishOptions>
<RunParams>
<local>
<FormatVersion Value="1"/>
<LaunchingApplication PathPlusParams="/usr/X11R6/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/>
</local>
</RunParams>
<RequiredPackages Count="1">
<Item1>
<PackageName Value="indylaz"/>
</Item1>
</RequiredPackages>
<Units Count="9">
<Unit0>
<Filename Value="http_server.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="http_server"/>
<CursorPos X="12" Y="13"/>
<TopLine Value="1"/>
<EditorIndex Value="0"/>
<UsageCount Value="22"/>
<Loaded Value="True"/>
</Unit0>
<Unit1>
<Filename Value="app_object.pas"/>
<UnitName Value="app_object"/>
<CursorPos X="34" Y="65"/>
<TopLine Value="51"/>
<EditorIndex Value="1"/>
<UsageCount Value="11"/>
<Loaded Value="True"/>
</Unit1>
<Unit2>
<Filename Value="..\..\base_service_intf.pas"/>
<UnitName Value="base_service_intf"/>
<CursorPos X="1" Y="4149"/>
<TopLine Value="4122"/>
<UsageCount Value="10"/>
</Unit2>
<Unit3>
<Filename Value="..\..\metadata_wsdl.pas"/>
<UnitName Value="metadata_wsdl"/>
<CursorPos X="56" Y="308"/>
<TopLine Value="296"/>
<EditorIndex Value="2"/>
<UsageCount Value="11"/>
<Loaded Value="True"/>
</Unit3>
<Unit4>
<Filename Value="..\..\metadata_service_imp.pas"/>
<UnitName Value="metadata_service_imp"/>
<CursorPos X="73" Y="68"/>
<TopLine Value="54"/>
<UsageCount Value="10"/>
</Unit4>
<Unit5>
<Filename Value="..\user_service_intf_imp.pas"/>
<UnitName Value="user_service_intf_imp"/>
<CursorPos X="53" Y="39"/>
<TopLine Value="34"/>
<UsageCount Value="10"/>
</Unit5>
<Unit6>
<Filename Value="..\user_service_intf_binder.pas"/>
<UnitName Value="user_service_intf_binder"/>
<CursorPos X="69" Y="11"/>
<TopLine Value="1"/>
<UsageCount Value="10"/>
</Unit6>
<Unit7>
<Filename Value="..\user_service_intf.pas"/>
<UnitName Value="user_service_intf"/>
<CursorPos X="59" Y="65"/>
<TopLine Value="46"/>
<UsageCount Value="10"/>
</Unit7>
<Unit8>
<Filename Value="..\..\metadata_repository.pas"/>
<UnitName Value="metadata_repository"/>
<CursorPos X="5" Y="45"/>
<TopLine Value="99"/>
<EditorIndex Value="3"/>
<UsageCount Value="11"/>
<Loaded Value="True"/>
</Unit8>
</Units>
<JumpHistory Count="4" HistoryIndex="3">
<Position1>
<Filename Value="http_server.pas"/>
<Caret Line="10" Column="10" TopLine="1"/>
</Position1>
<Position2>
<Filename Value="app_object.pas"/>
<Caret Line="65" Column="34" TopLine="51"/>
</Position2>
<Position3>
<Filename Value="..\..\metadata_wsdl.pas"/>
<Caret Line="324" Column="51" TopLine="296"/>
</Position3>
<Position4>
<Filename Value="http_server.pas"/>
<Caret Line="10" Column="10" TopLine="1"/>
</Position4>
</JumpHistory>
</ProjectOptions>
<CompilerOptions>
<Version Value="5"/>
<PathDelim Value="\"/>
<Target>
<Filename Value="http_server"/>
</Target>
<SearchPaths>
<OtherUnitFiles Value="..\;..\..\;..\..\wst_rtti_filter\"/>
<UnitOutputDirectory Value="obj"/>
</SearchPaths>
<CodeGeneration>
<Generate Value="Faster"/>
</CodeGeneration>
<Other>
<CompilerPath Value="$(CompPath)"/>
</Other>
</CompilerOptions>
<Debugging>
<BreakPoints Count="5">
<Item1>
<Source Value="D:\lazarusClean\fpcsrc\rtl\inc\getopts.pp"/>
<Line Value="230"/>
</Item1>
<Item2>
<Source Value="D:\lazarusClean\fpcsrc\rtl\inc\getopts.pp"/>
<Line Value="193"/>
</Item2>
<Item3>
<Source Value="D:\lazarusClean\fpcsrc\rtl\inc\getopts.pp"/>
<Line Value="198"/>
</Item3>
<Item4>
<Source Value="..\..\ws_helper\wsdl2pas_imp.pas"/>
<Line Value="606"/>
</Item4>
<Item5>
<Source Value="..\user_service_intf_imp.pas"/>
<Line Value="176"/>
</Item5>
</BreakPoints>
<Watches Count="2">
<Item1>
<Expression Value="locStrFilter"/>
</Item1>
<Item2>
<Expression Value="i"/>
</Item2>
</Watches>
<Exceptions Count="2">
<Item1>
<Name Value="ECodetoolError"/>
</Item1>
<Item2>
<Name Value="EFOpenError"/>
</Item2>
</Exceptions>
</Debugging>
</CONFIG>

27
wst/tags/0.4/samples/http_server/http_server.pas Normal file
View File

@ -0,0 +1,27 @@
program http_server;
{$mode objfpc}{$H+}
uses
{$IFDEF UNIX}{$IFDEF UseCThreads}
cthreads,
{$ENDIF}{$ENDIF}
Classes, SysUtils,
app_object, metadata_service, logger_extension;
var
AppObject : TwstWebApplication;
begin
AppObject := TwstWebApplication.Create();
try
WriteLn('"Web Service Toolkit" HTTP Server sample listening at:');
WriteLn('');
WriteLn('http://127.0.0.1:8000/');
WriteLn('');
WriteLn('Press enter to quit.');
ReadLn();
finally
FreeAndNil(AppObject);
end;
end.

77
wst/tags/0.4/samples/imp_helper.pas Normal file
View File

@ -0,0 +1,77 @@
unit imp_helper;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils,
base_service_intf,
base_binary_formatter;
procedure SaveObjectToStream(AObject : TPersistent; AStream : TStream);
procedure LoadObjectFromStream(AObject : TPersistent; AStream : TStream);
procedure SaveObjectToFile(AObject : TPersistent; const AFileName : string);
procedure LoadObjectFromFile(AObject : TPersistent; const AFileName : string);
implementation
uses TypInfo;
procedure SaveObjectToFile(AObject : TPersistent; const AFileName : string);
var
strm : TFileStream;
begin
if FileExists(AFileName) then
DeleteFile(AFileName);
strm := TFileStream.Create(AFileName,fmCreate);
try
SaveObjectToStream(AObject,strm);
finally
strm.Free();
end;
end;
procedure LoadObjectFromFile(AObject : TPersistent; const AFileName : string);
var
strm : TFileStream;
begin
if not FileExists(AFileName) then
raise Exception.CreateFmt('File not found : "%s"',[AFileName]);
strm := TFileStream.Create(AFileName,fmOpenRead);
try
LoadObjectFromStream(AObject,strm);
finally
strm.Free();
end;
end;
procedure SaveObjectToStream(AObject : TPersistent; AStream : TStream);
var
srlzr : IFormatterBase;
begin
srlzr := TBaseBinaryFormatter.Create();
srlzr.BeginObject('root',TypeInfo(TPersistent));
srlzr.Put('object',PTypeInfo(AObject.ClassInfo),AObject);
srlzr.EndScope();
srlzr.SaveToStream(AStream);
end;
procedure LoadObjectFromStream(AObject : TPersistent; AStream : TStream);
var
srlzr : IFormatterBase;
nme : string;
begin
srlzr := TBaseBinaryFormatter.Create();
srlzr.LoadFromStream(AStream);
nme := 'root';
srlzr.BeginObjectRead(nme,TypeInfo(TPersistent));
nme := 'object';
srlzr.Get(PTypeInfo(AObject.ClassInfo),nme,AObject);
srlzr.EndScopeRead();
end;
end.

148
wst/tags/0.4/samples/library_server/lib_server.lpi Normal file
View File

@ -0,0 +1,148 @@
<?xml version="1.0"?>
<CONFIG>
<ProjectOptions>
<PathDelim Value="/"/>
<Version Value="5"/>
<General>
<MainUnit Value="0"/>
<IconPath Value="./"/>
<TargetFileExt Value=".exe"/>
<ActiveEditorIndexAtStart Value="4"/>
</General>
<VersionInfo>
<ProjectVersion Value=""/>
</VersionInfo>
<PublishOptions>
<Version Value="2"/>
<IgnoreBinaries Value="False"/>
<IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/>
<ExcludeFileFilter Value="*.(bak|ppu|ppw|o|so);*~;backup"/>
</PublishOptions>
<RunParams>
<local>
<FormatVersion Value="1"/>
<LaunchingApplication PathPlusParams="/usr/X11R6/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/>
</local>
</RunParams>
<Units Count="6">
<Unit0>
<Filename Value="lib_server.lpr"/>
<IsPartOfProject Value="True"/>
<UnitName Value="lib_server"/>
<CursorPos X="45" Y="35"/>
<TopLine Value="14"/>
<EditorIndex Value="0"/>
<UsageCount Value="20"/>
<Loaded Value="True"/>
</Unit0>
<Unit1>
<Filename Value="../../library_server_intf.pas"/>
<UnitName Value="library_server_intf"/>
<CursorPos X="51" Y="27"/>
<TopLine Value="14"/>
<EditorIndex Value="2"/>
<UsageCount Value="10"/>
<Loaded Value="True"/>
</Unit1>
<Unit2>
<Filename Value="../user_service_intf_imp.pas"/>
<UnitName Value="user_service_intf_imp"/>
<CursorPos X="43" Y="179"/>
<TopLine Value="157"/>
<EditorIndex Value="3"/>
<UsageCount Value="10"/>
<Loaded Value="True"/>
</Unit2>
<Unit3>
<Filename Value="../../wst_rtti_filter/rtti_filters.pas"/>
<UnitName Value="rtti_filters"/>
<CursorPos X="53" Y="43"/>
<TopLine Value="184"/>
<EditorIndex Value="5"/>
<UsageCount Value="10"/>
<Loaded Value="True"/>
</Unit3>
<Unit4>
<Filename Value="../user_service_intf_binder.pas"/>
<UnitName Value="user_service_intf_binder"/>
<CursorPos X="54" Y="32"/>
<TopLine Value="22"/>
<EditorIndex Value="1"/>
<UsageCount Value="10"/>
<Loaded Value="True"/>
</Unit4>
<Unit5>
<Filename Value="../../base_service_intf.pas"/>
<UnitName Value="base_service_intf"/>
<CursorPos X="52" Y="4125"/>
<TopLine Value="4118"/>
<EditorIndex Value="4"/>
<UsageCount Value="10"/>
<Loaded Value="True"/>
</Unit5>
</Units>
<JumpHistory Count="1" HistoryIndex="0">
<Position1>
<Filename Value="../../base_service_intf.pas"/>
<Caret Line="1" Column="1" TopLine="1"/>
</Position1>
</JumpHistory>
</ProjectOptions>
<CompilerOptions>
<Version Value="5"/>
<Target>
<Filename Value="lib_server.dll"/>
</Target>
<SearchPaths>
<OtherUnitFiles Value="../;../../;../../wst_rtti_filter/"/>
<UnitOutputDirectory Value="obj"/>
</SearchPaths>
<CodeGeneration>
<Generate Value="Faster"/>
</CodeGeneration>
<Linking>
<Options>
<ExecutableType Value="Library"/>
</Options>
</Linking>
<Other>
<CompilerPath Value="$(CompPath)"/>
</Other>
</CompilerOptions>
<Debugging>
<BreakPoints Count="4">
<Item1>
<Source Value="D:/lazarusClean/fpcsrc/rtl/inc/getopts.pp"/>
<Line Value="230"/>
</Item1>
<Item2>
<Source Value="D:/lazarusClean/fpcsrc/rtl/inc/getopts.pp"/>
<Line Value="193"/>
</Item2>
<Item3>
<Source Value="D:/lazarusClean/fpcsrc/rtl/inc/getopts.pp"/>
<Line Value="198"/>
</Item3>
<Item4>
<Source Value="../../ws_helper/wsdl2pas_imp.pas"/>
<Line Value="606"/>
</Item4>
</BreakPoints>
<Watches Count="2">
<Item1>
<Expression Value="locStrFilter"/>
</Item1>
<Item2>
<Expression Value="i"/>
</Item2>
</Watches>
<Exceptions Count="2">
<Item1>
<Name Value="ECodetoolError"/>
</Item1>
<Item2>
<Name Value="EFOpenError"/>
</Item2>
</Exceptions>
</Debugging>
</CONFIG>

44
wst/tags/0.4/samples/library_server/lib_server.lpr Normal file
View File

@ -0,0 +1,44 @@
{
This file is part of the Web Service Toolkit
Copyright (c) 2006 by Inoussa OUEDRAOGO
This file is provide under modified LGPL licence
( the files COPYING.modifiedLGPL and COPYING.LGPL).
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.
}
library lib_server;
{$mode objfpc}{$H+}
uses
SysUtils, Classes,
base_service_intf,
server_service_intf,
server_service_soap, server_binary_formatter,
metadata_repository, metadata_wsdl,
metadata_service, metadata_service_binder, metadata_service_imp,
library_base_intf, library_server_intf,
user_service_intf_binder, user_service_intf_imp;
exports
wstHandleRequest name WST_LIB_HANDLER;
begin
RegisterStdTypes();
Server_service_RegisterBinaryFormat();
Server_service_RegisterSoapFormat();
RegisterUserServiceImplementationFactory();
Server_service_RegisterUserServiceService();
Server_service_RegisterWSTMetadataServiceService();
RegisterWSTMetadataServiceImplementationFactory();
end.

81
wst/tags/0.4/samples/logger_extension.pas Normal file
View File

@ -0,0 +1,81 @@
{
This file is part of the Web Service Toolkit
Copyright (c) 2006 by Inoussa OUEDRAOGO
This file is provide under modified LGPL licence
( the files COPYING.modifiedLGPL and COPYING.LGPL).
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.
}
unit logger_extension;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, base_service_intf, server_service_intf;
type
{ TLoggerServiceExtension }
TLoggerServiceExtension = class(TSimpleFactoryItem,IServiceExtension)
private
procedure TraceMessage(const AMsg : string);
protected
procedure ProcessMessage(
const AMessageStage : TMessageStage;
ACallContext : ICallContext;
AMsgData : IInterface
{ The "AMsgData" parameter actual type depends on the message state
on correspond to :
- IRequestBuffer on "msBeforeDeserialize" and "msAfterSerialize"
- IFormatterResponse on "msAfterDeserialize", "msBeforeSerialize"
}
);
end;
implementation
uses TypInfo;
{ TLoggerServiceExtension }
procedure TLoggerServiceExtension.TraceMessage(const AMsg: string);
begin
WriteLn(AMsg);
end;
procedure TLoggerServiceExtension.ProcessMessage(
const AMessageStage: TMessageStage;
ACallContext: ICallContext;
AMsgData: IInterface
);
var
s : string;
rqb : IRequestBuffer;
frmtr : IFormatterResponse;
begin
s := GetEnumName(TypeInfo(TMessageStage),Ord(AMessageStage));
case AMessageStage of
msBeforeDeserialize, msAfterSerialize :
begin
rqb := AMsgData as IRequestBuffer;
s := Format('Called service : "%s"; Processing stage : "%s"',[rqb.GetTargetService(),s]);
end;
msAfterDeserialize, msBeforeSerialize :
begin
frmtr := AMsgData as IFormatterResponse;
s := Format('Called service : "%s"; Target Operation = "%s"; Processing stage : "%s"',[frmtr.GetCallTarget(),frmtr.GetCallProcedureName(),s]);
end;
end;
TraceMessage(s);
end;
initialization
GetServiceExtensionRegistry().Register('TLoggerServiceExtension',TSimpleItemFactory.Create(TLoggerServiceExtension) as IItemFactory);
end.

361
wst/tags/0.4/samples/tcp_server/tcp_server.lpi Normal file
View File

@ -0,0 +1,361 @@
<?xml version="1.0"?>
<CONFIG>
<ProjectOptions>
<PathDelim Value="/"/>
<Version Value="5"/>
<General>
<Flags>
<MainUnitHasUsesSectionForAllUnits Value="False"/>
<MainUnitHasCreateFormStatements Value="False"/>
<MainUnitHasTitleStatement Value="False"/>
</Flags>
<MainUnit Value="0"/>
<IconPath Value="./"/>
<TargetFileExt Value=".exe"/>
<ActiveEditorIndexAtStart Value="2"/>
</General>
<VersionInfo>
<ProjectVersion Value=""/>
</VersionInfo>
<PublishOptions>
<Version Value="2"/>
<IgnoreBinaries Value="False"/>
<IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/>
<ExcludeFileFilter Value="*.(bak|ppu|ppw|o|so);*~;backup"/>
</PublishOptions>
<RunParams>
<local>
<FormatVersion Value="1"/>
<LaunchingApplication PathPlusParams="/usr/X11R6/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/>
</local>
</RunParams>
<Units Count="37">
<Unit0>
<Filename Value="tcp_server.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="tcp_server"/>
<CursorPos X="51" Y="21"/>
<TopLine Value="27"/>
<EditorIndex Value="0"/>
<UsageCount Value="68"/>
<Loaded Value="True"/>
</Unit0>
<Unit1>
<Filename Value="synapse_tcp_server.pas"/>
<UnitName Value="synapse_tcp_server"/>
<CursorPos X="42" Y="211"/>
<TopLine Value="197"/>
<UsageCount Value="65"/>
</Unit1>
<Unit2>
<Filename Value="../../../../../lazarus23_213/fpc/2.1.3/source/rtl/objpas/classes/classesh.inc"/>
<CursorPos X="26" Y="686"/>
<TopLine Value="672"/>
<UsageCount Value="9"/>
</Unit2>
<Unit3>
<Filename Value="../../../../../lazarus23_213/fpc/2.1.3/source/rtl/win/sysosh.inc"/>
<CursorPos X="3" Y="25"/>
<TopLine Value="4"/>
<UsageCount Value="6"/>
</Unit3>
<Unit4>
<Filename Value="../../../../../lazarus23_213/others_package/synapse/blcksock.pas"/>
<UnitName Value="blcksock"/>
<CursorPos X="1" Y="2407"/>
<TopLine Value="2395"/>
<UsageCount Value="9"/>
</Unit4>
<Unit5>
<Filename Value="../../binary_streamer.pas"/>
<UnitName Value="binary_streamer"/>
<CursorPos X="37" Y="13"/>
<TopLine Value="178"/>
<UsageCount Value="8"/>
</Unit5>
<Unit6>
<Filename Value="../../server_service_soap.pas"/>
<UnitName Value="server_service_soap"/>
<CursorPos X="35" Y="29"/>
<TopLine Value="8"/>
<UsageCount Value="22"/>
</Unit6>
<Unit7>
<Filename Value="../../server_binary_formatter.pas"/>
<UnitName Value="server_binary_formatter"/>
<CursorPos X="24" Y="22"/>
<TopLine Value="1"/>
<UsageCount Value="10"/>
</Unit7>
<Unit8>
<Filename Value="../../metadata_service.pas"/>
<UnitName Value="metadata_service"/>
<CursorPos X="96" Y="118"/>
<TopLine Value="103"/>
<UsageCount Value="8"/>
</Unit8>
<Unit9>
<Filename Value="../../metadata_service_imp.pas"/>
<UnitName Value="metadata_service_imp"/>
<CursorPos X="1" Y="39"/>
<TopLine Value="28"/>
<UsageCount Value="8"/>
</Unit9>
<Unit10>
<Filename Value="../../metadata_service_binder.pas"/>
<UnitName Value="metadata_service_binder"/>
<CursorPos X="69" Y="11"/>
<TopLine Value="9"/>
<UsageCount Value="8"/>
</Unit10>
<Unit11>
<Filename Value="../user_service_intf.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="user_service_intf"/>
<CursorPos X="14" Y="48"/>
<TopLine Value="55"/>
<EditorIndex Value="4"/>
<UsageCount Value="68"/>
<Loaded Value="True"/>
</Unit11>
<Unit12>
<Filename Value="../../base_service_intf.pas"/>
<UnitName Value="base_service_intf"/>
<CursorPos X="1" Y="4148"/>
<TopLine Value="4118"/>
<EditorIndex Value="1"/>
<UsageCount Value="24"/>
<Bookmarks Count="1">
<Item0 X="19" Y="545" ID="0"/>
</Bookmarks>
<Loaded Value="True"/>
</Unit12>
<Unit13>
<Filename Value="../../wst_rtti_filter/std_cursors.pas"/>
<UnitName Value="std_cursors"/>
<CursorPos X="1" Y="48"/>
<TopLine Value="36"/>
<EditorIndex Value="6"/>
<UsageCount Value="33"/>
<Loaded Value="True"/>
</Unit13>
<Unit14>
<Filename Value="../../wst_rtti_filter/cursor_intf.pas"/>
<UnitName Value="cursor_intf"/>
<CursorPos X="3" Y="27"/>
<TopLine Value="15"/>
<UsageCount Value="24"/>
</Unit14>
<Unit15>
<Filename Value="../user_service_intf_binder.pas"/>
<UnitName Value="user_service_intf_binder"/>
<CursorPos X="30" Y="7"/>
<TopLine Value="1"/>
<EditorIndex Value="3"/>
<UsageCount Value="34"/>
<Loaded Value="True"/>
</Unit15>
<Unit16>
<Filename Value="../user_service_intf.wst"/>
<CursorPos X="1" Y="1"/>
<TopLine Value="1"/>
<UsageCount Value="8"/>
<SyntaxHighlighter Value="None"/>
</Unit16>
<Unit17>
<Filename Value="../../metadata_repository.pas"/>
<UnitName Value="metadata_repository"/>
<CursorPos X="37" Y="571"/>
<TopLine Value="562"/>
<UsageCount Value="8"/>
</Unit17>
<Unit18>
<Filename Value="../../wst_resources_imp.pas"/>
<UnitName Value="wst_resources_imp"/>
<CursorPos X="15" Y="63"/>
<TopLine Value="45"/>
<UsageCount Value="8"/>
</Unit18>
<Unit19>
<Filename Value="../../../../../lazarus23_213/fpc/2.1.3/source/rtl/inc/except.inc"/>
<CursorPos X="3" Y="95"/>
<TopLine Value="73"/>
<UsageCount Value="6"/>
</Unit19>
<Unit20>
<Filename Value="../../../../../lazarus23_213/fpc/2.1.3/source/rtl/i386/setjump.inc"/>
<CursorPos X="1" Y="36"/>
<TopLine Value="16"/>
<UsageCount Value="6"/>
</Unit20>
<Unit21>
<Filename Value="../../../../../lazarus23_213/fpc/2.1.3/source/rtl/inc/objpas.inc"/>
<CursorPos X="1" Y="76"/>
<TopLine Value="64"/>
<UsageCount Value="6"/>
</Unit21>
<Unit22>
<Filename Value="../../../../../lazarus23_213/fpc/2.1.3/source/rtl/objpas/classes/collect.inc"/>
<CursorPos X="1" Y="264"/>
<TopLine Value="252"/>
<UsageCount Value="6"/>
</Unit22>
<Unit23>
<Filename Value="../../../../../lazarus23_213/fpc/2.1.3/source/rtl/objpas/classes/lists.inc"/>
<CursorPos X="1" Y="381"/>
<TopLine Value="369"/>
<UsageCount Value="6"/>
</Unit23>
<Unit24>
<Filename Value="../../../../../lazarus23_213/fpc/2.1.3/source/rtl/inc/system.inc"/>
<CursorPos X="1" Y="674"/>
<TopLine Value="662"/>
<UsageCount Value="6"/>
</Unit24>
<Unit25>
<Filename Value="../../server_service_intf.pas"/>
<UnitName Value="server_service_intf"/>
<CursorPos X="16" Y="346"/>
<TopLine Value="323"/>
<UsageCount Value="8"/>
</Unit25>
<Unit26>
<Filename Value="../../../../../lazarus23_213/fpc/2.1.3/source/rtl/i386/i386.inc"/>
<CursorPos X="1" Y="1125"/>
<TopLine Value="1113"/>
<UsageCount Value="6"/>
</Unit26>
<Unit27>
<Filename Value="../user_service_intf_imp.pas"/>
<UnitName Value="user_service_intf_imp"/>
<CursorPos X="25" Y="13"/>
<TopLine Value="1"/>
<EditorIndex Value="5"/>
<UsageCount Value="34"/>
<Loaded Value="True"/>
</Unit27>
<Unit28>
<Filename Value="../../service_intf.pas"/>
<UnitName Value="service_intf"/>
<CursorPos X="15" Y="23"/>
<TopLine Value="19"/>
<UsageCount Value="7"/>
</Unit28>
<Unit29>
<Filename Value="../../base_soap_formatter.pas"/>
<UnitName Value="base_soap_formatter"/>
<CursorPos X="65" Y="313"/>
<TopLine Value="304"/>
<UsageCount Value="9"/>
</Unit29>
<Unit30>
<Filename Value="../../../../../lazarus23_213/fpc/2.1.3/source/rtl/objpas/typinfo.pp"/>
<UnitName Value="typinfo"/>
<CursorPos X="11" Y="247"/>
<TopLine Value="226"/>
<UsageCount Value="8"/>
</Unit30>
<Unit31>
<Filename Value="../../base_binary_formatter.pas"/>
<UnitName Value="base_binary_formatter"/>
<CursorPos X="3" Y="1063"/>
<TopLine Value="1055"/>
<UsageCount Value="10"/>
</Unit31>
<Unit32>
<Filename Value="imp_helper.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="imp_helper"/>
<CursorPos X="1" Y="44"/>
<TopLine Value="32"/>
<UsageCount Value="37"/>
</Unit32>
<Unit33>
<Filename Value="../../../../../lazarus23_213/fpc/2.1.3/source/rtl/objpas/classes/persist.inc"/>
<CursorPos X="3" Y="36"/>
<TopLine Value="32"/>
<UsageCount Value="9"/>
</Unit33>
<Unit34>
<Filename Value="../../../../../lazarus23_213/fpc/2.1.3/source/rtl/objpas/classes/streams.inc"/>
<CursorPos X="43" Y="511"/>
<TopLine Value="506"/>
<UsageCount Value="9"/>
</Unit34>
<Unit35>
<Filename Value="../../../../../lazarus23_213/fpc/2.1.3/source/rtl/win/sysutils.pp"/>
<UnitName Value="sysutils"/>
<CursorPos X="1" Y="326"/>
<TopLine Value="314"/>
<UsageCount Value="9"/>
</Unit35>
<Unit36>
<Filename Value="../../synapse_tcp_server.pas"/>
<UnitName Value="synapse_tcp_server"/>
<CursorPos X="34" Y="240"/>
<TopLine Value="231"/>
<EditorIndex Value="2"/>
<UsageCount Value="12"/>
<Loaded Value="True"/>
</Unit36>
</Units>
<JumpHistory Count="0" HistoryIndex="-1"/>
</ProjectOptions>
<CompilerOptions>
<Version Value="5"/>
<Target>
<Filename Value="tcp_server.exe"/>
</Target>
<SearchPaths>
<IncludeFiles Value="../../"/>
<OtherUnitFiles Value="../;../../;../../wst_rtti_filter/;$(LazarusDir)/others_package/synapse/"/>
<UnitOutputDirectory Value="obj"/>
</SearchPaths>
<CodeGeneration>
<Generate Value="Faster"/>
</CodeGeneration>
<Other>
<CompilerPath Value="$(CompPath)"/>
</Other>
</CompilerOptions>
<Debugging>
<BreakPoints Count="5">
<Item1>
<Source Value="D:/lazarusClean/fpcsrc/rtl/inc/getopts.pp"/>
<Line Value="230"/>
</Item1>
<Item2>
<Source Value="D:/lazarusClean/fpcsrc/rtl/inc/getopts.pp"/>
<Line Value="193"/>
</Item2>
<Item3>
<Source Value="D:/lazarusClean/fpcsrc/rtl/inc/getopts.pp"/>
<Line Value="198"/>
</Item3>
<Item4>
<Source Value="../../ws_helper/wsdl2pas_imp.pas"/>
<Line Value="606"/>
</Item4>
<Item5>
<Source Value="../user_service_intf_imp.pas"/>
<Line Value="176"/>
</Item5>
</BreakPoints>
<Watches Count="2">
<Item1>
<Expression Value="locStrFilter"/>
</Item1>
<Item2>
<Expression Value="i"/>
</Item2>
</Watches>
<Exceptions Count="2">
<Item1>
<Name Value="ECodetoolError"/>
</Item1>
<Item2>
<Name Value="EFOpenError"/>
</Item2>
</Exceptions>
</Debugging>
</CONFIG>

53
wst/tags/0.4/samples/tcp_server/tcp_server.pas Normal file
View File

@ -0,0 +1,53 @@
{
This file is part of the Web Service Toolkit
Copyright (c) 2006 by Inoussa OUEDRAOGO
This file is provide under modified LGPL licence
( the files COPYING.modifiedLGPL and COPYING.LGPL).
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 tcp_server;
{$INCLUDE wst.inc}
uses
{$IFDEF FPC}
{$IFDEF UNIX}
{$DEFINE UseCThreads}
{$ENDIF}
{$IFDEF UNIX}{$IFDEF UseCThreads}
cthreads,
{$ENDIF}{$ENDIF}
{$ENDIF}
Classes, SysUtils,
base_service_intf, server_service_soap,
base_binary_formatter, server_binary_formatter,
metadata_service, metadata_service_imp, metadata_service_binder,
synapse_tcp_server,
user_service_intf, user_service_intf_binder, user_service_intf_imp , imp_helper;
var
listnerThread : TServerListnerThread;
begin
SetLogger(TConsoleLogger.Create());
Server_service_RegisterBinaryFormat();
Server_service_RegisterSoapFormat();
Server_service_RegisterWSTMetadataServiceService();
RegisterWSTMetadataServiceImplementationFactory();
Server_service_RegisterUserServiceService();
RegisterUserServiceImplementationFactory();
Logger().Log('WST sample TCP Server listning on "%s"',[sSERVER_PORT]);
Logger().Log('Hit <enter> to stop.');
listnerThread := TServerListnerThread.Create();
ReadLn;
end.

124
wst/tags/0.4/samples/user_client/umain.lfm Normal file
View File

@ -0,0 +1,124 @@
object fMain: TfMain
Left = 379
Height = 382
Top = 283
Width = 651
HorzScrollBar.Page = 650
VertScrollBar.Page = 381
ActiveControl = Grid
Caption = 'fMain'
ClientHeight = 382
ClientWidth = 651
Position = poMainFormCenter
object Panel1: TPanel
Height = 182
Top = 200
Width = 651
Align = alClient
BevelInner = bvLowered
Caption = 'Panel1'
ClientHeight = 182
ClientWidth = 651
TabOrder = 0
object Grid: TTIGrid
Left = 2
Height = 178
Top = 2
Width = 647
Align = alClient
AutoFillColumns = True
BorderSpacing.CellAlignHorizontal = ccaRightBottom
BorderStyle = bsNone
Filter = [tkInteger, tkChar, tkEnumeration, tkFloat, tkSString, tkLString, tkAString, tkWString, tkVariant, tkWChar, tkBool, tkInt64, tkQWord]
FixedColor = clBtnFace
Flat = True
OnGetObject = GridGetObject
OnGetObjectCount = GridGetObjectCount
OnGetObjectName = GridGetObjectName
Options = [goFixedVertLine, goFixedHorzLine, goVertLine, goHorzLine, goRangeSelect, goDrawFocusSelected, goColSizing, goRowMoving, goColMoving, goColSpanning, goDblClickAutoSize, goFixedRowNumbering, goScrollKeepVisible]
ParentColor = False
PropertyOrder.Strings = (
'Name'
'Category'
'Preferences'
'eMail'
)
TabOrder = 0
TabStop = True
end
end
object GroupBox1: TGroupBox
Height = 200
Width = 651
Align = alTop
ClientHeight = 178
ClientWidth = 647
TabOrder = 1
object btnSearch: TButton
Left = 500
Height = 35
Top = -1
Width = 131
Action = actSearch
Anchors = [akTop, akRight]
BorderSpacing.InnerBorder = 4
TabOrder = 0
end
object btnAdd: TButton
Left = 500
Height = 35
Top = 42
Width = 131
Action = actNew
Anchors = [akTop, akRight]
BorderSpacing.InnerBorder = 4
TabOrder = 1
end
object btnAdd1: TButton
Left = 500
Height = 35
Top = 87
Width = 131
Action = actUpdate
Anchors = [akTop, akRight]
BorderSpacing.InnerBorder = 4
TabOrder = 2
end
object btnAdd2: TButton
Left = 500
Height = 35
Top = 132
Width = 131
Action = actDelete
Anchors = [akTop, akRight]
BorderSpacing.InnerBorder = 4
TabOrder = 3
end
end
object AL: TActionList
left = 99
top = 56
object actNew: TAction
Caption = 'Create User'
DisableIfNoHandler = True
OnExecute = actNewExecute
end
object actUpdate: TAction
Caption = 'Update User'
DisableIfNoHandler = True
OnExecute = actUpdateExecute
OnUpdate = actUpdateUpdate
end
object actDelete: TAction
Caption = 'Delete'
DisableIfNoHandler = True
OnExecute = actDeleteExecute
OnUpdate = actUpdateUpdate
end
object actSearch: TAction
Caption = 'Get List'
DisableIfNoHandler = True
OnExecute = actSearchExecute
end
end
end

44
wst/tags/0.4/samples/user_client/umain.lrs Normal file
View File

@ -0,0 +1,44 @@
{ Ceci est un fichier ressource g�n�r� automatiquement par Lazarus }
LazarusResources.Add('TfMain','FORMDATA',[
'TPF0'#6'TfMain'#5'fMain'#4'Left'#3'{'#1#6'Height'#3'~'#1#3'Top'#3#27#1#5'Wid'
+'th'#3#139#2#18'HorzScrollBar.Page'#3#138#2#18'VertScrollBar.Page'#3'}'#1#13
+'ActiveControl'#7#4'Grid'#7'Caption'#6#5'fMain'#12'ClientHeight'#3'~'#1#11'C'
+'lientWidth'#3#139#2#8'Position'#7#16'poMainFormCenter'#0#6'TPanel'#6'Panel1'
+#6'Height'#3#182#0#3'Top'#3#200#0#5'Width'#3#139#2#5'Align'#7#8'alClient'#10
+'BevelInner'#7#9'bvLowered'#7'Caption'#6#6'Panel1'#12'ClientHeight'#3#182#0
+#11'ClientWidth'#3#139#2#8'TabOrder'#2#0#0#7'TTIGrid'#4'Grid'#4'Left'#2#2#6
+'Height'#3#178#0#3'Top'#2#2#5'Width'#3#135#2#5'Align'#7#8'alClient'#15'AutoF'
+'illColumns'#9'!BorderSpacing.CellAlignHorizontal'#7#14'ccaRightBottom'#11'B'
+'orderStyle'#7#6'bsNone'#6'Filter'#11#9'tkInteger'#6'tkChar'#13'tkEnumeratio'
+'n'#7'tkFloat'#9'tkSString'#9'tkLString'#9'tkAString'#9'tkWString'#9'tkVaria'
+'nt'#7'tkWChar'#6'tkBool'#7'tkInt64'#7'tkQWord'#0#10'FixedColor'#7#9'clBtnFa'
+'ce'#4'Flat'#9#11'OnGetObject'#7#13'GridGetObject'#16'OnGetObjectCount'#7#18
+'GridGetObjectCount'#15'OnGetObjectName'#7#17'GridGetObjectName'#7'Options'
+#11#15'goFixedVertLine'#15'goFixedHorzLine'#10'goVertLine'#10'goHorzLine'#13
+'goRangeSelect'#19'goDrawFocusSelected'#11'goColSizing'#11'goRowMoving'#11'g'
+'oColMoving'#13'goColSpanning'#18'goDblClickAutoSize'#19'goFixedRowNumbering'
+#19'goScrollKeepVisible'#0#11'ParentColor'#8#21'PropertyOrder.Strings'#1#6#4
+'Name'#6#8'Category'#6#11'Preferences'#6#5'eMail'#0#8'TabOrder'#2#0#7'TabSto'
+'p'#9#0#0#0#9'TGroupBox'#9'GroupBox1'#6'Height'#3#200#0#5'Width'#3#139#2#5'A'
+'lign'#7#5'alTop'#12'ClientHeight'#3#178#0#11'ClientWidth'#3#135#2#8'TabOrde'
+'r'#2#1#0#7'TButton'#9'btnSearch'#4'Left'#3#244#1#6'Height'#2'#'#3'Top'#2#255
+#5'Width'#3#131#0#6'Action'#7#9'actSearch'#7'Anchors'#11#5'akTop'#7'akRight'
+#0#25'BorderSpacing.InnerBorder'#2#4#8'TabOrder'#2#0#0#0#7'TButton'#6'btnAdd'
+#4'Left'#3#244#1#6'Height'#2'#'#3'Top'#2'*'#5'Width'#3#131#0#6'Action'#7#6'a'
+'ctNew'#7'Anchors'#11#5'akTop'#7'akRight'#0#25'BorderSpacing.InnerBorder'#2#4
+#8'TabOrder'#2#1#0#0#7'TButton'#7'btnAdd1'#4'Left'#3#244#1#6'Height'#2'#'#3
+'Top'#2'W'#5'Width'#3#131#0#6'Action'#7#9'actUpdate'#7'Anchors'#11#5'akTop'#7
+'akRight'#0#25'BorderSpacing.InnerBorder'#2#4#8'TabOrder'#2#2#0#0#7'TButton'
+#7'btnAdd2'#4'Left'#3#244#1#6'Height'#2'#'#3'Top'#3#132#0#5'Width'#3#131#0#6
+'Action'#7#9'actDelete'#7'Anchors'#11#5'akTop'#7'akRight'#0#25'BorderSpacing'
+'.InnerBorder'#2#4#8'TabOrder'#2#3#0#0#0#11'TActionList'#2'AL'#4'left'#2'c'#3
+'top'#2'8'#0#7'TAction'#6'actNew'#7'Caption'#6#11'Create User'#18'DisableIfN'
+'oHandler'#9#9'OnExecute'#7#13'actNewExecute'#0#0#7'TAction'#9'actUpdate'#7
+'Caption'#6#11'Update User'#18'DisableIfNoHandler'#9#9'OnExecute'#7#16'actUp'
+'dateExecute'#8'OnUpdate'#7#15'actUpdateUpdate'#0#0#7'TAction'#9'actDelete'#7
+'Caption'#6#6'Delete'#18'DisableIfNoHandler'#9#9'OnExecute'#7#16'actDeleteEx'
+'ecute'#8'OnUpdate'#7#15'actUpdateUpdate'#0#0#7'TAction'#9'actSearch'#7'Capt'
+'ion'#6#8'Get List'#18'DisableIfNoHandler'#9#9'OnExecute'#7#16'actSearchExec'
+'ute'#0#0#0#0
]);

169
wst/tags/0.4/samples/user_client/umain.pas Normal file
View File

@ -0,0 +1,169 @@
unit umain;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, RTTIGrids,
ExtCtrls, StdCtrls, user_service_intf, Buttons, ActnList;
type
{ TfMain }
TfMain = class(TForm)
actDelete: TAction;
actSearch: TAction;
actUpdate: TAction;
actNew: TAction;
AL: TActionList;
btnAdd1: TButton;
btnAdd2: TButton;
btnSearch: TButton;
btnAdd: TButton;
GroupBox1: TGroupBox;
Panel1: TPanel;
Grid: TTIGrid;
procedure actDeleteExecute(Sender: TObject);
procedure actNewExecute(Sender: TObject);
procedure actSearchExecute(Sender: TObject);
procedure actUpdateExecute(Sender: TObject);
procedure actUpdateUpdate(Sender: TObject);
procedure GridGetObject(Sender: TTICustomGrid; Index: integer;
var TIObject: TPersistent);
procedure GridGetObjectCount(Sender: TTICustomGrid; ListObject: TObject;
var ObjCount: integer);
procedure GridGetObjectName(Sender: TObject; Index: integer;
TIObject: TPersistent; var ObjName: string);
private
FUserService : UserService;
function CreateObj():UserService;
function GetObjectIndex() : Integer;
public
FUsers : TUserArray;
end;
var
fMain: TfMain;
implementation
uses user_service_intf_proxy, synapse_tcp_protocol, synapse_http_protocol,
soap_formatter, binary_formatter, user_edit_imp ;
{ TfMain }
procedure TfMain.GridGetObjectCount(Sender: TTICustomGrid;
ListObject: TObject; var ObjCount: integer);
begin
if ( FUsers = nil ) then
ObjCount := 0
else
ObjCount := FUsers.Length;
end;
procedure TfMain.GridGetObjectName(Sender: TObject; Index: integer;
TIObject: TPersistent; var ObjName: string);
begin
if ( TIObject <> nil ) then
ObjName := (TIObject as TUser).UserName;
end;
function TfMain.CreateObj(): UserService;
begin
if ( FUserService = nil ) then begin
FUserService := TUserService_Proxy.Create(
'UserService',
'binary:',
'TCP:Address=127.0.0.1;Port=1234;target=UserService'
);
end;
Result := FUserService;
end;
type TCrakGrid = class(TTIGrid);
function TfMain.GetObjectIndex(): Integer;
begin
Result := TCrakGrid(Grid).Row - 1;
end;
procedure TfMain.GridGetObject(Sender: TTICustomGrid; Index: integer;
var TIObject: TPersistent);
begin
TIObject := FUsers[Index];
end;
procedure TfMain.actNewExecute(Sender: TObject);
var
obj : TUser;
f : TfUserEdit;
begin
obj := nil;
f := TfUserEdit.Create(Application);
try
obj := TUser.Create();
if f.UpdateObject(obj) then begin
CreateObj().Add(obj);
end;
finally
FreeAndNil(obj);
f.Release();
actSearch.Execute();
end;
end;
procedure TfMain.actSearchExecute(Sender: TObject);
begin
FreeAndNil(FUsers);
FUsers := CreateObj().GetList();
Grid.ListObject := FUsers;
Grid.Invalidate();
end;
procedure TfMain.actDeleteExecute(Sender: TObject);
var
i : Integer;
begin
i := GetObjectIndex();
if ( i >= 0 ) then begin
try
CreateObj().Delete(FUsers[i].UserName);
finally
actSearch.Execute();
end;
end;
end;
procedure TfMain.actUpdateExecute(Sender: TObject);
var
i : Integer;
obj : TUser;
f : TfUserEdit;
begin
i := GetObjectIndex();
if ( i >= 0 ) then begin
obj := FUsers[i];
f := TfUserEdit.Create(Application);
try
if f.UpdateObject(obj) then begin
CreateObj().Update(obj);
end;
finally
f.Release();
actSearch.Execute();
end;
end;
end;
procedure TfMain.actUpdateUpdate(Sender: TObject);
begin
TAction(Sender).Enabled := ( GetObjectIndex() >= 0 );
end;
initialization
{$I umain.lrs}
SYNAPSE_RegisterTCP_Transport();
SYNAPSE_RegisterHTTP_Transport();
end.

362
wst/tags/0.4/samples/user_client/user_client.lpi Normal file
View File

@ -0,0 +1,362 @@
<?xml version="1.0"?>
<CONFIG>
<ProjectOptions>
<PathDelim Value="\"/>
<Version Value="5"/>
<General>
<MainUnit Value="0"/>
<IconPath Value="./"/>
<TargetFileExt Value=".exe"/>
<ActiveEditorIndexAtStart Value="7"/>
</General>
<VersionInfo>
<ProjectVersion Value=""/>
</VersionInfo>
<PublishOptions>
<Version Value="2"/>
<IgnoreBinaries Value="False"/>
<IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/>
<ExcludeFileFilter Value="*.(bak|ppu|ppw|o|so);*~;backup"/>
</PublishOptions>
<RunParams>
<local>
<FormatVersion Value="1"/>
<LaunchingApplication PathPlusParams="/usr/X11R6/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/>
</local>
</RunParams>
<RequiredPackages Count="2">
<Item1>
<PackageName Value="RunTimeTypeInfoControls"/>
<MinVersion Minor="1" Valid="True"/>
</Item1>
<Item2>
<PackageName Value="LCL"/>
</Item2>
</RequiredPackages>
<Units Count="21">
<Unit0>
<Filename Value="user_client.lpr"/>
<IsPartOfProject Value="True"/>
<UnitName Value="user_client"/>
<CursorPos X="9" Y="9"/>
<TopLine Value="1"/>
<UsageCount Value="44"/>
</Unit0>
<Unit1>
<Filename Value="umain.pas"/>
<ComponentName Value="fMain"/>
<IsPartOfProject Value="True"/>
<ResourceFilename Value="umain.lrs"/>
<UnitName Value="umain"/>
<CursorPos X="44" Y="130"/>
<TopLine Value="116"/>
<EditorIndex Value="0"/>
<UsageCount Value="44"/>
<Loaded Value="True"/>
</Unit1>
<Unit2>
<Filename Value="..\user_service_intf.pas"/>
<UnitName Value="user_service_intf"/>
<CursorPos X="64" Y="30"/>
<TopLine Value="25"/>
<EditorIndex Value="6"/>
<UsageCount Value="23"/>
<Loaded Value="True"/>
</Unit2>
<Unit3>
<Filename Value="..\user_service_intf_proxy.pas"/>
<UnitName Value="user_service_intf_proxy"/>
<CursorPos X="24" Y="21"/>
<TopLine Value="13"/>
<EditorIndex Value="5"/>
<UsageCount Value="23"/>
<Loaded Value="True"/>
</Unit3>
<Unit4>
<Filename Value="..\..\synapse_tcp_protocol.pas"/>
<UnitName Value="synapse_tcp_protocol"/>
<CursorPos X="58" Y="28"/>
<TopLine Value="23"/>
<EditorIndex Value="4"/>
<UsageCount Value="23"/>
<Loaded Value="True"/>
</Unit4>
<Unit5>
<Filename Value="..\..\base_service_intf.pas"/>
<UnitName Value="base_service_intf"/>
<CursorPos X="1" Y="3316"/>
<TopLine Value="1"/>
<EditorIndex Value="2"/>
<UsageCount Value="23"/>
<Loaded Value="True"/>
</Unit5>
<Unit6>
<Filename Value="..\..\..\..\..\lazarus23_213\components\rtticontrols\rttigrids.pas"/>
<UnitName Value="RTTIGrids"/>
<CursorPos X="13" Y="680"/>
<TopLine Value="663"/>
<UsageCount Value="12"/>
</Unit6>
<Unit7>
<Filename Value="..\..\..\..\..\lazarus23_213\lcl\grids.pas"/>
<UnitName Value="Grids"/>
<CursorPos X="14" Y="829"/>
<TopLine Value="494"/>
<UsageCount Value="12"/>
</Unit7>
<Unit8>
<Filename Value="..\..\..\..\..\lazarus23_213\fpc\2.1.3\source\rtl\win32\classes.pp"/>
<UnitName Value="Classes"/>
<CursorPos X="7" Y="29"/>
<TopLine Value="19"/>
<UsageCount Value="9"/>
</Unit8>
<Unit9>
<Filename Value="..\..\..\..\..\lazarus23_213\fpc\2.1.3\source\rtl\objpas\types.pp"/>
<UnitName Value="types"/>
<CursorPos X="1" Y="1"/>
<TopLine Value="268"/>
<UsageCount Value="9"/>
</Unit9>
<Unit10>
<Filename Value="..\..\..\..\..\lazarus23_213\fpc\2.1.3\source\rtl\objpas\typinfo.pp"/>
<UnitName Value="typinfo"/>
<CursorPos X="1" Y="1"/>
<TopLine Value="1276"/>
<UsageCount Value="9"/>
</Unit10>
<Unit11>
<Filename Value="user_edit_imp.pas"/>
<ComponentName Value="fUserEdit"/>
<IsPartOfProject Value="True"/>
<ResourceFilename Value="user_edit_imp.lrs"/>
<UnitName Value="user_edit_imp"/>
<CursorPos X="19" Y="27"/>
<TopLine Value="27"/>
<EditorIndex Value="7"/>
<UsageCount Value="37"/>
<Loaded Value="True"/>
</Unit11>
<Unit12>
<Filename Value="..\..\..\..\..\lazarus23_213\components\rtticontrols\rttictrls.pas"/>
<UnitName Value="RTTICtrls"/>
<CursorPos X="3" Y="2239"/>
<TopLine Value="2237"/>
<UsageCount Value="12"/>
</Unit12>
<Unit13>
<Filename Value="..\..\..\..\..\lazarus23_213\lcl\interfaces\win32\interfaces.pp"/>
<UnitName Value="Interfaces"/>
<CursorPos X="25" Y="40"/>
<TopLine Value="22"/>
<UsageCount Value="9"/>
</Unit13>
<Unit14>
<Filename Value="..\..\..\..\..\lazarus23_213\lcl\interfaces\win32\win32int.pp"/>
<UnitName Value="Win32Int"/>
<CursorPos X="34" Y="50"/>
<TopLine Value="246"/>
<UsageCount Value="9"/>
</Unit14>
<Unit15>
<Filename Value="..\..\..\..\..\lazarus23_213\fpc\2.1.3\source\rtl\inc\resh.inc"/>
<CursorPos X="3" Y="10"/>
<TopLine Value="1"/>
<UsageCount Value="9"/>
</Unit15>
<Unit16>
<Filename Value="user_edit_imp.lrs"/>
<CursorPos X="1" Y="1"/>
<TopLine Value="1"/>
<UsageCount Value="9"/>
</Unit16>
<Unit17>
<Filename Value="..\..\binary_formatter.pas"/>
<UnitName Value="binary_formatter"/>
<CursorPos X="58" Y="132"/>
<TopLine Value="113"/>
<EditorIndex Value="3"/>
<UsageCount Value="15"/>
<Loaded Value="True"/>
</Unit17>
<Unit18>
<Filename Value="..\..\..\..\..\lazarus23_213\lcl\controls.pp"/>
<UnitName Value="Controls"/>
<CursorPos X="15" Y="1653"/>
<TopLine Value="1635"/>
<UsageCount Value="9"/>
</Unit18>
<Unit19>
<Filename Value="..\..\..\..\..\lazarus23_213\ideintf\propedits.pp"/>
<UnitName Value="PropEdits"/>
<CursorPos X="49" Y="4174"/>
<TopLine Value="4157"/>
<UsageCount Value="10"/>
</Unit19>
<Unit20>
<Filename Value="..\..\base_binary_formatter.pas"/>
<UnitName Value="base_binary_formatter"/>
<CursorPos X="1" Y="1511"/>
<TopLine Value="1497"/>
<EditorIndex Value="1"/>
<UsageCount Value="10"/>
<Loaded Value="True"/>
</Unit20>
</Units>
<JumpHistory Count="23" HistoryIndex="22">
<Position1>
<Filename Value="umain.pas"/>
<Caret Line="126" Column="27" TopLine="114"/>
</Position1>
<Position2>
<Filename Value="umain.pas"/>
<Caret Line="120" Column="17" TopLine="106"/>
</Position2>
<Position3>
<Filename Value="umain.pas"/>
<Caret Line="79" Column="36" TopLine="77"/>
</Position3>
<Position4>
<Filename Value="umain.pas"/>
<Caret Line="27" Column="5" TopLine="26"/>
</Position4>
<Position5>
<Filename Value="umain.pas"/>
<Caret Line="151" Column="22" TopLine="75"/>
</Position5>
<Position6>
<Filename Value="umain.pas"/>
<Caret Line="29" Column="49" TopLine="28"/>
</Position6>
<Position7>
<Filename Value="umain.pas"/>
<Caret Line="31" Column="48" TopLine="14"/>
</Position7>
<Position8>
<Filename Value="umain.pas"/>
<Caret Line="159" Column="3" TopLine="141"/>
</Position8>
<Position9>
<Filename Value="umain.pas"/>
<Caret Line="120" Column="1" TopLine="117"/>
</Position9>
<Position10>
<Filename Value="umain.pas"/>
<Caret Line="85" Column="38" TopLine="142"/>
</Position10>
<Position11>
<Filename Value="umain.pas"/>
<Caret Line="158" Column="51" TopLine="142"/>
</Position11>
<Position12>
<Filename Value="user_edit_imp.pas"/>
<Caret Line="25" Column="15" TopLine="1"/>
</Position12>
<Position13>
<Filename Value="user_edit_imp.pas"/>
<Caret Line="25" Column="18" TopLine="10"/>
</Position13>
<Position14>
<Filename Value="user_edit_imp.pas"/>
<Caret Line="25" Column="18" TopLine="10"/>
</Position14>
<Position15>
<Filename Value="user_edit_imp.pas"/>
<Caret Line="25" Column="19" TopLine="10"/>
</Position15>
<Position16>
<Filename Value="user_edit_imp.pas"/>
<Caret Line="25" Column="19" TopLine="10"/>
</Position16>
<Position17>
<Filename Value="..\user_service_intf_proxy.pas"/>
<Caret Line="21" Column="24" TopLine="13"/>
</Position17>
<Position18>
<Filename Value="umain.pas"/>
<Caret Line="158" Column="51" TopLine="1"/>
</Position18>
<Position19>
<Filename Value="umain.pas"/>
<Caret Line="69" Column="44" TopLine="55"/>
</Position19>
<Position20>
<Filename Value="umain.pas"/>
<Caret Line="130" Column="44" TopLine="116"/>
</Position20>
<Position21>
<Filename Value="user_edit_imp.pas"/>
<Caret Line="25" Column="19" TopLine="13"/>
</Position21>
<Position22>
<Filename Value="user_edit_imp.pas"/>
<Caret Line="26" Column="23" TopLine="13"/>
</Position22>
<Position23>
<Filename Value="user_edit_imp.pas"/>
<Caret Line="27" Column="22" TopLine="13"/>
</Position23>
</JumpHistory>
</ProjectOptions>
<CompilerOptions>
<Version Value="5"/>
<PathDelim Value="\"/>
<Target>
<Filename Value="user_client.exe"/>
</Target>
<SearchPaths>
<OtherUnitFiles Value="C:\Programmes\lazarus\wst\samples\;$(LazarusDir)\others_package\synapse\;C:\Programmes\lazarus\wst\"/>
<UnitOutputDirectory Value="obj"/>
<SrcPath Value="$(LazarusDir)\lcl\;$(LazarusDir)\lcl\interfaces\$(LCLWidgetType)\"/>
</SearchPaths>
<CodeGeneration>
<Generate Value="Faster"/>
</CodeGeneration>
<Linking>
<Options>
<Win32>
<GraphicApplication Value="True"/>
</Win32>
</Options>
</Linking>
<Other>
<CompilerPath Value="$(CompPath)"/>
</Other>
</CompilerOptions>
<Debugging>
<BreakPoints Count="4">
<Item1>
<Source Value="D:\lazarusClean\fpcsrc\rtl\inc\getopts.pp"/>
<Line Value="230"/>
</Item1>
<Item2>
<Source Value="D:\lazarusClean\fpcsrc\rtl\inc\getopts.pp"/>
<Line Value="193"/>
</Item2>
<Item3>
<Source Value="D:\lazarusClean\fpcsrc\rtl\inc\getopts.pp"/>
<Line Value="198"/>
</Item3>
<Item4>
<Source Value="..\..\ws_helper\wsdl2pas_imp.pas"/>
<Line Value="606"/>
</Item4>
</BreakPoints>
<Watches Count="2">
<Item1>
<Expression Value="locStrFilter"/>
</Item1>
<Item2>
<Expression Value="i"/>
</Item2>
</Watches>
<Exceptions Count="2">
<Item1>
<Name Value="ECodetoolError"/>
</Item1>
<Item2>
<Name Value="EFOpenError"/>
</Item2>
</Exceptions>
</Debugging>
</CONFIG>

19
wst/tags/0.4/samples/user_client/user_client.lpr Normal file
View File

@ -0,0 +1,19 @@
program user_client;
{$mode objfpc}{$H+}
uses
{$IFDEF UNIX}{$IFDEF UseCThreads}
cthreads,
{$ENDIF}{$ENDIF}
Interfaces, // this includes the LCL widgetset
Forms
, umain, RunTimeTypeInfoControls, user_edit_imp;
begin
Application.Initialize;
Application.CreateForm(TfMain, fMain);
Application.CreateForm(TfUserEdit, fUserEdit);
Application.Run;
end.

124
wst/tags/0.4/samples/user_client/user_edit_imp.lfm Normal file
View File

@ -0,0 +1,124 @@
object fUserEdit: TfUserEdit
Left = 395
Height = 241
Top = 199
Width = 400
HorzScrollBar.Page = 399
VertScrollBar.Page = 240
ActiveControl = btnOk
BorderIcons = [biSystemMenu]
BorderStyle = bsDialog
Caption = 'User Edit'
ClientHeight = 241
ClientWidth = 400
Position = poMainFormCenter
object Panel1: TPanel
Height = 50
Top = 191
Width = 400
Align = alBottom
ClientHeight = 50
ClientWidth = 400
TabOrder = 0
object btnOk: TButton
Left = 224
Height = 35
Top = 6
Width = 75
BorderSpacing.InnerBorder = 4
Caption = 'OK'
Default = True
ModalResult = 1
TabOrder = 0
end
object Button2: TButton
Left = 312
Height = 35
Top = 6
Width = 75
BorderSpacing.InnerBorder = 4
Cancel = True
Caption = 'Cancel'
ModalResult = 2
TabOrder = 1
end
end
object Panel2: TPanel
Height = 191
Width = 400
Align = alClient
ClientHeight = 191
ClientWidth = 400
TabOrder = 1
object Label1: TLabel
Left = 16
Height = 18
Top = 18
Width = 36
Caption = 'Name'
Color = clNone
ParentColor = False
end
object Label2: TLabel
Left = 16
Height = 18
Top = 53
Width = 34
Caption = 'e-Mail'
Color = clNone
ParentColor = False
end
object Label3: TLabel
Left = 16
Height = 18
Top = 88
Width = 58
Caption = 'Category'
Color = clNone
ParentColor = False
end
object Label4: TLabel
Left = 17
Height = 18
Top = 120
Width = 72
Caption = 'Preferences'
Color = clNone
ParentColor = False
end
object edtName: TTIEdit
Left = 80
Height = 23
Top = 16
Width = 304
Link.TIPropertyName = 'UserName'
TabOrder = 0
end
object edteMail: TTIEdit
Left = 80
Height = 23
Top = 53
Width = 304
Link.TIPropertyName = 'eMail'
TabOrder = 1
end
object edtCategory: TTIComboBox
Left = 80
Height = 24
Top = 88
Width = 160
Link.TIPropertyName = 'Category'
MaxLength = 0
Style = csDropDownList
TabOrder = 2
end
object edtPreferences: TTIEdit
Left = 17
Height = 23
Top = 146
Width = 368
Link.TIPropertyName = 'Preferences'
TabOrder = 3
end
end
end

34
wst/tags/0.4/samples/user_client/user_edit_imp.lrs Normal file
View File

@ -0,0 +1,34 @@
{ Ceci est un fichier ressource g�n�r� automatiquement par Lazarus }
LazarusResources.Add('TfUserEdit','FORMDATA',[
'TPF0'#10'TfUserEdit'#9'fUserEdit'#4'Left'#3#139#1#6'Height'#3#241#0#3'Top'#3
+#199#0#5'Width'#3#144#1#18'HorzScrollBar.Page'#3#143#1#18'VertScrollBar.Page'
+#3#240#0#13'ActiveControl'#7#5'btnOk'#11'BorderIcons'#11#12'biSystemMenu'#0
+#11'BorderStyle'#7#8'bsDialog'#7'Caption'#6#9'User Edit'#12'ClientHeight'#3
+#241#0#11'ClientWidth'#3#144#1#8'Position'#7#16'poMainFormCenter'#0#6'TPanel'
+#6'Panel1'#6'Height'#2'2'#3'Top'#3#191#0#5'Width'#3#144#1#5'Align'#7#8'alBot'
+'tom'#12'ClientHeight'#2'2'#11'ClientWidth'#3#144#1#8'TabOrder'#2#0#0#7'TBut'
+'ton'#5'btnOk'#4'Left'#3#224#0#6'Height'#2'#'#3'Top'#2#6#5'Width'#2'K'#25'Bo'
+'rderSpacing.InnerBorder'#2#4#7'Caption'#6#2'OK'#7'Default'#9#11'ModalResult'
+#2#1#8'TabOrder'#2#0#0#0#7'TButton'#7'Button2'#4'Left'#3'8'#1#6'Height'#2'#'
+#3'Top'#2#6#5'Width'#2'K'#25'BorderSpacing.InnerBorder'#2#4#6'Cancel'#9#7'Ca'
+'ption'#6#6'Cancel'#11'ModalResult'#2#2#8'TabOrder'#2#1#0#0#0#6'TPanel'#6'Pa'
+'nel2'#6'Height'#3#191#0#5'Width'#3#144#1#5'Align'#7#8'alClient'#12'ClientHe'
+'ight'#3#191#0#11'ClientWidth'#3#144#1#8'TabOrder'#2#1#0#6'TLabel'#6'Label1'
+#4'Left'#2#16#6'Height'#2#18#3'Top'#2#18#5'Width'#2'$'#7'Caption'#6#4'Name'#5
+'Color'#7#6'clNone'#11'ParentColor'#8#0#0#6'TLabel'#6'Label2'#4'Left'#2#16#6
+'Height'#2#18#3'Top'#2'5'#5'Width'#2'"'#7'Caption'#6#6'e-Mail'#5'Color'#7#6
+'clNone'#11'ParentColor'#8#0#0#6'TLabel'#6'Label3'#4'Left'#2#16#6'Height'#2
+#18#3'Top'#2'X'#5'Width'#2':'#7'Caption'#6#8'Category'#5'Color'#7#6'clNone'
+#11'ParentColor'#8#0#0#6'TLabel'#6'Label4'#4'Left'#2#17#6'Height'#2#18#3'Top'
+#2'x'#5'Width'#2'H'#7'Caption'#6#11'Preferences'#5'Color'#7#6'clNone'#11'Par'
+'entColor'#8#0#0#7'TTIEdit'#7'edtName'#4'Left'#2'P'#6'Height'#2#23#3'Top'#2
+#16#5'Width'#3'0'#1#19'Link.TIPropertyName'#6#8'UserName'#8'TabOrder'#2#0#0#0
+#7'TTIEdit'#8'edteMail'#4'Left'#2'P'#6'Height'#2#23#3'Top'#2'5'#5'Width'#3'0'
+#1#19'Link.TIPropertyName'#6#5'eMail'#8'TabOrder'#2#1#0#0#11'TTIComboBox'#11
+'edtCategory'#4'Left'#2'P'#6'Height'#2#24#3'Top'#2'X'#5'Width'#3#160#0#19'Li'
+'nk.TIPropertyName'#6#8'Category'#9'MaxLength'#2#0#5'Style'#7#14'csDropDownL'
+'ist'#8'TabOrder'#2#2#0#0#7'TTIEdit'#14'edtPreferences'#4'Left'#2#17#6'Heigh'
+'t'#2#23#3'Top'#3#146#0#5'Width'#3'p'#1#19'Link.TIPropertyName'#6#11'Prefere'
+'nces'#8'TabOrder'#2#3#0#0#0#0
]);

73
wst/tags/0.4/samples/user_client/user_edit_imp.pas Normal file
View File

@ -0,0 +1,73 @@
unit user_edit_imp;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, ExtCtrls,
Buttons, StdCtrls, RTTICtrls, user_service_intf;
type
{ TfUserEdit }
TfUserEdit = class(TForm)
btnOk: TButton;
Button2: TButton;
Label1: TLabel;
Label2: TLabel;
Label3: TLabel;
Label4: TLabel;
Panel1: TPanel;
Panel2: TPanel;
edtCategory: TTIComboBox;
edtName: TTIEdit;
edteMail: TTIEdit;
edtPreferences: TTIEdit;
private
FInfos: TUser;
public
constructor Create(AOwner : TComponent);override;
destructor Destroy();override;
property Infos : TUser read FInfos;
function UpdateObject( AUser : TUser ) : Boolean;
end;
var
fUserEdit: TfUserEdit;
implementation
{ TfUserEdit }
constructor TfUserEdit.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FInfos := TUser.Create();
edtName.Link.TIObject := FInfos;
edteMail.Link.TIObject := FInfos;
edtPreferences.Link.TIObject := FInfos;
edtCategory.Link.TIObject := FInfos;
end;
destructor TfUserEdit.Destroy();
begin
FreeAndNil(FInfos);
inherited Destroy();
end;
function TfUserEdit.UpdateObject(AUser: TUser): Boolean;
begin
Infos.Assign(AUser);
Result := ( ShowModal() = mrOK );
if Result then begin
AUser.Assign(Infos);
end;
end;
initialization
{$I user_edit_imp.lrs}
end.

233
wst/tags/0.4/samples/user_client_console/user_client_console.lpi Normal file
View File

@ -0,0 +1,233 @@
<?xml version="1.0"?>
<CONFIG>
<ProjectOptions>
<PathDelim Value="/"/>
<Version Value="5"/>
<General>
<Flags>
<MainUnitHasUsesSectionForAllUnits Value="False"/>
<MainUnitHasCreateFormStatements Value="False"/>
<MainUnitHasTitleStatement Value="False"/>
</Flags>
<MainUnit Value="0"/>
<IconPath Value="./"/>
<TargetFileExt Value=".exe"/>
<ActiveEditorIndexAtStart Value="1"/>
</General>
<VersionInfo>
<ProjectVersion Value=""/>
</VersionInfo>
<PublishOptions>
<Version Value="2"/>
<IgnoreBinaries Value="False"/>
<IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/>
<ExcludeFileFilter Value="*.(bak|ppu|ppw|o|so);*~;backup"/>
</PublishOptions>
<RunParams>
<local>
<FormatVersion Value="1"/>
<LaunchingApplication PathPlusParams="/usr/X11R6/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/>
</local>
</RunParams>
<Units Count="19">
<Unit0>
<Filename Value="user_client_console.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="user_client_console"/>
<CursorPos X="12" Y="14"/>
<TopLine Value="16"/>
<EditorIndex Value="0"/>
<UsageCount Value="34"/>
<Loaded Value="True"/>
</Unit0>
<Unit1>
<Filename Value="../user_service_intf_proxy.pas"/>
<UnitName Value="user_service_intf_proxy"/>
<CursorPos X="1" Y="1"/>
<TopLine Value="1"/>
<EditorIndex Value="5"/>
<UsageCount Value="17"/>
<Loaded Value="True"/>
</Unit1>
<Unit2>
<Filename Value="../../synapse_tcp_protocol.pas"/>
<UnitName Value="synapse_tcp_protocol"/>
<CursorPos X="1" Y="1"/>
<TopLine Value="1"/>
<EditorIndex Value="8"/>
<UsageCount Value="17"/>
<Loaded Value="True"/>
</Unit2>
<Unit3>
<Filename Value="../../service_intf.pas"/>
<UnitName Value="service_intf"/>
<CursorPos X="1" Y="1"/>
<TopLine Value="1"/>
<EditorIndex Value="4"/>
<UsageCount Value="17"/>
<Loaded Value="True"/>
</Unit3>
<Unit4>
<Filename Value="../user_service_intf.pas"/>
<UnitName Value="user_service_intf"/>
<CursorPos X="1" Y="1"/>
<TopLine Value="1"/>
<EditorIndex Value="7"/>
<UsageCount Value="17"/>
<Loaded Value="True"/>
</Unit4>
<Unit5>
<Filename Value="../../../../../lazarus23_213/others_package/synapse/blcksock.pas"/>
<UnitName Value="blcksock"/>
<CursorPos X="60" Y="2413"/>
<TopLine Value="2393"/>
<UsageCount Value="9"/>
</Unit5>
<Unit6>
<Filename Value="../../base_service_intf.pas"/>
<UnitName Value="base_service_intf"/>
<CursorPos X="52" Y="4135"/>
<TopLine Value="4000"/>
<EditorIndex Value="3"/>
<UsageCount Value="17"/>
<Loaded Value="True"/>
</Unit6>
<Unit7>
<Filename Value="../../library_protocol.pas"/>
<UnitName Value="library_protocol"/>
<CursorPos X="18" Y="5"/>
<TopLine Value="26"/>
<EditorIndex Value="1"/>
<UsageCount Value="17"/>
<Loaded Value="True"/>
</Unit7>
<Unit8>
<Filename Value="../../../../../lazarus23_213/fpc/2.1.3/source/rtl/objpas/sysutils/finah.inc"/>
<CursorPos X="10" Y="33"/>
<TopLine Value="17"/>
<UsageCount Value="9"/>
</Unit8>
<Unit9>
<Filename Value="../../../../../lazarus23_213/fpc/2.1.3/source/rtl/objpas/sysutils/fina.inc"/>
<CursorPos X="13" Y="112"/>
<TopLine Value="105"/>
<UsageCount Value="9"/>
</Unit9>
<Unit10>
<Filename Value="../../../../../lazarus23_213/fpc/2.1.3/source/rtl/objpas/sysutils/sysutilh.inc"/>
<CursorPos X="33" Y="202"/>
<TopLine Value="188"/>
<UsageCount Value="9"/>
</Unit10>
<Unit11>
<Filename Value="../../../../../lazarus23_213/fpc/2.1.3/source/rtl/win32/system.pp"/>
<UnitName Value="System"/>
<CursorPos X="20" Y="35"/>
<TopLine Value="21"/>
<UsageCount Value="9"/>
</Unit11>
<Unit12>
<Filename Value="../../../../../lazarus23_213/fpc/2.1.3/source/rtl/inc/fexpand.inc"/>
<CursorPos X="10" Y="86"/>
<TopLine Value="226"/>
<UsageCount Value="9"/>
</Unit12>
<Unit13>
<Filename Value="../../../../../lazarus23_213/fpc/2.1.3/source/rtl/objpas/sysutils/sysstrh.inc"/>
<CursorPos X="54" Y="33"/>
<TopLine Value="19"/>
<UsageCount Value="9"/>
</Unit13>
<Unit14>
<Filename Value="../../synapse_http_protocol.pas"/>
<UnitName Value="synapse_http_protocol"/>
<CursorPos X="1" Y="1"/>
<TopLine Value="22"/>
<UsageCount Value="17"/>
</Unit14>
<Unit15>
<Filename Value="../../metadata_repository.pas"/>
<UnitName Value="metadata_repository"/>
<CursorPos X="1" Y="1"/>
<TopLine Value="1"/>
<EditorIndex Value="6"/>
<UsageCount Value="17"/>
<Loaded Value="True"/>
</Unit15>
<Unit16>
<Filename Value="../../wst.inc"/>
<CursorPos X="1" Y="1"/>
<TopLine Value="1"/>
<UsageCount Value="12"/>
</Unit16>
<Unit17>
<Filename Value="../../library_imp_utils.pas"/>
<UnitName Value="library_imp_utils"/>
<CursorPos X="1" Y="1"/>
<TopLine Value="1"/>
<EditorIndex Value="2"/>
<UsageCount Value="12"/>
<Loaded Value="True"/>
</Unit17>
<Unit18>
<Filename Value="../../../../../lazarus23_213/fpc/2.1.3/source/rtl/win/dynlibs.inc"/>
<CursorPos X="17" Y="27"/>
<TopLine Value="13"/>
<UsageCount Value="10"/>
</Unit18>
</Units>
<JumpHistory Count="0" HistoryIndex="-1"/>
</ProjectOptions>
<CompilerOptions>
<Version Value="5"/>
<Target>
<Filename Value="user_client_console.exe"/>
</Target>
<SearchPaths>
<OtherUnitFiles Value="../;../../;$(LazarusDir)/others_package/synapse/"/>
<UnitOutputDirectory Value="obj"/>
</SearchPaths>
<CodeGeneration>
<Generate Value="Faster"/>
</CodeGeneration>
<Other>
<CompilerPath Value="$(CompPath)"/>
</Other>
</CompilerOptions>
<Debugging>
<BreakPoints Count="4">
<Item1>
<Source Value="D:/lazarusClean/fpcsrc/rtl/inc/getopts.pp"/>
<Line Value="230"/>
</Item1>
<Item2>
<Source Value="D:/lazarusClean/fpcsrc/rtl/inc/getopts.pp"/>
<Line Value="193"/>
</Item2>
<Item3>
<Source Value="D:/lazarusClean/fpcsrc/rtl/inc/getopts.pp"/>
<Line Value="198"/>
</Item3>
<Item4>
<Source Value="../../ws_helper/wsdl2pas_imp.pas"/>
<Line Value="606"/>
</Item4>
</BreakPoints>
<Watches Count="2">
<Item1>
<Expression Value="locStrFilter"/>
</Item1>
<Item2>
<Expression Value="i"/>
</Item2>
</Watches>
<Exceptions Count="2">
<Item1>
<Name Value="ECodetoolError"/>
</Item1>
<Item2>
<Name Value="EFOpenError"/>
</Item2>
</Exceptions>
</Debugging>
</CONFIG>

193
wst/tags/0.4/samples/user_client_console/user_client_console.pas Normal file
View File

@ -0,0 +1,193 @@
program user_client_console;
{$mode objfpc}{$H+}
uses
Classes, SysUtils, TypInfo,
user_service_intf_proxy,
synapse_tcp_protocol, synapse_http_protocol, library_protocol,
soap_formatter, binary_formatter,
user_service_intf;
var
UserServiceInst : UserService;
procedure ShowUser(AUser : TUser);
begin
if ( AUser <> nil ) then begin
WriteLn(' Name = ',AUser.UserName);
WriteLn(' Category = ',GetEnumName(TypeInfo(TUserCategory),Ord(AUser.Category)));
WriteLn(' e-Mail = ',AUser.eMail);
WriteLn(' Preferences = ',AUser.Preferences);
end else begin
WriteLn('<Empty User>');
end;
end;
procedure ShowUserArray(AArray : TUserArray);
var
i, c : Integer;
usr : TUser;
begin
if ( AArray <> nil ) then begin
c := AArray.Length;
for i := 0 to Pred(c) do begin
usr := AArray[i];
WriteLn();
WriteLn(Format('User[%d] : ',[(i+1)]));
ShowUser(usr);
end;
end;
end;
procedure HandleShowAll();
var
userArray : TUserArray;
begin
userArray := UserServiceInst.GetList();
try
if ( userArray <> nil ) and ( userArray.Length > 0 ) then begin
ShowUserArray(userArray);
end else begin
WriteLn('Empty Array.');
end;
finally
FreeAndNil(userArray);
end;
end;
procedure HandleAdd();
function ReadItem(const APrompt : string; const ANonNull : Boolean):string ;
begin
Result := '';
Write(APrompt);
ReadLn(Result);
Result := Trim(Result);
if ANonNull and ( Length(Result) = 0 ) then
Raise Exception.Create('Invalid User Name!');
end;
var
usr : TUser;
buff : string;
begin
buff := '';
WriteLn('Adding a user :');
try
usr := TUser.Create();
try
usr.UserName := ReadItem('Enter user name : ',True);
buff := UpperCase(ReadItem('Enter user Category( A : Admin; N : normal ) : ',True));
if ( buff[1] = 'A' ) then
usr.Category:= Admin
else
usr.Category:= Normal;
usr.eMail := ReadItem('Enter user e-mail : ',False);
usr.Preferences := ReadItem('Enter user Preferences : ',False);
UserServiceInst.Add(usr);
finally
FreeAndNil(usr);
end;
except
on e : Exception do begin
WriteLn(e.Message);
end;
end;
end;
procedure HandleFindUser();
var
user : TUser;
buff : string;
begin
Write('Enter User Name : ');
ReadLn(buff);
user := UserServiceInst.Find(buff);
try
ShowUser(user);
finally
FreeAndNil(user);
end;
end;
type TTransportType = ( ttLibrary, ttTCP, ttHTTP );
procedure CreateProxy(const ATransportType :TTransportType);
const ADDRESS_MAP : array[TTransportType] of string = (
'LIB:FileName=..\library_server\lib_server.dll;target=UserService',
'TCP:Address=127.0.0.1;Port=1234;target=UserService',
'http:Address=http://127.0.0.1:8080/wst/services/UserService'
//'http:Address=http://127.0.0.1:8000/services/UserService'
);
var
buff : string;
begin
buff := ADDRESS_MAP[ATransportType];
if ( ATransportType = ttLibrary ) then
buff := StringReplace(buff,'\',DirectorySeparator,[rfReplaceAll, rfIgnoreCase]);
UserServiceInst := TUserService_Proxy.Create(
'UserService',
'binary:',
buff
);
end;
function ReadTransportType():TTransportType;
var
buff : string;
begin
WriteLn();
WriteLn('Select a transport protocol : ');
WriteLn(' L : Library, the lib_server project must have been built');
WriteLn(' T : TCP, the tcp_server must have been built');
WriteLn(' H : HTTP, the http_server must have been built');
WriteLn();
Write('Your selection : ');
while True do begin
ReadLn(buff);
buff := UpperCase(Trim(buff));
if ( Length(buff) > 0 ) and ( buff[1] in ['L','T', 'H'] ) then begin
case buff[1] of
'L' : Result := ttLibrary;
'T' : Result := ttTCP;
'H' : Result := ttHTTP;
end;
Break;
end;
end;
end;
var
strBuffer : string;
tt : TTransportType;
begin
SYNAPSE_RegisterTCP_Transport();
SYNAPSE_RegisterHTTP_Transport();
LIB_Register_Transport();
WriteLn('Sample Application using Web Services Toolkit');
CreateProxy(ReadTransportType());
WriteLn('Menu :');
WriteLn(' L : Show the user list');
WriteLn(' A : Add a new user');
WriteLn(' F : Find a new');
WriteLn(' C : Change the communication protocol');
WriteLn(' X : Exit');
WriteLn();
Write('Choose a item : ');
while True do begin
strBuffer := '';
ReadLn(strBuffer);
strBuffer := UpperCase(Trim(strBuffer));
if ( Length(strBuffer) > 0 ) then begin
case strBuffer[1] of
'L' : HandleShowAll();
'A' : HandleAdd();
'F' : HandleFindUser();
'C' : CreateProxy(ReadTransportType());
'X' : Break;
end;
WriteLn();
Write('Choose a item : ');
end;
end;
end.

216
wst/tags/0.4/samples/user_service_intf.pas Normal file
View File

@ -0,0 +1,216 @@
{
This unit has been produced by ws_helper.
Input unit name : "user_service_intf".
This unit name : "user_service_intf".
Date : "05/05/2007 19:07".
}
unit user_service_intf;
{$IFDEF FPC} {$mode objfpc}{$H+} {$ENDIF}
interface
uses SysUtils, Classes, TypInfo, base_service_intf, service_intf;
const
sNAME_SPACE = 'urn:UserService';
sUNIT_NAME = 'user_service_intf';
type
TUser = class;
TUserArray = class;
TUserCategory = (
Normal
,Admin
);
TUser = class(TBaseComplexRemotable)
private
FCategory : TUserCategory;
FUserName : string;
FeMail : string;
FPreferences : string;
published
property Category : TUserCategory read FCategory write FCategory;
property UserName : string read FUserName write FUserName;
property eMail : string read FeMail write FeMail;
property Preferences : string read FPreferences write FPreferences;
end;
TUserArray = class(TBaseObjectArrayRemotable)
private
function GetItem(AIndex: Integer): TUser;
public
class function GetItemClass():TBaseRemotableClass;override;
property Item[AIndex:Integer] : TUser Read GetItem;Default;
end;
UserService = interface(IInvokable)
['{842D8408-E142-470F-9CDD-FAD0D8AEEB12}']
function GetList():TUserArray;
procedure Add(
Const AUser : TUser
);
procedure Update(
Const AUser : TUser
);
function Find(
Const AName : string
):TUser;
function Delete(
Const AName : string
):boolean;
end;
procedure Register_user_service_intf_ServiceMetadata();
Implementation
uses metadata_repository;
{ TUserArray }
function TUserArray.GetItem(AIndex: Integer): TUser;
begin
Result := Inherited GetItem(AIndex) As TUser;
end;
class function TUserArray.GetItemClass(): TBaseRemotableClass;
begin
Result:= TUser;
end;
procedure Register_user_service_intf_ServiceMetadata();
var
mm : IModuleMetadataMngr;
begin
mm := GetModuleMetadataMngr();
mm.SetRepositoryNameSpace(sUNIT_NAME, sNAME_SPACE);
mm.SetServiceCustomData(
sUNIT_NAME,
'UserService',
'TRANSPORT_Address',
'http://127.0.0.1:8000/services/UserService'
);
mm.SetServiceCustomData(
sUNIT_NAME,
'UserService',
'FORMAT_Style',
'rpc'
);
mm.SetOperationCustomData(
sUNIT_NAME,
'UserService',
'GetList',
'TRANSPORT_soapAction',
'urn:UserService/UserServiceGetList'
);
mm.SetOperationCustomData(
sUNIT_NAME,
'UserService',
'GetList',
'FORMAT_Input_EncodingStyle',
'literal'
);
mm.SetOperationCustomData(
sUNIT_NAME,
'UserService',
'GetList',
'FORMAT_OutputEncodingStyle',
'literal'
);
mm.SetOperationCustomData(
sUNIT_NAME,
'UserService',
'Add',
'TRANSPORT_soapAction',
'urn:UserService/UserServiceAdd'
);
mm.SetOperationCustomData(
sUNIT_NAME,
'UserService',
'Add',
'FORMAT_Input_EncodingStyle',
'literal'
);
mm.SetOperationCustomData(
sUNIT_NAME,
'UserService',
'Add',
'FORMAT_OutputEncodingStyle',
'literal'
);
mm.SetOperationCustomData(
sUNIT_NAME,
'UserService',
'Update',
'TRANSPORT_soapAction',
'urn:UserService/UserServiceUpdate'
);
mm.SetOperationCustomData(
sUNIT_NAME,
'UserService',
'Update',
'FORMAT_Input_EncodingStyle',
'literal'
);
mm.SetOperationCustomData(
sUNIT_NAME,
'UserService',
'Update',
'FORMAT_OutputEncodingStyle',
'literal'
);
mm.SetOperationCustomData(
sUNIT_NAME,
'UserService',
'Find',
'TRANSPORT_soapAction',
'urn:UserService/UserServiceFind'
);
mm.SetOperationCustomData(
sUNIT_NAME,
'UserService',
'Find',
'FORMAT_Input_EncodingStyle',
'literal'
);
mm.SetOperationCustomData(
sUNIT_NAME,
'UserService',
'Find',
'FORMAT_OutputEncodingStyle',
'literal'
);
mm.SetOperationCustomData(
sUNIT_NAME,
'UserService',
'Delete',
'TRANSPORT_soapAction',
'urn:UserService/UserServiceDelete'
);
mm.SetOperationCustomData(
sUNIT_NAME,
'UserService',
'Delete',
'FORMAT_Input_EncodingStyle',
'literal'
);
mm.SetOperationCustomData(
sUNIT_NAME,
'UserService',
'Delete',
'FORMAT_OutputEncodingStyle',
'literal'
);
end;
initialization
GetTypeRegistry().Register(sNAME_SPACE,TypeInfo(TUserCategory),'TUserCategory');
GetTypeRegistry().Register(sNAME_SPACE,TypeInfo(TUser),'TUser');
GetTypeRegistry().Register(sNAME_SPACE,TypeInfo(TUserArray),'TUserArray');
GetTypeRegistry().ItemByTypeInfo[TypeInfo(TUserArray)].RegisterExternalPropertyName(sARRAY_ITEM,'item');
End.

91
wst/tags/0.4/samples/user_service_intf.wsdl Normal file
View File

@ -0,0 +1,91 @@
<?xml version="1.0"?>
<definitions name="user_service_intf" xmlns="http://schemas.xmlsoap.org/wsdl/" xmlns:tns="urn:UserService" xmlns:xsd="http://www.w3.org/2001/XMLSchema" xmlns:soap="http://schemas.xmlsoap.org/wsdl/soap/" targetNamespace="urn:UserService">
<types>
<xsd:schema xmlns="http://www.w3.org/2001/XMLSchema" targetNamespace="urn:UserService">
<xsd:simpleType name="TUserCategory">
<xsd:restriction base="xsd:string">
<xsd:enumeration value="Normal"/>
<xsd:enumeration value="Admin"/>
</xsd:restriction>
</xsd:simpleType>
<xsd:element name="TUser">
<xsd:complexType>
<xsd:sequence>
<xsd:element name="Category" type="tns:TUserCategory" maxOccurs="1" minOccurs="1"/>
<xsd:element name="UserName" type="xsd:string" maxOccurs="1" minOccurs="1"/>
<xsd:element name="eMail" type="xsd:string" maxOccurs="1" minOccurs="1"/>
<xsd:element name="Preferences" type="xsd:string" maxOccurs="1" minOccurs="1"/>
</xsd:sequence>
</xsd:complexType>
</xsd:element>
<xsd:element name="TUserArray">
<xsd:complexType>
<xsd:sequence><xsd:element name="item" type="tns:TUser" maxOccurs="unbounded" minOccurs="0"/></xsd:sequence>
</xsd:complexType>
</xsd:element>
</xsd:schema>
</types>
<message name="GetList"/>
<message name="GetListResponse"><part name="result" type="tns:TUserArray"/></message>
<message name="Add"><part name="AUser" type="tns:TUser"/></message>
<message name="AddResponse"/>
<message name="Update"><part name="AUser" type="tns:TUser"/></message>
<message name="UpdateResponse"/>
<message name="Find"><part name="AName" type="xsd:string"/></message>
<message name="FindResponse"><part name="result" type="tns:TUser"/></message>
<message name="Delete"><part name="AName" type="xsd:string"/></message>
<message name="DeleteResponse"><part name="result" type="xsd:boolean"/></message>
<portType name="UserService">
<operation name="GetList">
<input message="tns:GetList"/>
<output message="tns:GetListResponse"/>
</operation>
<operation name="Add">
<input message="tns:Add"/>
<output message="tns:AddResponse"/>
</operation>
<operation name="Update">
<input message="tns:Update"/>
<output message="tns:UpdateResponse"/>
</operation>
<operation name="Find">
<input message="tns:Find"/>
<output message="tns:FindResponse"/>
</operation>
<operation name="Delete">
<input message="tns:Delete"/>
<output message="tns:DeleteResponse"/>
</operation>
</portType>
<binding name="UserServiceBinding" type="tns:UserService">
<soap:binding style="rpc" transport="http://schemas.xmlsoap.org/soap/http"/>
<operation name="GetList">
<soap:operation soapAction="urn:UserService/UserServiceGetList"/>
<input><soap:body use="literal" namespace="urn:UserService"/></input>
<output><soap:body use="literal" namespace="urn:UserService"/></output>
</operation>
<operation name="Add">
<soap:operation soapAction="urn:UserService/UserServiceAdd"/>
<input><soap:body use="literal" namespace="urn:UserService"/></input>
<output><soap:body use="literal" namespace="urn:UserService"/></output>
</operation>
<operation name="Update">
<soap:operation soapAction="urn:UserService/UserServiceUpdate"/>
<input><soap:body use="literal" namespace="urn:UserService"/></input>
<output><soap:body use="literal" namespace="urn:UserService"/></output>
</operation>
<operation name="Find">
<soap:operation soapAction="urn:UserService/UserServiceFind"/>
<input><soap:body use="literal" namespace="urn:UserService"/></input>
<output><soap:body use="literal" namespace="urn:UserService"/></output>
</operation>
<operation name="Delete">
<soap:operation soapAction="urn:UserService/UserServiceDelete"/>
<input><soap:body use="literal" namespace="urn:UserService"/></input>
<output><soap:body use="literal" namespace="urn:UserService"/></output>
</operation>
</binding>
<service name="UserService">
<port name="UserServicePort" binding="tns:UserServiceBinding"><soap:address location="http://127.0.0.1:8000/services/UserService"/></port>
</service>
</definitions>

75
wst/tags/0.4/samples/user_service_intf_.pas Normal file
View File

@ -0,0 +1,75 @@
unit user_service_intf;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, base_service_intf;
type
TUserCategory = ( Normal, Admin );
{ TUser }
TUser = class(TBaseComplexRemotable)
private
FCategory: TUserCategory;
FeMail: string;
FName: string;
FPreferences: string;
published
property Category : TUserCategory read FCategory write FCategory;
property Name : string read FName write FName;
property eMail : string read FeMail write FeMail;
property Preferences : string read FPreferences write FPreferences;
end;
{ TUserArray }
TUserArray = class(TBaseObjectArrayRemotable)
private
function GetUser(AIndex: Integer): TUser;
public
class function GetItemClass():TBaseRemotableClass;override;
Property Item[AIndex:Integer] : TUser Read GetUser;Default;
End;
UserService = interface(IInvokable)
['{101F2CA7-19FC-4A73-AA98-F13FCDA75EE1}']
function GetList():TUserArray;
procedure Add(AUser : TUser);
function Find(const AName : string):TUser;
function Delete(const AName : string):Boolean;
end;
procedure Register_user_service_intf_NameSpace();
implementation
uses metadata_repository;
procedure Register_user_service_intf_NameSpace();
begin
GetModuleMetadataMngr().SetRepositoryNameSpace('user_service_intf','urn:UserService');
end;
{ TUserArray }
function TUserArray.GetUser(AIndex: Integer): TUser;
begin
Result := GetItem(AIndex) as TUser;
end;
class function TUserArray.GetItemClass(): TBaseRemotableClass;
begin
Result := TUser;
end;
initialization
GetTypeRegistry().Register('urn:UserService',TypeInfo(TUserCategory),'TUserCategory');
GetTypeRegistry().Register('urn:UserService',TypeInfo(TUser),'TUser');
GetTypeRegistry().Register('urn:UserService',TypeInfo(TUserArray),'TUserArray');
end.

227
wst/tags/0.4/samples/user_service_intf_binder.pas Normal file
View File

@ -0,0 +1,227 @@
{
This unit has been produced by ws_helper.
Input unit name : "user_service_intf".
This unit name : "user_service_intf_binder".
Date : "02/05/2007 20:07".
}
unit user_service_intf_binder;
{$mode objfpc}{$H+}
interface
uses SysUtils, Classes, base_service_intf, server_service_intf, user_service_intf;
type
TUserService_ServiceBinder=class(TBaseServiceBinder)
Protected
procedure GetListHandler(AFormatter:IFormatterResponse);
procedure AddHandler(AFormatter:IFormatterResponse);
procedure UpdateHandler(AFormatter:IFormatterResponse);
procedure FindHandler(AFormatter:IFormatterResponse);
procedure DeleteHandler(AFormatter:IFormatterResponse);
Public
constructor Create();
End;
TUserService_ServiceBinderFactory = class(TInterfacedObject,IItemFactory)
protected
function CreateInstance():IInterface;
End;
procedure Server_service_RegisterUserServiceService();
Implementation
uses TypInfo, wst_resources_imp,metadata_repository;
{ TUserService_ServiceBinder implementation }
procedure TUserService_ServiceBinder.GetListHandler(AFormatter:IFormatterResponse);
Var
cllCntrl : ICallControl;
tmpObj : UserService;
callCtx : ICallContext;
strPrmName : string;
procName,trgName : string;
returnVal : TUserArray;
Begin
callCtx := GetCallContext();
If ( PTypeInfo(TypeInfo(TUserArray))^.Kind in [tkClass,tkInterface] ) Then
Pointer(returnVal) := Nil;
tmpObj := Self.GetFactory().CreateInstance() as UserService;
if Supports(tmpObj,ICallControl,cllCntrl) then
cllCntrl.SetCallContext(GetCallContext());
returnVal := tmpObj.GetList();
If ( PTypeInfo(TypeInfo(TUserArray))^.Kind = tkClass ) And Assigned(Pointer(returnVal)) Then
callCtx.AddObjectToFree(TObject(returnVal));
procName := AFormatter.GetCallProcedureName();
trgName := AFormatter.GetCallTarget();
AFormatter.Clear();
AFormatter.BeginCallResponse(procName,trgName);
AFormatter.Put('result',TypeInfo(TUserArray),returnVal);
AFormatter.EndCallResponse();
callCtx := Nil;
End;
procedure TUserService_ServiceBinder.AddHandler(AFormatter:IFormatterResponse);
Var
cllCntrl : ICallControl;
tmpObj : UserService;
callCtx : ICallContext;
strPrmName : string;
procName,trgName : string;
AUser : TUser;
Begin
callCtx := GetCallContext();
TObject(AUser) := Nil;
strPrmName := 'AUser'; AFormatter.Get(TypeInfo(TUser),strPrmName,AUser);
If Assigned(Pointer(AUser)) Then
callCtx.AddObjectToFree(TObject(AUser));
tmpObj := Self.GetFactory().CreateInstance() as UserService;
if Supports(tmpObj,ICallControl,cllCntrl) then
cllCntrl.SetCallContext(GetCallContext());
tmpObj.Add(AUser);
procName := AFormatter.GetCallProcedureName();
trgName := AFormatter.GetCallTarget();
AFormatter.Clear();
AFormatter.BeginCallResponse(procName,trgName);
AFormatter.EndCallResponse();
callCtx := Nil;
End;
procedure TUserService_ServiceBinder.UpdateHandler(AFormatter:IFormatterResponse);
Var
cllCntrl : ICallControl;
tmpObj : UserService;
callCtx : ICallContext;
strPrmName : string;
procName,trgName : string;
AUser : TUser;
Begin
callCtx := GetCallContext();
TObject(AUser) := Nil;
strPrmName := 'AUser'; AFormatter.Get(TypeInfo(TUser),strPrmName,AUser);
If Assigned(Pointer(AUser)) Then
callCtx.AddObjectToFree(TObject(AUser));
tmpObj := Self.GetFactory().CreateInstance() as UserService;
if Supports(tmpObj,ICallControl,cllCntrl) then
cllCntrl.SetCallContext(GetCallContext());
tmpObj.Update(AUser);
procName := AFormatter.GetCallProcedureName();
trgName := AFormatter.GetCallTarget();
AFormatter.Clear();
AFormatter.BeginCallResponse(procName,trgName);
AFormatter.EndCallResponse();
callCtx := Nil;
End;
procedure TUserService_ServiceBinder.FindHandler(AFormatter:IFormatterResponse);
Var
cllCntrl : ICallControl;
tmpObj : UserService;
callCtx : ICallContext;
strPrmName : string;
procName,trgName : string;
AName : string;
returnVal : TUser;
Begin
callCtx := GetCallContext();
TObject(returnVal) := Nil;
strPrmName := 'AName'; AFormatter.Get(TypeInfo(string),strPrmName,AName);
tmpObj := Self.GetFactory().CreateInstance() as UserService;
if Supports(tmpObj,ICallControl,cllCntrl) then
cllCntrl.SetCallContext(GetCallContext());
returnVal := tmpObj.Find(AName);
If Assigned(TObject(returnVal)) Then
callCtx.AddObjectToFree(TObject(returnVal));
procName := AFormatter.GetCallProcedureName();
trgName := AFormatter.GetCallTarget();
AFormatter.Clear();
AFormatter.BeginCallResponse(procName,trgName);
AFormatter.Put('result',TypeInfo(TUser),returnVal);
AFormatter.EndCallResponse();
callCtx := Nil;
End;
procedure TUserService_ServiceBinder.DeleteHandler(AFormatter:IFormatterResponse);
Var
cllCntrl : ICallControl;
tmpObj : UserService;
callCtx : ICallContext;
strPrmName : string;
procName,trgName : string;
AName : string;
returnVal : boolean;
Begin
callCtx := GetCallContext();
strPrmName := 'AName'; AFormatter.Get(TypeInfo(string),strPrmName,AName);
tmpObj := Self.GetFactory().CreateInstance() as UserService;
if Supports(tmpObj,ICallControl,cllCntrl) then
cllCntrl.SetCallContext(GetCallContext());
returnVal := tmpObj.Delete(AName);
procName := AFormatter.GetCallProcedureName();
trgName := AFormatter.GetCallTarget();
AFormatter.Clear();
AFormatter.BeginCallResponse(procName,trgName);
AFormatter.Put('result',TypeInfo(boolean),returnVal);
AFormatter.EndCallResponse();
callCtx := Nil;
End;
constructor TUserService_ServiceBinder.Create();
Begin
Inherited Create(GetServiceImplementationRegistry().FindFactory('UserService'));
RegisterVerbHandler('GetList',@GetListHandler);
RegisterVerbHandler('Add',@AddHandler);
RegisterVerbHandler('Update',@UpdateHandler);
RegisterVerbHandler('Find',@FindHandler);
RegisterVerbHandler('Delete',@DeleteHandler);
End;
{ TUserService_ServiceBinderFactory }
function TUserService_ServiceBinderFactory.CreateInstance():IInterface;
Begin
Result := TUserService_ServiceBinder.Create() as IInterface;
End;
procedure Server_service_RegisterUserServiceService();
Begin
GetServerServiceRegistry().Register('UserService',TUserService_ServiceBinderFactory.Create() as IItemFactory);
End;
initialization
{$IF DECLARED(Register_user_service_intf_NameSpace)}
Register_user_service_intf_NameSpace();
{$ENDIF}
{$i user_service_intf.wst}
End.

202
wst/tags/0.4/samples/user_service_intf_imp.pas Normal file
View File

@ -0,0 +1,202 @@
{
This unit has been produced by ws_helper.
Input unit name : "user_service_intf".
This unit name : "user_service_intf_imp".
Date : "30/04/2007 00:07".
}
Unit user_service_intf_imp;
{$mode objfpc}{$H+}
Interface
Uses SysUtils, Classes,
base_service_intf, server_service_intf, server_service_imputils,
user_service_intf, cursor_intf;
Type
{ TUserService_ServiceImp }
TUserService_ServiceImp=class(TBaseServiceImplementation,UserService)
Protected
function GetList():TUserArray;
procedure Add(
Const AUser : TUser
);
procedure Update(
Const AUser : TUser
);
function Find(
Const AName : string
):TUser;
function Delete(
Const AName : string
):boolean;
End;
const sDATA_FILE_NAME = 'sample.data';
procedure RegisterUserServiceImplementationFactory();
procedure SaveDataToFile(const AFileName : string);
Implementation
uses Contnrs, std_cursors, rtti_filters, imp_helper;
var
FUserList : TObjectList = nil;
FUserCursor : IObjectCursor = nil;
procedure FillArrayFromCursor(ACursor: IObjectCursor;ARes: TUserArray);
var
i, c : Integer;
begin
ACursor.Reset();
c := 0;
while ACursor.MoveNext() do begin
Inc(c);
end;
ARes.SetLength(c);
i := 0;
ACursor.Reset();
while ACursor.MoveNext() do begin
ARes[i].Assign(ACursor.GetCurrent() as TUser);
Inc(i);
end;
end;
{ TUserService_ServiceImp implementation }
function TUserService_ServiceImp.GetList():TUserArray;
var
locCrs : IObjectCursor;
srcUsr, locUsr : TUser;
Begin
Result := TUserArray.Create();
try
FillArrayFromCursor(FUserCursor.Clone() as IObjectCursor,Result);
except
FreeAndNil(Result);
raise;
end;
SaveDataToFile(sDATA_FILE_NAME);
End;
procedure TUserService_ServiceImp.Add(Const AUser : TUser);
var
locObj : TUser;
Begin
locObj := Find(AUser.UserName);
if ( locObj <> nil ) then
raise Exception.CreateFmt('Duplicated user : "%s"',[AUser.UserName]);
locObj := TUser.Create();
locObj.Assign(AUser);
FUserList.Add(locObj);
End;
procedure TUserService_ServiceImp.Update(const AUser: TUser);
var
locCrs : IObjectCursor;
Begin
locCrs := FUserCursor.Clone() as IObjectCursor;
locCrs.Reset();
locCrs := CreateCursorOn(locCrs,ParseFilter(Format('%s=%s',['UserName',QuotedStr(AUser.UserName)]),TUser));
if locCrs.MoveNext() then begin
(locCrs.GetCurrent() as TUser).Assign(AUser);
end;
end;
function TUserService_ServiceImp.Find(Const AName : string):TUser;
var
locCrs : IObjectCursor;
Begin
Result := nil;
locCrs := FUserCursor.Clone() as IObjectCursor;
locCrs.Reset();
locCrs := CreateCursorOn(locCrs,ParseFilter(Format('%s=%s',['UserName',QuotedStr(AName)]),TUser));
if locCrs.MoveNext() then begin
Result := TUser.Create();
Result.Assign(locCrs.GetCurrent() as TUser);
end;
End;
function TUserService_ServiceImp.Delete(Const AName : string):boolean;
var
locCrs : IObjectCursor;
Begin
Result := False;
locCrs := FUserCursor.Clone() as IObjectCursor;
locCrs.Reset();
locCrs := CreateCursorOn(locCrs,ParseFilter(Format('%s=%s',['UserName',QuotedStr(AName)]),TUser));
if locCrs.MoveNext() then begin
FUserList.Delete(FUserList.IndexOf(locCrs.GetCurrent() as TUser));
Result := True;
end;
End;
procedure RegisterUserServiceImplementationFactory();
Begin
GetServiceImplementationRegistry().Register('UserService',TImplementationFactory.Create(TUserService_ServiceImp) as IServiceImplementationFactory);
End;
procedure FillSampleData();
var
locUser : TUser;
begin
locUser := TUser.Create();
locUser.UserName := 'Lazarus FreePascal';
locUser.eMail := 'Lazarus@FreePascal.wst';
FUserList.Add(locUser);
locUser := TUser.Create();
locUser.UserName := 'Inoussa OUEDRAOGO';
locUser.eMail := 'sample@example.wst';
FUserList.Add(locUser);
end;
procedure FillDataFromFile(const AFileName : string);
var
objArray : TUserArray;
i : PtrInt;
obj : TUser;
begin
objArray := TUserArray.Create();
try
LoadObjectFromFile(objArray,AFileName);
FUserList.Clear();
for i := 0 to Pred(objArray.Length) do begin
obj := TUser.Create();
FUserList.Add(obj);
obj.Assign(objArray[i]);
end;
finally
FreeAndNil(objArray);
end;
end;
procedure SaveDataToFile(const AFileName : string);
var
objArray : TUserArray;
begin
objArray := TUserArray.Create();
try
FUserCursor.Reset();
FillArrayFromCursor(FUserCursor,objArray);
SaveObjectToFile(objArray,AFileName);
finally
FreeAndNil(objArray);
end;
end;
initialization
FUserList := TObjectList.Create(True);
FUserCursor := TObjectListCursor.Create(FUserList);
if FileExists(sDATA_FILE_NAME) then
FillDataFromFile(sDATA_FILE_NAME)
else
FillSampleData();
finalization
if Assigned(FUserCursor) then
SaveDataToFile(sDATA_FILE_NAME);
FUserCursor := nil;
FreeAndNil(FUserList);
end.

175
wst/tags/0.4/samples/user_service_intf_proxy.pas Normal file
View File

@ -0,0 +1,175 @@
{
This unit has been produced by ws_helper.
Input unit name : "user_service_intf".
This unit name : "user_service_intf_proxy".
Date : "6-5-07 16:06:17".
}
Unit user_service_intf_proxy;
{$IFDEF FPC} {$mode objfpc}{$H+} {$ENDIF}
Interface
Uses SysUtils, Classes, TypInfo, base_service_intf, service_intf, user_service_intf;
Type
TUserService_Proxy=class(TBaseProxy,UserService)
Protected
class function GetServiceType() : PTypeInfo;override;
function GetList():TUserArray;
procedure Add(
Const AUser : TUser
);
procedure Update(
Const AUser : TUser
);
function Find(
Const AName : string
):TUser;
function Delete(
Const AName : string
):boolean;
End;
Function wst_CreateInstance_UserService(const AFormat : string = 'SOAP:'; const ATransport : string = 'HTTP:'):UserService;
Implementation
uses wst_resources_imp, metadata_repository;
Function wst_CreateInstance_UserService(const AFormat : string; const ATransport : string):UserService;
Begin
Result := TUserService_Proxy.Create('UserService',AFormat+GetServiceDefaultFormatProperties(TypeInfo(UserService)),ATransport + 'address=' + GetServiceDefaultAddress(TypeInfo(UserService)));
End;
{ TUserService_Proxy implementation }
class function TUserService_Proxy.GetServiceType() : PTypeInfo;
begin
result := TypeInfo(UserService);
end;
function TUserService_Proxy.GetList():TUserArray;
Var
locSerializer : IFormatterClient;
strPrmName : string;
Begin
locSerializer := GetSerializer();
Try
locSerializer.BeginCall('GetList', GetTarget(),(Self as ICallContext));
locSerializer.EndCall();
MakeCall();
locSerializer.BeginCallRead((Self as ICallContext));
TObject(Result) := Nil;
strPrmName := 'result';
locSerializer.Get(TypeInfo(TUserArray), strPrmName, Result);
Finally
locSerializer.Clear();
End;
End;
procedure TUserService_Proxy.Add(
Const AUser : TUser
);
Var
locSerializer : IFormatterClient;
strPrmName : string;
Begin
locSerializer := GetSerializer();
Try
locSerializer.BeginCall('Add', GetTarget(),(Self as ICallContext));
locSerializer.Put('AUser', TypeInfo(TUser), AUser);
locSerializer.EndCall();
MakeCall();
locSerializer.BeginCallRead((Self as ICallContext));
Finally
locSerializer.Clear();
End;
End;
procedure TUserService_Proxy.Update(
Const AUser : TUser
);
Var
locSerializer : IFormatterClient;
strPrmName : string;
Begin
locSerializer := GetSerializer();
Try
locSerializer.BeginCall('Update', GetTarget(),(Self as ICallContext));
locSerializer.Put('AUser', TypeInfo(TUser), AUser);
locSerializer.EndCall();
MakeCall();
locSerializer.BeginCallRead((Self as ICallContext));
Finally
locSerializer.Clear();
End;
End;
function TUserService_Proxy.Find(
Const AName : string
):TUser;
Var
locSerializer : IFormatterClient;
strPrmName : string;
Begin
locSerializer := GetSerializer();
Try
locSerializer.BeginCall('Find', GetTarget(),(Self as ICallContext));
locSerializer.Put('AName', TypeInfo(string), AName);
locSerializer.EndCall();
MakeCall();
locSerializer.BeginCallRead((Self as ICallContext));
TObject(Result) := Nil;
strPrmName := 'result';
locSerializer.Get(TypeInfo(TUser), strPrmName, Result);
Finally
locSerializer.Clear();
End;
End;
function TUserService_Proxy.Delete(
Const AName : string
):boolean;
Var
locSerializer : IFormatterClient;
strPrmName : string;
Begin
locSerializer := GetSerializer();
Try
locSerializer.BeginCall('Delete', GetTarget(),(Self as ICallContext));
locSerializer.Put('AName', TypeInfo(string), AName);
locSerializer.EndCall();
MakeCall();
locSerializer.BeginCallRead((Self as ICallContext));
strPrmName := 'result';
locSerializer.Get(TypeInfo(boolean), strPrmName, Result);
Finally
locSerializer.Clear();
End;
End;
initialization
{$i user_service_intf.wst}
{$IF DECLARED(Register_user_service_intf_ServiceMetadata)}
Register_user_service_intf_ServiceMetadata();
{$IFEND}
End.

137
wst/tags/0.4/server_binary_formatter.pas Normal file
View File

@ -0,0 +1,137 @@
{
This file is part of the Web Service Toolkit
Copyright (c) 2006 by Inoussa OUEDRAOGO
This file is provide under modified LGPL licence
( the files COPYING.modifiedLGPL and COPYING.LGPL).
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.
}
unit server_binary_formatter;
{$INCLUDE wst.inc}
interface
uses
Classes, SysUtils, TypInfo,
base_service_intf, server_service_intf,
base_binary_formatter;
const
sBINARY_CONTENT_TYPE = 'binary';
procedure Server_service_RegisterBinaryFormat();
implementation
Type
{ TBinaryFormatter }
TBinaryFormatter = class(TBaseBinaryFormatter,IFormatterBase,IFormatterResponse)
Private
FCallProcedureName : string;
FCallTarget : string;
Protected
procedure BeginCallResponse(Const AProcName,ATarget:string);
procedure EndCallResponse();
procedure BeginCallRead(ACallContext : ICallContext);
function GetCallProcedureName():String;
function GetCallTarget():String;
procedure BeginExceptionList(
const AErrorCode : string;
const AErrorMsg : string
);
procedure EndExceptionList();
End;
{ TBinaryFormatterFactory }
TBinaryFormatterFactory = class(TInterfacedObject,IItemFactory)
protected
function CreateInstance():IInterface;
End;
{ TBinaryFormatterFactory }
function TBinaryFormatterFactory.CreateInstance(): IInterface;
begin
Result := TBinaryFormatter.Create() as IFormatterResponse;
end;
{ TBinaryFormatter }
procedure TBinaryFormatter.BeginCallResponse(const AProcName, ATarget: string);
begin
BeginObject('Body',Nil);
BeginObject(ATarget,Nil);
BeginObject(AProcName + 'Response',Nil);
end;
procedure Print(const AMsg:string);
begin
WriteLn(AMsg);
End;
procedure TBinaryFormatter.EndCallResponse();
begin
EndScope();
EndScope();
EndScope();
//PrintObj(GetRootData(),0,@Print);
end;
procedure TBinaryFormatter.BeginCallRead(ACallContext : ICallContext);
Var
s : string;
begin
ClearStack();
PushStack(GetRootData(),stObject);
s := 'Body';
BeginObjectRead(s,nil);
FCallTarget := StackTop().GetByIndex(0)^.Name;
BeginObjectRead(FCallTarget,nil);
FCallProcedureName := StackTop().GetByIndex(0)^.Name;
BeginObjectRead(FCallProcedureName,nil);
end;
function TBinaryFormatter.GetCallProcedureName(): String;
begin
Result := FCallProcedureName;
end;
function TBinaryFormatter.GetCallTarget(): String;
begin
Result := FCallTarget;
end;
procedure TBinaryFormatter.BeginExceptionList(
const AErrorCode: string;
const AErrorMsg: string
);
begin
BeginObject('Body',Nil);
BeginObject('Fault',Nil);
Put('faultcode',TypeInfo(string),AErrorCode);
Put('faultstring',TypeInfo(string),AErrorMsg);
end;
procedure TBinaryFormatter.EndExceptionList();
begin
EndScope();
EndScope();
end;
procedure Server_service_RegisterBinaryFormat();
begin
GetFormatterRegistry().Register(sBINARY_CONTENT_TYPE,TBinaryFormatterFactory.Create() as IItemFactory);
end;
Initialization
end.

105
wst/tags/0.4/server_service_imputils.pas Normal file
View File

@ -0,0 +1,105 @@
{
This file is part of the Web Service Toolkit
Copyright (c) 2006 by Inoussa OUEDRAOGO
This file is provide under modified LGPL licence
( the files COPYING.modifiedLGPL and COPYING.LGPL).
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.
}
unit server_service_imputils;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, TypInfo,
server_service_intf;
Type
{ TRequestBuffer }
TRequestBuffer = class(TInterfacedObject,IRequestBuffer)
private
FTargetService : string;
FContentType : string;
//FLength : Integer;
FContent : TStream;
FResponse : TStream;
protected
function GetTargetService():string;
function GetContentType():string;
//function GetLength():Integer;
function GetContent():TStream;
function GetResponse():TStream;
public
constructor Create(
ATargetService : string;
AContentType : string;
//ALength : Integer;
AContent : TStream;
AResponse : TStream
);
End;
function IsStrEmpty(Const AStr:String):Boolean;
implementation
function IsStrEmpty(Const AStr:String):Boolean;
begin
Result := ( Length(Trim(AStr)) = 0 );
end;
{ TRequestBuffer }
function TRequestBuffer.GetTargetService(): string;
begin
Result := FTargetService;
end;
function TRequestBuffer.GetContentType(): string;
begin
Result := FContentType;
end;
{function TRequestBuffer.GetLength(): Integer;
begin
Result := FLength;
end;}
function TRequestBuffer.GetContent(): TStream;
begin
Result := FContent;
end;
function TRequestBuffer.GetResponse(): TStream;
begin
Result := FResponse;
end;
constructor TRequestBuffer.Create(
ATargetService : string;
AContentType : string;
//ALength : Integer;
AContent : TStream;
AResponse : TStream
);
begin
FTargetService := ATargetService;
FContentType := AContentType;
//FLength := ALength;
FContent := AContent;
FResponse := AResponse;
end;
end.

635
wst/tags/0.4/server_service_intf.pas Normal file
View File

@ -0,0 +1,635 @@
{
This file is part of the Web Service Toolkit
Copyright (c) 2006 by Inoussa OUEDRAOGO
This file is provide under modified LGPL licence
( the files COPYING.modifiedLGPL and COPYING.LGPL).
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.
}
unit server_service_intf;
{$INCLUDE wst.inc}
interface
uses
Classes, SysUtils, TypInfo, Contnrs,
base_service_intf;
Type
IRequestBuffer = interface;
IServerService = interface;
IServerServiceRegistry = interface;
IFormatterResponse = interface;
IServiceImplementationRegistry = interface;
IServiceImplementationFactory = interface;
ICallControl = interface;
IServiceExtension = interface;
IServiceExtensionRegistry = interface;
ICallControl = interface
['{7B4B7192-EE96-4B52-92C7-AE855FBC31E7}']
procedure SetCallContext(ACallContext : ICallContext);
function GetCallContext():ICallContext;
end;
IRequestBuffer = interface
['{6BF71D1F-DDC0-4432-83C6-6D50D26762C3}']
function GetTargetService():string;
function GetContentType():string;
//function GetLength():Integer;
function GetContent():TStream;
function GetResponse():TStream;
End;
IServerService = Interface
['{EEBF8E24-8B20-462F-AA4A-48A5C8BAE680}']
procedure HandleRequest(ARequestBuffer : IRequestBuffer);
End;
TMessageStage = (
msAfterDeserialize, msAfterSerialize, msBeforeDeserialize, msBeforeSerialize
);
IServiceExtension = interface
['{E192E6B3-7932-4D44-A8AC-135D7A0B8C93}']
procedure ProcessMessage(
const AMessageStage : TMessageStage;
ACallContext : ICallContext;
AMsgData : IInterface
{ The "AMsgData" parameter actual type depends on the message state
on correspond to :
- IRequestBuffer on "msBeforeDeserialize" and "msAfterSerialize"
- IFormatterResponse on "msAfterDeserialize", "msBeforeSerialize"
}
);
end;
IServiceExtensionRegistry = Interface
['{68DC78F1-E6CF-4D6B-8473-75288794769C}']
function Find(const AName : string):IServiceExtension;
procedure Register(
const AName : string;
AFactory : IItemFactory
);
end;
IServerServiceRegistry = Interface
['{83E7BBEB-A33D-4A3E-896D-D351C2819009}']
function Find(const AServiceName : string):IServerService;
procedure Register(
const AServiceName : string;
AFactory : IItemFactory
);
End;
IServiceImplementationFactory = interface(IItemFactoryEx)
['{23A745BC-5F63-404D-BF53-55A6E64DE5BE}']
procedure RegisterExtension(
const AExtensionList : array of string
);
function GetExtension(
out AExtensionList : string
) : Boolean;
end;
IServiceImplementationRegistry = Interface
['{0AE04033-475E-4FD5-88BD-9F816FD53A97}']
function FindFactory(const AServiceName : string):IServiceImplementationFactory;
function Register(
const AServiceName : string;
AFactory : IServiceImplementationFactory
) : IServiceImplementationFactory;
End;
IFormatterResponse = Interface(IFormatterBase)
['{CA7538D4-2C16-48C2-9F39-ACE45FEBB27E}']
procedure BeginCallResponse(Const AProcName,ATarget:string);
procedure EndCallResponse();
procedure BeginCallRead(ACallContext : ICallContext);
function GetCallProcedureName():String;
function GetCallTarget():String;
procedure BeginExceptionList(
const AErrorCode : string;
const AErrorMsg : string
);
procedure EndExceptionList();
End;
TServiceVerbMethod = procedure(AFormatter:IFormatterResponse) of object;
{ TBaseServiceBinder }
TBaseServiceBinder = Class(TInterfacedObject,IServerService)
Private
FVerbList : TObjectList;
FImplementationFactory : IServiceImplementationFactory;
FCallContext : ICallContext;
Protected
procedure RegisterVerbHandler(
const AVerb : string;
AVerbHandler : TServiceVerbMethod
);
function FindVerbHandler(const AVerb : string):TServiceVerbMethod;
procedure HandleRequest(ARequestBuffer : IRequestBuffer);
function GetFactory():IItemFactory;
function CreateCallContext():ICallContext;virtual;
function GetCallContext():ICallContext;
procedure DoProcessMessage(
const AMessageStage : TMessageStage;
ACallContext : ICallContext;
AMsgData : IInterface
);
Public
constructor Create(AImplementationFactory : IServiceImplementationFactory);
destructor Destroy();override;
procedure Error(Const AMsg : string);overload;
procedure Error(Const AMsg : string;Const AArgs : Array of Const);overload;
End;
{ TBaseServiceImplementation }
TBaseServiceImplementation = class(TSimpleFactoryItem,ICallControl)
private
FCallContext : ICallContext;
protected
procedure SetCallContext(ACallContext : ICallContext);
function GetCallContext():ICallContext;
End;
{ TImplementationFactory }
TImplementationFactory = class(
TSimpleItemFactoryEx,
IInterface,
IItemFactory,
IItemFactoryEx,
IServiceImplementationFactory
)
protected
procedure RegisterExtension(
const AExtensionList : array of string
);
function GetExtension(
out AExtensionList : string
) : Boolean;
end;
procedure HandleServiceRequest(
ARequestBuffer : IRequestBuffer;
AServiceRegistry : IServerServiceRegistry = Nil
);
function GetFormatterRegistry():IFormatterRegistry;
function GetServerServiceRegistry():IServerServiceRegistry;
function GetServiceImplementationRegistry():IServiceImplementationRegistry ;
function GetServiceExtensionRegistry():IServiceExtensionRegistry;
implementation
Var
FormatterRegistryInst : IFormatterRegistry = Nil;
ServerServiceRegistryInst : IServerServiceRegistry = Nil;
ServiceImplementationRegistryInst : IServiceImplementationRegistry = Nil;
ServiceExtensionRegistryInst : IServiceExtensionRegistry = nil;
procedure HandleServiceRequest(
ARequestBuffer : IRequestBuffer;
AServiceRegistry : IServerServiceRegistry
);
Var
sr : IServerServiceRegistry;
s : IServerService;
svcName : string;
Begin
Assert(Assigned(ARequestBuffer));
If Assigned(AServiceRegistry) Then
sr := AServiceRegistry
Else
sr := GetServerServiceRegistry();
svcName := ARequestBuffer.GetTargetService();
s := sr.Find(svcName);
If Not Assigned(s) Then
Raise EServiceException.CreateFmt('Service not found : "%s"',[svcName]);
s.HandleRequest(ARequestBuffer);
End;
Type
TFormatterRegistry = class(TBaseFactoryRegistry,IFormatterRegistry)
protected
function Find(const AFormatterName : string):IFormatterBase;
End;
{ TServerServiceRegistry }
TServerServiceRegistry = class(TBaseFactoryRegistry,IServerServiceRegistry)
protected
function Find(const AServiceName : string):IServerService;
End;
{ TServerServiceRegistry }
function TServerServiceRegistry.Find(const AServiceName: string): IServerService;
Var
fct : IItemFactory;
begin
fct := FindFactory(AServiceName);
If Assigned(fct) Then
Result := fct.CreateInstance() as IServerService
Else
Result := Nil;
end;
function TFormatterRegistry.Find(const AFormatterName: string): IFormatterBase;
Var
fct : IItemFactory;
begin
fct := FindFactory(AFormatterName);
If Assigned(fct) Then
Result := fct.CreateInstance() as IFormatterBase
Else
Result := Nil;
end;
Type
{ TServiceVerbItem }
TServiceVerbItem = class
private
FVerb: string;
FVerbHandler: TServiceVerbMethod;
public
constructor Create(
const AVerb : string;
AVerbHandler : TServiceVerbMethod
);
property Verb : string Read FVerb;
property VerbHandler : TServiceVerbMethod Read FVerbHandler;
End;
{ TServiceVerbItem }
constructor TServiceVerbItem.Create(
const AVerb: string;
AVerbHandler: TServiceVerbMethod
);
begin
FVerb := AVerb;
FVerbHandler := AVerbHandler;
end;
{ TBaseServiceBinder }
procedure TBaseServiceBinder.RegisterVerbHandler(
const AVerb : string;
AVerbHandler : TServiceVerbMethod
);
Var
s : string;
begin
Assert(Assigned(AVerbHandler));
s := LowerCase(Trim(AVerb));
If Not Assigned(FindVerbHandler(s)) Then
FVerbList.Add(TServiceVerbItem.Create(s,AVerbHandler));
end;
function TBaseServiceBinder.FindVerbHandler(const AVerb: string):TServiceVerbMethod;
Var
i : Integer;
s : string;
begin
s := LowerCase(Trim(AVerb));
For i := 0 To Pred(FVerbList.Count) Do Begin
If AnsiSameText(TServiceVerbItem(FVerbList[i]).Verb,s) Then Begin
Result := TServiceVerbItem(FVerbList[i]).VerbHandler;
Exit;
End;
End;
Result := Nil;
end;
procedure TBaseServiceBinder.HandleRequest(ARequestBuffer: IRequestBuffer);
Var
f : IFormatterResponse;
s : string;
m : TServiceVerbMethod;
strm : TStream;
cllCtx : ICallContext;
i : Integer;
hdr : THeaderBlock;
typRegItm : TTypeRegistryItem;
begin
s := ARequestBuffer.GetContentType();
f := GetFormatterRegistry().Find(s) as IFormatterResponse;
if not Assigned(f) then
Error('No formatter for that content type : "%s"',[s]);
try
cllCtx := GetCallContext();
DoProcessMessage(msBeforeDeserialize,cllCtx,ARequestBuffer);
strm := ARequestBuffer.GetContent();
f.LoadFromStream(strm);
f.BeginCallRead(GetCallContext());
DoProcessMessage(msAfterDeserialize,cllCtx,f);
s := f.GetCallProcedureName();
m := FindVerbHandler(s);
if not Assigned(m) then
Error('No handler for that verb : "%s"',[s]);
m(f);
for i := 0 to Pred(cllCtx.GetHeaderCount(AllHeaderDirection)) do begin
hdr := cllCtx.GetHeader(i);
if ( hdr.Direction = hdIn ) and ( hdr.mustUnderstand <> 0 ) and ( not hdr.Understood ) then begin
typRegItm := GetTypeRegistry().Find(hdr.ClassName);
if Assigned(typRegItm) then
s := typRegItm.DeclaredName
else
s := hdr.ClassName;
Error('Header "%s" not Understood.',[s]);
end;
end;
except
on e : Exception do begin
f.Clear();
f.SetSerializationStyle(ssNodeSerialization);
f.BeginExceptionList('Server',E.Message);
f.EndExceptionList();
end;
end;
strm := ARequestBuffer.GetResponse();
DoProcessMessage(msBeforeSerialize,cllCtx,f);
f.SaveToStream(strm);
DoProcessMessage(msAfterSerialize,cllCtx,ARequestBuffer);
end;
function TBaseServiceBinder.GetFactory(): IItemFactory;
begin
Result := FImplementationFactory;
end;
function TBaseServiceBinder.CreateCallContext(): ICallContext;
begin
if not Assigned(FCallContext) then
FCallContext := TSimpleCallContext.Create() as ICallContext;
Result := FCallContext;
end;
function TBaseServiceBinder.GetCallContext(): ICallContext;
begin
if not Assigned(FCallContext) then
CreateCallContext();
Result := FCallContext;
end;
procedure TBaseServiceBinder.DoProcessMessage(
const AMessageStage : TMessageStage;
ACallContext : ICallContext;
AMsgData : IInterface
);
var
s : string;
ls : TStringList;
i : Integer;
exreg : IServiceExtensionRegistry;
se : IServiceExtension;
begin
exreg := GetServiceExtensionRegistry();
if FImplementationFactory.GetExtension(s) then begin
ls := TStringList.Create();
try
ls.QuoteChar := #0;
ls.Delimiter := PROP_LIST_DELIMITER;
ls.DelimitedText := s;
for i := 0 to Pred(ls.Count) do begin
s := ls[i];
se := exreg.Find(s);
if Assigned(se) then
se.ProcessMessage(AMessageStage,ACallContext,AMsgData);
end;
finally
ls.Free();
end;
end;
end;
constructor TBaseServiceBinder.Create(AImplementationFactory : IServiceImplementationFactory);
begin
Assert(Assigned(AImplementationFactory));
FImplementationFactory := AImplementationFactory;
FVerbList := TObjectList.Create(True);
end;
destructor TBaseServiceBinder.Destroy();
begin
FVerbList.Free();
inherited Destroy();
end;
procedure TBaseServiceBinder.Error(const AMsg: string);
begin
Raise EServiceException.Create(AMsg);
end;
procedure TBaseServiceBinder.Error(const AMsg: string;const AArgs: array of const);
begin
Raise EServiceException.CreateFmt(AMsg,AArgs);
end;
function GetFormatterRegistry():IFormatterRegistry;
begin
Result := FormatterRegistryInst;
end;
function GetServerServiceRegistry():IServerServiceRegistry;
begin
Result := ServerServiceRegistryInst;
end;
Type
{ TServiceImplementationRegistry }
TServiceImplementationRegistry = class(TInterfacedObject,IInterface,IServiceImplementationRegistry)
private
FList : TObjectList;
protected
function FindFactory(const AServiceName : string): IServiceImplementationFactory;
function Register(
const AServiceName : string;
AFactory : IServiceImplementationFactory
) : IServiceImplementationFactory;
public
constructor Create();
destructor Destroy();override;
End;
{ TServiceImplementationRegistryItem }
TServiceImplementationRegistryItem = class
private
FFactory: IServiceImplementationFactory;
FItemTypeInfo: string;
public
constructor Create(
const AItemTypeInfo : string;
AFactory : IServiceImplementationFactory
);
property ItemTypeInfo : string Read FItemTypeInfo;
property Factory : IServiceImplementationFactory Read FFactory;
End;
function TServiceImplementationRegistry.FindFactory(
const AServiceName : string
): IServiceImplementationFactory;
Var
i : Integer;
begin
For i := 0 To Pred(FList.Count) Do Begin
If ( AServiceName = TServiceImplementationRegistryItem(FList[i]).ItemTypeInfo ) Then Begin
Result := TServiceImplementationRegistryItem(FList[i]).Factory;
Exit;
End;
End;
Result := Nil;
end;
function TServiceImplementationRegistry.Register(
const AServiceName : string;
AFactory : IServiceImplementationFactory
) : IServiceImplementationFactory;
begin
Assert(Assigned(AFactory));
if not Assigned(FindFactory(AServiceName)) then
FList.Add(TServiceImplementationRegistryItem.Create(AServiceName,AFactory));
Result := AFactory;
end;
constructor TServiceImplementationRegistry.Create();
begin
FList := TObjectList.Create(True);
inherited Create();
end;
destructor TServiceImplementationRegistry.Destroy();
begin
FreeAndNil(FList);
inherited Destroy();
end;
{ TServiceImplementationRegistryItem }
constructor TServiceImplementationRegistryItem.Create(
const AItemTypeInfo: string;
AFactory: IServiceImplementationFactory
);
begin
Assert(Assigned(AFactory));
FItemTypeInfo := AItemTypeInfo;
FFactory := AFactory;
end;
function GetServiceImplementationRegistry():IServiceImplementationRegistry ;
begin
Result := ServiceImplementationRegistryInst;
end;
{ TBaseServiceImplementation }
procedure TBaseServiceImplementation.SetCallContext(ACallContext: ICallContext);
begin
FCallContext := ACallContext;
end;
function TBaseServiceImplementation.GetCallContext(): ICallContext;
begin
Result := FCallContext;
end;
{ TImplementationFactory }
const sSERVICES_EXTENSIONS = 'extensions';sLIST = 'list';
procedure TImplementationFactory.RegisterExtension(
const AExtensionList : array of string
);
var
pmngr : IPropertyManager;
i : Integer;
strBuffer, s : string;
begin
if ( Length(AExtensionList) > 0 ) then begin
pmngr := GetPropertyManager(sSERVICES_EXTENSIONS,True);
strBuffer := '';
for i := Low(AExtensionList) to High(AExtensionList) do begin
s := Trim(AExtensionList[i]);
if ( Length(s) > 0 ) then
strBuffer := strBuffer + ';' + s;
end;
if ( Length(strBuffer) > 0 ) then begin
s:= Trim(pmngr.GetProperty(sLIST));
if ( Length(s) = 0 ) then
Delete(strBuffer,1,1);
s := s + strBuffer;
pmngr.SetProperty(sLIST,s);
end;
end;
end;
function TImplementationFactory.GetExtension(
out AExtensionList : string
): Boolean;
var
pmngr : IPropertyManager;
begin
pmngr := GetPropertyManager(sSERVICES_EXTENSIONS,False);
if Assigned(pmngr) then
AExtensionList := Trim(pmngr.GetProperty(sLIST))
else
AExtensionList := '';
Result := ( Length(AExtensionList) > 0 );
end;
type
{ TServiceExtensionRegistry }
TServiceExtensionRegistry = class(TBaseFactoryRegistry,IServiceExtensionRegistry)
protected
function Find(const AName : string):IServiceExtension;
End;
{ TServiceExtensionRegistry }
function TServiceExtensionRegistry.Find(const AName: string): IServiceExtension;
Var
fct : IItemFactory;
begin
fct := FindFactory(AName);
If Assigned(fct) Then
Result := fct.CreateInstance() as IServiceExtension
Else
Result := Nil;
end;
function GetServiceExtensionRegistry():IServiceExtensionRegistry ;
begin
Result := ServiceExtensionRegistryInst;
end;
Initialization
FormatterRegistryInst := TFormatterRegistry.Create() as IFormatterRegistry;
ServerServiceRegistryInst := TServerServiceRegistry.Create() as IServerServiceRegistry;
ServiceImplementationRegistryInst := TServiceImplementationRegistry.Create() As IServiceImplementationRegistry;
ServiceExtensionRegistryInst := TServiceExtensionRegistry.Create() as IServiceExtensionRegistry;
Finalization
ServiceExtensionRegistryInst := nil;
ServiceImplementationRegistryInst := Nil;
ServerServiceRegistryInst := Nil;
FormatterRegistryInst := Nil;
end.

201
wst/tags/0.4/server_service_soap.pas Normal file
View File

@ -0,0 +1,201 @@
{
This file is part of the Web Service Toolkit
Copyright (c) 2006 by Inoussa OUEDRAOGO
This file is provide under modified LGPL licence
( the files COPYING.modifiedLGPL and COPYING.LGPL).
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.
}
unit server_service_soap;
{$INCLUDE wst.inc}
interface
uses
Classes, SysUtils, TypInfo, DOM,
base_service_intf, server_service_intf, server_service_imputils,
base_soap_formatter;
Type
{ TSOAPFormatter }
{$M+}
TSOAPFormatter = class(TSOAPBaseFormatter,IFormatterBase,IFormatterResponse)
private
FCallProcedureName : string;
FCallTarget : String;
FCallContext : ICallContext;
public
procedure BeginCallResponse(Const AProcName,ATarget:string);
procedure EndCallResponse();
procedure BeginCallRead(ACallContext : ICallContext);
function GetCallProcedureName():String;
function GetCallTarget():String;
procedure BeginExceptionList(
const AErrorCode : string;
const AErrorMsg : string
);
procedure EndExceptionList();
End;
procedure Server_service_RegisterSoapFormat();
implementation
Const NAMESPACE_SEPARATOR = ':';
function ExtractNamespacePart( Const AQualifiedName : string):String;
Var
i : Integer;
begin
Result := '';
i := Pos(NAMESPACE_SEPARATOR,AQualifiedName);
If ( i <= 0 ) Then
Exit;
Result := Copy(AQualifiedName,1,Pred(i));
end;
function ExtractNamePart(Const AQualifiedName : string):String;
Var
i : Integer;
begin
i := Pos(NAMESPACE_SEPARATOR,AQualifiedName);
If ( i <= 0 ) Then
i := 0;
Result := Copy(AQualifiedName,Succ(i),MaxInt);
end;
{ TSOAPFormatter }
procedure TSOAPFormatter.BeginCallResponse(Const AProcName,ATarget:string);
begin
Clear();
Prepare();
WriteHeaders(FCallContext);
BeginScope('Body',sSOAP_ENV,'',stObject,asNone);
BeginScope(AProcName + 'Response',ATarget,'',stObject,asNone);
end;
procedure TSOAPFormatter.EndCallResponse();
begin
EndScope(); //BeginScope(AProcName,ATarget);
EndScope(); //BeginScope('Body','http://schemas.xmlsoap.org/soap/envelope/');
EndScope(); //BeginScope('Envelope','http://schemas.xmlsoap.org/soap/envelope/','SOAP-ENV');
end;
procedure TSOAPFormatter.BeginCallRead(ACallContext : ICallContext);
Var
envNd : TDOMElement;
hdrNd, bdyNd, mthdNd, tmpNode : TDOMNode;
s,nsShortName,eltName : string;
doc : TXMLDocument;
begin
FCallContext := ACallContext;
ClearStack();
doc := GetXmlDoc();
If FindAttributeByValueInNode(sSOAP_ENV,doc.DocumentElement,nsShortName) Then Begin
nsShortName := Copy(nsShortName,1 + Pos(':',nsShortName),MaxInt);
If Not IsStrEmpty(nsShortName) Then
nsShortName := nsShortName + ':';
End Else
nsShortName := '';
eltName := nsShortName + 'Envelope';
envNd := doc.DocumentElement;
If Not SameText(eltName,envNd.NodeName) Then
Error('XML root node must be "Envelope".');
PushStack(envNd).SetNameSpace(sSOAP_ENV);
bdyNd := envNd.FirstChild;
If Not Assigned(bdyNd) Then
Error('Node not found : "Body".');
eltName := nsShortName + 'Body';
if not SameText(bdyNd.NodeName,eltName) then begin
eltName := nsShortName + 'Header';
hdrNd := bdyNd;
bdyNd := hdrNd.NextSibling;
if SameText(hdrNd.NodeName,eltName) then begin
PushStack(hdrNd,asScoped,'').SetNameSpace(sSOAP_ENV);
ReadHeaders(FCallContext);
PopStack().Free();
end;
end;
eltName := nsShortName + 'Body';
If Not Assigned(bdyNd) Then
Error('Node not found : "Body".');
PushStack(bdyNd).SetNameSpace(sSOAP_ENV);
If Not Assigned(bdyNd.FirstChild) Then
Error('Method Node not found.');
mthdNd := bdyNd.FirstChild;
PushStack(mthdNd);
s := mthdNd.NodeName;
nsShortName := ExtractNamespacePart(s);
If IsStrEmpty(nsShortName) Then
Error('Method Node must have a qualified name.');
FCallProcedureName := ExtractNamePart(s);
If IsStrEmpty(FCallProcedureName) Then
Error('No Method name.');
tmpNode := mthdNd.Attributes.GetNamedItem(sXML_NS + ':' + nsShortName);
If Not Assigned(tmpNode) Then
Error('Call target attribute not found.');
FCallTarget := tmpNode.NodeValue;
end;
function TSOAPFormatter.GetCallProcedureName(): String;
begin
Result := FCallProcedureName;
end;
function TSOAPFormatter.GetCallTarget(): String;
begin
Result := FCallTarget;
end;
procedure TSOAPFormatter.BeginExceptionList(
const AErrorCode: string;
const AErrorMsg: string
);
Var
c,m :string;
begin
If IsStrEmpty(AErrorCode) Then
c := 'SOAP-ENV:Server'
Else
c := AErrorCode;
If IsStrEmpty(AErrorMsg) Then
m := 'Server Error'
Else
m := AErrorMsg;
Clear();
BeginScope('Envelope',sSOAP_ENV,'SOAP-ENV',stObject,asNone);
AddScopeAttribute('xmlns:xsi',sXSI_NS);
AddScopeAttribute('xmlns:'+sXSD, sXSD_NS);
BeginScope('Body',sSOAP_ENV,'',stObject,asNone);
BeginScope('Fault',sSOAP_ENV,'',stObject,asNone);
Put('faultcode',TypeInfo(string),c);
Put('faultstring',TypeInfo(string),m);
end;
procedure TSOAPFormatter.EndExceptionList();
begin
EndScope(); //BeginScope('Fault',sSOAP_ENV);
EndScope(); //BeginScope('Body','http://schemas.xmlsoap.org/soap/envelope/');
EndScope(); //BeginScope('Envelope','http://schemas.xmlsoap.org/soap/envelope/','SOAP-ENV');
end;
procedure Server_service_RegisterSoapFormat();
begin
GetFormatterRegistry().Register(sSOAP_CONTENT_TYPE,TSimpleItemFactory.Create(TSOAPFormatter) as IItemFactory);
RegisterStdTypes();
end;
end.

594
wst/tags/0.4/service_intf.pas Normal file
View File

@ -0,0 +1,594 @@
{
This file is part of the Web Service Toolkit
Copyright (c) 2006 by Inoussa OUEDRAOGO
This file is provide under modified LGPL licence
( the files COPYING.modifiedLGPL and COPYING.LGPL).
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.
}
{ Base service interface }
unit service_intf;
interface
uses
Classes, SysUtils, TypInfo, Contnrs,
base_service_intf;
{$INCLUDE wst.inc}
Const
sTARGET = 'target';
Type
ITransport = Interface
['{AEB6677A-9620-4E7D-82A0-43E3C4C52B43}']
function GetPropertyManager():IPropertyManager;
procedure SendAndReceive(ARequest,AResponse:TStream);
End;
//The client formater interface, used to marshall parameters.
IFormatterClient = Interface(IFormatterBase)
['{73746BC7-CA43-4C00-8789-71E23033C3B2}']
function GetPropertyManager():IPropertyManager;
procedure BeginCall(
const AProcName,
ATarget : string;
ACallContext : ICallContext
);
procedure EndCall();
procedure BeginCallRead(ACallContext : ICallContext);
function GetCallProcedureName():String;
function GetCallTarget():String;
End;
(* This interface is used with IFormatterClient to handle messages *)
ICallMaker = Interface
['{4CF7B98B-8C37-479F-AFF3-822FCCEECEC8}']
function GetPropertyManager():IPropertyManager;
procedure MakeCall(
ASerializer : IFormatterClient;
ATransport : ITransport
);
End;
(* A service protocol is defined by :
- a marshaller
- a call handler for that marshaller
- and a tranport. *)
IServiceProtocol = Interface
['{777FE102-0F6C-495C-9A92-528D07F1C60C}']
function GetSerializer() : IFormatterClient; // the marshaller >> SOAP, XML-RPC, Binary,...
function GetCallHandler() : ICallMaker; // Call handler >> SOAP call handler, XML-RPC call handler, ...
function GetTransport() : ITransport; // the transport >> HTTP, TCP, named pipes, ...
procedure SetTransport(AValue : ITransport);
End;
{ TBaseProxy }
(* The base class for service proxy *)
TBaseProxy = Class(TInterfacedObject,IInterface,ICallContext)
private
FTarget : String;
FProtocol : IServiceProtocol;
FOperationsProperties : TStrings;
private
procedure LoadProperties();
protected
function GetTarget():String;
function GetSerializer() : IFormatterClient;
function GetCallHandler() : ICallMaker;
function GetTransport() : ITransport;
procedure MakeCall();
class function GetServiceType() : PTypeInfo;virtual;abstract;
// ---- BEGIN >> ICallContext implementation ----
private
FCallContext : ICallContext;
protected
procedure AddObjectToFree(const AObject : TObject);
procedure Clear();
function AddHeader(
const AHeader : THeaderBlock;
const AKeepOwnership : Boolean
):Integer;
function GetHeaderCount(const ADirections : THeaderDirections):Integer;
function GetHeader(const AIndex : Integer) : THeaderBlock;
// ---- END >> ICallContext implementation ----
procedure ClearHeaders(const ADirection : THeaderDirection);
public
(* This is the primary constructor! *)
constructor Create(
Const ATarget : String; // the target service
Const AProtocol : IServiceProtocol
);overload;virtual;
(* A User friendly constructor *)
constructor Create(
Const ATarget : String;
Const AProtocolData : string;
Const ATransportData : string
);overload;virtual;
destructor Destroy();override;
End;
IFormaterQueryRegistry = Interface
['{037907E1-5E44-4A91-B290-CA70ACACF5E6}']
function Find(
Const AProtocolData : string;
Out ARes : IServiceProtocol
):Boolean;
procedure Register(
Const AProtocolName : string;
AFormaterFactory : IItemFactory;
ACallHandlerFactory : IItemFactory
);
End;
ITransportRegistry = Interface
['{ED34F7A2-2335-4FD3-A457-2B8C4349664E}']
function Find(
Const ATransportData : string;
Out ARes : ITransport
):Boolean;
procedure Register(
const ATransportName : string;
AFactory : IItemFactory
);
End;
function GetFormaterRegistry():IFormaterQueryRegistry;
function GetTransportRegistry():ITransportRegistry;
implementation
uses imp_utils, metadata_repository;
{ TBaseProxy }
procedure TBaseProxy.LoadProperties();
var
pd : PPropertyData;
i : Integer;
sd : PService;
opd : PServiceOperation;
mm : IModuleMetadataMngr;
strTransportBuffer, strFormatBuffer, strName : string;
begin
if not Assigned(FOperationsProperties) then begin
FOperationsProperties := TStringList.Create();
mm := GetModuleMetadataMngr();
sd := mm.GetServiceMetadata(GetTypeData(GetServiceType())^.IntfUnit,GetServiceType()^.Name);
try
Assert(Assigned(sd));
opd := sd^.Operations;
for i := 0 to Pred(sd^.OperationsCount) do begin
strFormatBuffer := '';
strTransportBuffer := '';
pd := opd^.Properties;
while Assigned(pd) do begin
strName := ExtractOptionName(pd^.Name);
if ( AnsiPos(sFORMAT + '_',pd^.Name) = 1 ) then begin
if ( Length(strName) > 0 ) then begin
strFormatBuffer := Format('%s%s=%s;',[strFormatBuffer,strName,pd^.Data]);
end;
end else if ( AnsiPos(sTRANSPORT + '_',pd^.Name) = 1 ) then begin
if ( Length(strName) > 0 ) then begin
strTransportBuffer := Format('%s%s=%s;',[strTransportBuffer,strName,pd^.Data]);
end;
end;
pd := pd^.Next;
end;
if not IsStrEmpty(strFormatBuffer) then begin
Delete(strFormatBuffer,Length(strFormatBuffer),1);
FOperationsProperties.Values[opd^.Name + '_' + sFORMAT] := strFormatBuffer;
end;
if not IsStrEmpty(strTransportBuffer) then begin
Delete(strTransportBuffer,Length(strTransportBuffer),1);
FOperationsProperties.Values[opd^.Name + '_' + sTRANSPORT] := strTransportBuffer;
end;
Inc(opd);
end;
finally
mm.ClearServiceMetadata(sd);
end;
end;
end;
function TBaseProxy.GetTarget(): String;
begin
Result := FTarget;
end;
function TBaseProxy.GetSerializer(): IFormatterClient;
begin
Result := FProtocol.GetSerializer();
end;
function TBaseProxy.GetCallHandler(): ICallMaker;
begin
Result := FProtocol.GetCallHandler();
end;
function TBaseProxy.GetTransport(): ITransport;
begin
Result := FProtocol.GetTransport();
end;
procedure TBaseProxy.MakeCall();
var
trans : ITransport;
frmt : IFormatterClient;
procedure PrepareCall();
var
strBuffer, strName : string;
begin
LoadProperties();
strName := frmt.GetCallProcedureName() + '_';
strBuffer := FOperationsProperties.Values[strName + sTRANSPORT];
if not IsStrEmpty(strBuffer) then
trans.GetPropertyManager().SetProperties(strBuffer);
strBuffer := FOperationsProperties.Values[strName + sFORMAT];
if not IsStrEmpty(strBuffer) then
frmt.GetPropertyManager().SetProperties(strBuffer);
end;
begin
trans := GetTransport();
frmt := GetSerializer();
PrepareCall();
GetCallHandler().MakeCall(frmt,trans);
end;
procedure TBaseProxy.AddObjectToFree(const AObject: TObject);
begin
FCallContext.AddObjectToFree(AObject);
end;
procedure TBaseProxy.Clear();
begin
FCallContext.Clear();
end;
function TBaseProxy.AddHeader(
const AHeader: THeaderBlock;
const AKeepOwnership: Boolean
): Integer;
begin
Result := FCallContext.AddHeader(AHeader,AKeepOwnership);
end;
function TBaseProxy.GetHeaderCount(const ADirections : THeaderDirections):Integer;
begin
Result := FCallContext.GetHeaderCount(ADirections);
end;
function TBaseProxy.GetHeader(const AIndex: Integer): THeaderBlock;
begin
Result := FCallContext.GetHeader(AIndex);
end;
procedure TBaseProxy.ClearHeaders(const ADirection: THeaderDirection);
begin
FCallContext.ClearHeaders(ADirection);
end;
constructor TBaseProxy.Create(
const ATarget : String;
const AProtocol : IServiceProtocol
);
begin
Assert(Assigned(AProtocol));
Assert(Assigned(AProtocol.GetCallHandler()));
Assert(Assigned(AProtocol.GetSerializer()));
Assert(Assigned(AProtocol.GetTransport()));
FCallContext := TSimpleCallContext.Create() as ICallContext;
FTarget := ATarget;
FProtocol := AProtocol;
FProtocol.GetSerializer().GetPropertyManager().SetProperty(sTARGET,FTarget);
FProtocol.GetCallHandler().GetPropertyManager().SetProperty(sTARGET,FTarget);
end;
constructor TBaseProxy.Create(
const ATarget: String;
const AProtocolData: string;
const ATransportData: string
);
Var
ptcl : IServiceProtocol;
tmpTrprt : ITransport;
begin
ptcl := Nil;
If GetFormaterRegistry().Find(AProtocolData,ptcl) And
GetTransportRegistry().Find(ATransportData,tmpTrprt)
Then Begin
ptcl.SetTransport(tmpTrprt);
Create(ATarget,ptcl);
End;
end;
destructor TBaseProxy.Destroy();
begin
FProtocol := Nil;
FreeAndNil(FOperationsProperties);
inherited Destroy();
end;
Const PROTOCOL_SEPARATOR = ':';
function ExtractProtocol( Const AProtocolName : string):String;
Var
i : Integer;
begin
i := Pos(PROTOCOL_SEPARATOR,AProtocolName);
If ( i <= 0 ) Then
i := MaxInt;
Result := lowercase(Copy(AProtocolName,1,Pred(i)));
end;
function ExtractProtocolData(Const AProtocolPropsStr : string):String;
Var
i : Integer;
begin
i := Pos(PROTOCOL_SEPARATOR,AProtocolPropsStr);
If ( i <= 0 ) Then
i := 0;
Result := Copy(AProtocolPropsStr,Succ(i),MaxInt);
end;
Type
{ TFormatterFactoryRegistryItem }
{ TServiceProtocol }
TServiceProtocol = class(TInterfacedObject,IInterface,IServiceProtocol)
Private
FFormatter : IFormatterClient;
FCallHandler : ICallMaker;
FTransport : ITransport;
Protected
function GetSerializer() : IFormatterClient;
function GetCallHandler() : ICallMaker;
function GetTransport() : ITransport;
procedure SetTransport(AValue : ITransport);
Public
constructor Create(
AFormatter : IFormatterClient;
ACallHandler : ICallMaker
);
End;
TFormatterFactoryRegistryItem = class
private
FCallHandlerFactory: IItemFactory;
FFormaterFactory: IItemFactory;
FProtocolName: string;
public
constructor Create(
Const AProtocolName : string;
AFormaterFactory : IItemFactory;
ACallHandlerFactory : IItemFactory
);
destructor Destroy();override;
property ProtocolName : string Read FProtocolName;
property FormaterFactory : IItemFactory Read FFormaterFactory;
property CallHandlerFactory : IItemFactory Read FCallHandlerFactory;
End;
{ TFormatterRegistry }
//Make it Threadsafe ???
TFormatterRegistry = class(TInterfacedObject,IInterface,IFormaterQueryRegistry)
private
FList : TObjectList;
function IndexOf(Const AName : string ):Integer;
procedure Clear();
function GetCount():Integer;
function GetItem(const AIndex:Integer): TFormatterFactoryRegistryItem;
protected
function Find(
Const AProtocolData : string;
Out ARes : IServiceProtocol
):Boolean;
procedure Register(
Const AProtocolName : string;
AFormaterFactory : IItemFactory;
ACallHandlerFactory : IItemFactory
);
public
constructor Create();
destructor Destroy();override;
End;
{ TServiceProtocol }
function TServiceProtocol.GetSerializer(): IFormatterClient;
begin
Result := FFormatter;
end;
function TServiceProtocol.GetCallHandler(): ICallMaker;
begin
Result := FCallHandler;
end;
function TServiceProtocol.GetTransport(): ITransport;
begin
Result := FTransport;
end;
procedure TServiceProtocol.SetTransport(AValue: ITransport);
begin
FTransport := AValue;
end;
constructor TServiceProtocol.Create(AFormatter: IFormatterClient;ACallHandler: ICallMaker);
begin
FFormatter := AFormatter;
FCallHandler := ACallHandler;
end;
{ TFormatterFactoryRegistryItem }
constructor TFormatterFactoryRegistryItem.Create(
const AProtocolName: string;
AFormaterFactory: IItemFactory; ACallHandlerFactory: IItemFactory);
begin
FProtocolName := AProtocolName;
FFormaterFactory := AFormaterFactory;
FCallHandlerFactory := ACallHandlerFactory;
end;
destructor TFormatterFactoryRegistryItem.Destroy();
begin
FFormaterFactory := nil;
FCallHandlerFactory := nil;
inherited Destroy();
end;
Var
FormaterRegistryInst : IFormaterQueryRegistry = Nil;
function GetFormaterRegistry():IFormaterQueryRegistry;
begin
If Not Assigned(FormaterRegistryInst) Then
FormaterRegistryInst := TFormatterRegistry.Create() as IFormaterQueryRegistry;// Lock!!!
Result := FormaterRegistryInst;
end;
{ TFormatterRegistry }
function TFormatterRegistry.IndexOf(const AName: string): Integer;
Var
s : string;
begin
s := lowercase(AName);
For Result := 0 To Pred(GetCount()) Do
If SameText(s,GetItem(Result).ProtocolName) Then
Exit;
Result := -1;
end;
procedure TFormatterRegistry.Clear();
begin
FList.Clear();
end;
function TFormatterRegistry.GetCount(): Integer;
begin
Result := FList.Count;
end;
function TFormatterRegistry.GetItem(const AIndex: Integer): TFormatterFactoryRegistryItem;
begin
Result := FList[AIndex] as TFormatterFactoryRegistryItem;
end;
function TFormatterRegistry.Find(
Const AProtocolData : string;
Out ARes : IServiceProtocol
): Boolean;
Var
i : Integer;
r : TFormatterFactoryRegistryItem;
initData : String;
begin
ARes := Nil;
i := IndexOf(ExtractProtocol(AProtocolData));
Result := ( i > -1 );
If Result Then Begin
initData := ExtractProtocolData(AProtocolData);
r := GetItem(i);
ARes := TServiceProtocol.Create(
r.FormaterFactory.CreateInstance() as IFormatterClient,
r.CallHandlerFactory.CreateInstance() as ICallMaker
) as IServiceProtocol;
ARes.GetSerializer().GetPropertyManager().SetProperties(initData);
ARes.GetCallHandler().GetPropertyManager().SetProperties(initData);
End;
end;
procedure TFormatterRegistry.Register(
Const AProtocolName : string;
AFormaterFactory : IItemFactory;
ACallHandlerFactory : IItemFactory
);
Var
i : Integer;
s : string;
begin
Assert(Assigned(AFormaterFactory));
Assert(Assigned(ACallHandlerFactory));
s := ExtractProtocol(AProtocolName);
i := IndexOf(s);
If ( i = -1 ) Then
FList.Add(TFormatterFactoryRegistryItem.Create(s,AFormaterFactory,ACallHandlerFactory));
end;
constructor TFormatterRegistry.Create();
begin
FList := TObjectList.Create(True);
end;
destructor TFormatterRegistry.Destroy();
begin
FreeAndNil(FList);
inherited Destroy();
end;
Type
{ TTransportRegistry }
//Make it Threadsafe ???
TTransportRegistry = class(TBaseFactoryRegistry,IInterface,ITransportRegistry)
protected
function Find(
Const ATransportData : string;
Out ARes : ITransport
):Boolean;
End;
Var
TransportRegistryInst : ITransportRegistry = Nil;
function GetTransportRegistry():ITransportRegistry;
begin
If Not Assigned(TransportRegistryInst) Then
TransportRegistryInst := TTransportRegistry.Create() as ITransportRegistry;// Lock!!!
Result := TransportRegistryInst;
end;
{ TTransportRegistry }
function TTransportRegistry.Find(
const ATransportData : string;
Out ARes : ITransport
): Boolean;
Var
fct : IItemFactory;
begin
fct := FindFactory(ExtractProtocol(ATransportData));
If Assigned(fct) Then Begin
ARes := fct.CreateInstance() as ITransport;
ARes.GetPropertyManager().SetProperties(ExtractProtocolData(ATransportData));
Result := True;
End Else Begin
Result := False;
End;
end;
initialization
TransportRegistryInst := TTransportRegistry.Create() as ITransportRegistry;
FormaterRegistryInst := TFormatterRegistry.Create() as IFormaterQueryRegistry;
finalization
FormaterRegistryInst := nil;
TransportRegistryInst := nil;
end.

263
wst/tags/0.4/soap_formatter.pas Normal file
View File

@ -0,0 +1,263 @@
{
This file is part of the Web Service Toolkit
Copyright (c) 2006 by Inoussa OUEDRAOGO
This file is provide under modified LGPL licence
( the files COPYING.modifiedLGPL and COPYING.LGPL).
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.
}
unit soap_formatter;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, TypInfo, DOM,
base_service_intf, service_intf, imp_utils, base_soap_formatter;
Type
{ TSOAPFormatter }
{$M+}
TSOAPFormatter = class(TSOAPBaseFormatter,IFormatterClient)
private
FPropMngr : IPropertyManager;
FCallProcedureName : string;
FCallTarget : String;
public
destructor Destroy();override;
function GetPropertyManager():IPropertyManager;
procedure BeginCall(
const AProcName,
ATarget : string;
ACallContext : ICallContext
);
procedure EndCall();
procedure BeginCallRead(ACallContext : ICallContext);
function GetCallProcedureName():String;
function GetCallTarget():String;
End;
{ TSOAPCallMaker }
TSOAPCallMaker = class(TSimpleFactoryItem,ICallMaker)
private
FPropMngr : IPropertyManager;
FUniqueAddress: Boolean;
public
constructor Create();override;
destructor Destroy();override;
function GetPropertyManager():IPropertyManager;
procedure MakeCall(
ASerializer : IFormatterClient;
ATransport : ITransport
);
published
property UniqueAddress : Boolean read FUniqueAddress Write FUniqueAddress;
end;
{$M-}
implementation
{ TSOAPFormatter }
destructor TSOAPFormatter.Destroy();
begin
FPropMngr := nil;
inherited Destroy();
end;
function TSOAPFormatter.GetPropertyManager(): IPropertyManager;
begin
If Not Assigned(FPropMngr) Then
FPropMngr := TPublishedPropertyManager.Create(Self);
Result := FPropMngr;
end;
procedure TSOAPFormatter.BeginCall(
const AProcName,
ATarget : string;
ACallContext : ICallContext
);
begin
Prepare();
WriteHeaders(ACallContext);
BeginScope('Body',sSOAP_ENV,'',stObject,asNone);
if ( Style = RPC ) then
BeginScope(AProcName,ATarget,'',stObject,asNone);
FCallTarget := ATarget;
FCallProcedureName := AProcName;
end;
procedure TSOAPFormatter.EndCall();
begin
if ( Style = RPC ) then
EndScope(); //BeginScope(AProcName,ATarget);
EndScope(); //BeginScope('Body','http://schemas.xmlsoap.org/soap/envelope/');
EndScope(); //BeginScope('Envelope','http://schemas.xmlsoap.org/soap/envelope/','SOAP-ENV');
end;
procedure TSOAPFormatter.BeginCallRead(ACallContext : ICallContext);
Var
envNd : TDOMElement;
bdyNd, fltNd, hdrNd : TDOMNode;
nsShortName,eltName, msgBuff : string;
excpt_Obj : ESOAPException;
doc : TXMLDocument;
begin
ClearStack();
doc := GetXmlDoc();
If FindAttributeByValueInNode(sSOAP_ENV,doc.DocumentElement,nsShortName) or
FindAttributeByValueInNode('"' + sSOAP_ENV + '"',doc.DocumentElement,nsShortName)
Then Begin
nsShortName := Copy(nsShortName,1 + Pos(':',nsShortName),MaxInt);
If Not IsStrEmpty(nsShortName) Then
nsShortName := nsShortName + ':';
End Else
nsShortName := '';
eltName := nsShortName + sENVELOPE;
envNd := doc.DocumentElement;
If Not SameText(eltName,envNd.NodeName) Then
Error('XML root node must be "Envelope", found : "%s"',[envNd.NodeName + ':::' + nsShortName]);
PushStack(envNd);
bdyNd := envNd.FirstChild;
if not Assigned(bdyNd) then
Error('Node not found : "Body".');
eltName := nsShortName + 'Body';
if not SameText(bdyNd.NodeName,eltName) then begin
eltName := nsShortName + 'Header';
hdrNd := bdyNd;
bdyNd := hdrNd.NextSibling;
if SameText(hdrNd.NodeName,eltName) then begin
PushStack(hdrNd,asScoped,'').SetNameSpace(sSOAP_ENV);
ReadHeaders(ACallContext);
PopStack().Free();
end;
end;
eltName := nsShortName + 'Body';
bdyNd := envNd.FirstChild;
If Not Assigned(bdyNd) Then
Error('Node not found : "Body"');
If Not SameText(bdyNd.NodeName,eltName) Then
bdyNd := bdyNd.NextSibling;
If Not Assigned(bdyNd) Then
Error('Node not found : "Body"');
PushStack(bdyNd);
If Not Assigned(bdyNd.FirstChild) Then
Error('Response Node not found');
if ( Style = RPC ) then begin
PushStack(bdyNd.FirstChild);
end;
eltName := nsShortName + 'Fault';
If SameText(eltName,bdyNd.FirstChild.NodeName) Then Begin
fltNd := bdyNd.FirstChild;
excpt_Obj := ESOAPException.Create('');
Try
eltName := 'faultcode';
Get(TypeInfo(string),eltName,msgBuff);
excpt_Obj.FaultCode := msgBuff;
eltName := 'faultstring';
Get(TypeInfo(string),eltName,msgBuff);
excpt_Obj.FaultString := msgBuff; ;
excpt_Obj.Message := Format(
'Service exception :%s Code = "%s"%s Message = "%s"',
[LineEnding,excpt_Obj.FaultCode,LineEnding,excpt_Obj.FaultString]
);
Except
FreeAndNil(excpt_Obj);
Raise;
End;
Raise excpt_Obj;
End;
end;
function TSOAPFormatter.GetCallProcedureName(): String;
begin
Result := FCallProcedureName;
end;
function TSOAPFormatter.GetCallTarget(): String;
begin
Result := FCallTarget;
end;
{ TSOAPCallMaker }
constructor TSOAPCallMaker.Create();
begin
FUniqueAddress := True;
FPropMngr := TPublishedPropertyManager.Create(Self);
end;
destructor TSOAPCallMaker.Destroy();
begin
FPropMngr := Nil;
inherited Destroy();
end;
function TSOAPCallMaker.GetPropertyManager(): IPropertyManager;
begin
Result := FPropMngr;
end;
procedure TSOAPCallMaker.MakeCall(
ASerializer : IFormatterClient;
ATransport : ITransport
);
Var
rqt, rsps : TMemoryStream;
{$IFDEF WST_DBG}
s : string;
{$ENDIF WST_DBG}
begin
Assert(Assigned(ASerializer));
Assert(Assigned(ATransport));
ATransport.GetPropertyManager().SetProperty(
sCONTENT_TYPE,
ASerializer.GetPropertyManager().GetProperty(sCONTENT_TYPE)
);
rsps := Nil;
rqt := TMemoryStream.Create();
Try
rsps := TMemoryStream.Create();
ASerializer.SaveToStream(rqt);
rqt.Position := 0;
ATransport.SendAndReceive(rqt,rsps);
rqt.Clear();
rsps.Position := 0;
ASerializer.Clear();
ASerializer.LoadFromStream(rsps);
Finally
rsps.Free();
rqt.Free();
End;
end;
procedure RegisterSoapProtocol();
begin
RegisterStdTypes();
GetFormaterRegistry().Register(
sPROTOCOL_NAME,
TSimpleItemFactory.Create(TSOAPFormatter) as IItemFactory,
TSimpleItemFactory.Create(TSOAPCallMaker) as IItemFactory
);
end;
Initialization
RegisterSoapProtocol();
end.

183
wst/tags/0.4/synapse_http_protocol.pas Normal file
View File

@ -0,0 +1,183 @@
{
This file is part of the Web Service Toolkit
Copyright (c) 2006 by Inoussa OUEDRAOGO
This file is provide under modified LGPL licence
( the files COPYING.modifiedLGPL and COPYING.LGPL).
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.
}
unit synapse_http_protocol;
//{$DEFINE WST_DBG}
interface
uses
Classes, SysUtils,{$IFDEF WST_DBG}Dialogs,{$ENDIF}
service_intf, imp_utils, base_service_intf,
httpsend;
{$INCLUDE wst.inc}
Const
sTRANSPORT_NAME = 'HTTP';
Type
{$M+}
{ THTTPTransport }
THTTPTransport = class(TSimpleFactoryItem,ITransport)
Private
FPropMngr : IPropertyManager;
FConnection : THTTPSend;
FAddress : string;
private
FSoapAction: string;
function GetAddress: string;
function GetContentType: string;
function GetProxyPassword: string;
function GetProxyPort: Integer;
function GetProxyServer: string;
function GetProxyUsername: string;
procedure SetAddress(const AValue: string);
procedure SetContentType(const AValue: string);
procedure SetProxyPassword(const AValue: string);
procedure SetProxyPort(const AValue: Integer);
procedure SetProxyServer(const AValue: string);
procedure SetProxyUsername(const AValue: string);
Public
constructor Create();override;
destructor Destroy();override;
function GetPropertyManager():IPropertyManager;
procedure SendAndReceive(ARequest,AResponse:TStream);
Published
property ContentType : string Read GetContentType Write SetContentType;
property Address : string Read GetAddress Write SetAddress;
property ProxyServer : string Read GetProxyServer Write SetProxyServer;
property ProxyPort : Integer Read GetProxyPort Write SetProxyPort;
property ProxyUsername : string read GetProxyUsername write SetProxyUsername;
property ProxyPassword : string read GetProxyPassword write SetProxyPassword;
property SoapAction : string read FSoapAction write FSoapAction;
End;
{$M+}
procedure SYNAPSE_RegisterHTTP_Transport();
implementation
{ THTTPTransport }
function THTTPTransport.GetAddress: string;
begin
Result := FAddress;
end;
function THTTPTransport.GetContentType: string;
begin
Result := FConnection.MimeType;
end;
function THTTPTransport.GetProxyPassword: string;
begin
Result := FConnection.ProxyPass;
end;
function THTTPTransport.GetProxyPort: Integer;
begin
Result := StrToInt(FConnection.ProxyPort);
end;
function THTTPTransport.GetProxyServer: string;
begin
Result := FConnection.ProxyHost;
end;
function THTTPTransport.GetProxyUsername: string;
begin
Result := FConnection.ProxyUser;
end;
procedure THTTPTransport.SetAddress(const AValue: string);
begin
FAddress := AValue;
end;
procedure THTTPTransport.SetContentType(const AValue: string);
begin
FConnection.MimeType := AValue;
end;
procedure THTTPTransport.SetProxyPassword(const AValue: string);
begin
FConnection.ProxyPass := AValue;
end;
procedure THTTPTransport.SetProxyPort(const AValue: Integer);
begin
FConnection.ProxyPort := IntToStr(AValue);
end;
procedure THTTPTransport.SetProxyServer(const AValue: string);
begin
FConnection.ProxyHost := AValue;
end;
procedure THTTPTransport.SetProxyUsername(const AValue: string);
begin
FConnection.ProxyUser := AValue;
end;
constructor THTTPTransport.Create();
begin
inherited Create();
FPropMngr := TPublishedPropertyManager.Create(Self);
FConnection := THTTPSend.Create();
FConnection.Protocol := '1.1';
end;
destructor THTTPTransport.Destroy();
begin
FreeAndNil(FConnection);
FPropMngr := Nil;
inherited Destroy();
end;
function THTTPTransport.GetPropertyManager(): IPropertyManager;
begin
Result := FPropMngr;
end;
procedure THTTPTransport.SendAndReceive(ARequest, AResponse: TStream);
{$IFDEF WST_DBG}
var
s : string;
{$ENDIF}
begin
FConnection.Document.Size := 0;
FConnection.Headers.Add('soapAction:' + SoapAction);
FConnection.Document.CopyFrom(ARequest,0);
FConnection.HTTPMethod('POST',FAddress);
AResponse.CopyFrom(FConnection.Document,0);
FConnection.Clear();
{$IFDEF WST_DBG}
TMemoryStream(ARequest).SaveToFile('request.log');
SetLength(s,AResponse.Size);
Move(TMemoryStream(AResponse).Memory^,s[1],Length(s));
TMemoryStream(AResponse).SaveToFile('response.log');
if IsConsole then
WriteLn(s)
else
ShowMessage(s);
{$ENDIF}
end;
procedure SYNAPSE_RegisterHTTP_Transport();
begin
GetTransportRegistry().Register(sTRANSPORT_NAME,TSimpleItemFactory.Create(THTTPTransport) as IItemFactory);
end;
end.

148
wst/tags/0.4/synapse_tcp_protocol.pas Normal file
View File

@ -0,0 +1,148 @@
{
This file is part of the Web Service Toolkit
Copyright (c) 2006 by Inoussa OUEDRAOGO
This file is provide under modified LGPL licence
( the files COPYING.modifiedLGPL and COPYING.LGPL).
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.
}
unit synapse_tcp_protocol;
interface
uses
Classes, SysUtils,
service_intf, imp_utils, base_service_intf,
blcksock;
{$INCLUDE wst.inc}
Const
sTRANSPORT_NAME = 'TCP';
Type
ETCPException = class(EServiceException)
End;
{$M+}
{ TTCPTransport }
TTCPTransport = class(TSimpleFactoryItem,ITransport)
Private
FPropMngr : IPropertyManager;
FConnection : TTCPBlockSocket;
FContentType : string;
FTarget: string;
FAddress : string;
FPort : string;
FDefaultTimeOut: Integer;
public
constructor Create();override;
destructor Destroy();override;
function GetPropertyManager():IPropertyManager;
procedure SendAndReceive(ARequest,AResponse:TStream);
Published
property Target : string Read FTarget Write FTarget;
property ContentType : string Read FContentType Write FContentType;
property Address : string Read FAddress Write FAddress;
property Port : string Read FPort Write FPort;
property DefaultTimeOut : Integer read FDefaultTimeOut write FDefaultTimeOut;
End;
{$M+}
procedure SYNAPSE_RegisterTCP_Transport();
implementation
uses binary_streamer, Math;
{ TTCPTransport }
constructor TTCPTransport.Create();
begin
FPropMngr := TPublishedPropertyManager.Create(Self);
FConnection := TTCPBlockSocket.Create();
FConnection.RaiseExcept := True;
FDefaultTimeOut := 90000;
end;
destructor TTCPTransport.Destroy();
begin
FreeAndNil(FConnection);
FPropMngr := Nil;
inherited Destroy();
end;
function TTCPTransport.GetPropertyManager(): IPropertyManager;
begin
Result := FPropMngr;
end;
procedure TTCPTransport.SendAndReceive(ARequest, AResponse: TStream);
Var
wrtr : IDataStore;
buffStream : TMemoryStream;
strBuff : string;
bufferLen : LongInt;
i, j, c : PtrInt;
{$IFDEF WST_DBG}
s : string;
{$ENDIF WST_DBG}
begin
buffStream := TMemoryStream.Create();
Try
wrtr := CreateBinaryWriter(buffStream);
wrtr.WriteInt32S(0);
wrtr.WriteStr(Target);
wrtr.WriteStr(ContentType);
SetLength(strBuff,ARequest.Size);
ARequest.Position := 0;
ARequest.Read(strBuff[1],Length(strBuff));
wrtr.WriteStr(strBuff);
buffStream.Position := 0;
wrtr.WriteInt32S(buffStream.Size-4);
if ( FConnection.Socket = NOT(0) ) then
FConnection.Connect(Address,Port);
FConnection.SendBuffer(buffStream.Memory,buffStream.Size);
bufferLen := 0;
FConnection.RecvBufferEx(@bufferLen,SizeOf(bufferLen),DefaultTimeOut);
FConnection.ExceptCheck();
bufferLen := Reverse_32(bufferLen);
AResponse.Size := bufferLen;
if ( bufferLen > 0 ) then begin
c := 0;
i := 1024;
if ( i > bufferLen ) then
i := bufferLen;
SetLength(strBuff,i);
repeat
j := FConnection.RecvBufferEx(@(strBuff[1]),i,DefaultTimeOut);
FConnection.ExceptCheck();
AResponse.Write(strBuff[1],j);
Inc(c,j);
i := Min(1024,(bufferLen-c));
until ( i =0 ) or ( j <= 0 );
end;
AResponse.Position := 0;
{$IFDEF WST_DBG}
i := AResponse.Position;
SetLength(s,AResponse.Size);
AResponse.Read(s[1],AResponse.Size);
WriteLn(s);
{$ENDIF WST_DBG}
Finally
buffStream.Free();
End;
end;
procedure SYNAPSE_RegisterTCP_Transport();
begin
GetTransportRegistry().Register(sTRANSPORT_NAME,TSimpleItemFactory.Create(TTCPTransport) as IItemFactory);
end;
end.

257
wst/tags/0.4/synapse_tcp_server.pas Normal file
View File

@ -0,0 +1,257 @@
{
This file is part of the Web Service Toolkit
Copyright (c) 2006 by Inoussa OUEDRAOGO
This file is provide under modified LGPL licence
( the files COPYING.modifiedLGPL and COPYING.LGPL).
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.
}
unit synapse_tcp_server;
{$INCLUDE wst.inc}
interface
uses
Classes, SysUtils, blcksock, synsock;
const
sSERVER_PORT = '1234';
type
ILogger = interface
['{CA357B9A-604F-4603-96FA-65D445837E80}']
procedure Log(const AMsg : string);overload;
procedure Log(const AMsg : string;const AArgs : array of const);overload;
end;
{ TClientHandlerThread }
TClientHandlerThread = class(TThread)
private
FDefaultTimeOut: Integer;
FSocketObject : TTCPBlockSocket;
FSocketHandle : TSocket;
FInputStream : TMemoryStream;
FOutputStream : TMemoryStream;
private
procedure ClearBuffers();
function ReadInputBuffer():Integer;
procedure SendOutputBuffer();
public
constructor Create (ASocketHandle : TSocket);
destructor Destroy();override;
procedure Execute(); override;
property DefaultTimeOut : Integer read FDefaultTimeOut write FDefaultTimeOut;
end;
{ TServerListnerThread }
TServerListnerThread = class(TThread)
private
FDefaultTimeOut: Integer;
FSocketObject : TTCPBlockSocket;
public
constructor Create();
destructor Destroy(); override;
procedure Execute(); override;
property DefaultTimeOut : Integer read FDefaultTimeOut write FDefaultTimeOut;
end;
{ TConsoleLogger }
TConsoleLogger = class(TInterfacedObject,IInterface,ILogger)
protected
procedure Log(const AMsg : string);overload;
procedure Log(const AMsg : string;const AArgs : array of const);overload;
end;
function Logger():ILogger ;
function SetLogger(ALogger : ILogger):ILogger ;
implementation
uses binary_streamer, server_service_intf, server_service_imputils;
var FLoggerInst : ILogger = nil;
function SetLogger(ALogger : ILogger):ILogger ;
begin
Result := FLoggerInst;
FLoggerInst := ALogger;
end;
function Logger():ILogger ;
begin
Result := FLoggerInst;
end;
{ TConsoleLogger }
procedure TConsoleLogger.Log(const AMsg: string);
begin
WriteLn(AMsg);
end;
procedure TConsoleLogger.Log(const AMsg: string; const AArgs: array of const);
begin
WriteLn(Format(AMsg,AArgs));
end;
{ TClientHandlerThread }
procedure TClientHandlerThread.ClearBuffers();
begin
FInputStream.Size := 0;
FOutputStream.Size := 0;
end;
function TClientHandlerThread.ReadInputBuffer(): Integer;
var
strBuff : string;
bufferLen : LongInt;
i, j, c : PtrInt;
begin
FInputStream.Size := 0;
Result := 0;
bufferLen := 0;
FSocketObject.RecvBufferEx(@bufferLen,SizeOf(bufferLen),DefaultTimeOut);
FSocketObject.ExceptCheck();
bufferLen := Reverse_32(bufferLen);
FInputStream.Size := bufferLen;
if ( bufferLen > 0 ) then begin
c := 0;
i := 1024;
if ( i > bufferLen ) then
i := bufferLen;
SetLength(strBuff,i);
repeat
j := FSocketObject.RecvBufferEx(@(strBuff[1]),i,DefaultTimeOut);
FSocketObject.ExceptCheck();
FInputStream.Write(strBuff[1],j);
Inc(c,j);
if ( ( bufferLen - c ) > 1024 ) then
i := 1024
else
i := bufferLen - c;
until ( i = 0 ) or ( j <= 0 );
end;
FInputStream.Position := 0;
Result := FInputStream.Size;
end;
procedure TClientHandlerThread.SendOutputBuffer();
begin
FSocketObject.SendBuffer(FOutputStream.Memory,FOutputStream.Size);
end;
constructor TClientHandlerThread.Create(ASocketHandle: TSocket);
begin
FSocketHandle := ASocketHandle;
FreeOnTerminate := True;
FDefaultTimeOut := 90000;
inherited Create(False);
end;
destructor TClientHandlerThread.Destroy();
begin
FreeAndNil(FOutputStream);
FreeAndNil(FInputStream);
inherited Destroy();
end;
procedure TClientHandlerThread.Execute();
var
wrtr : IDataStore;
rdr : IDataStoreReader;
buff, trgt,ctntyp : string;
rqst : IRequestBuffer;
i : PtrUInt;
begin
FInputStream := TMemoryStream.Create();
FOutputStream := TMemoryStream.Create();
FSocketObject := TTCPBlockSocket.Create();
try
FSocketObject.RaiseExcept := True;
try
FSocketObject.Socket := FSocketHandle;
FSocketObject.GetSins();
while not Terminated do begin
FOutputStream.Size := 0;
if ( ReadInputBuffer() >= SizeOf(LongInt) ) then begin
rdr := CreateBinaryReader(FInputStream);
trgt := rdr.ReadStr();
ctntyp := rdr.ReadStr();
buff := rdr.ReadStr();
rdr := nil;
FInputStream.Size := 0;
FInputStream.Write(buff[1],Length(buff));
FInputStream.Position := 0;
rqst := TRequestBuffer.Create(trgt,ctntyp,FInputStream,FOutputStream);
HandleServiceRequest(rqst);
i := FOutputStream.Size;
SetLength(buff,i);
FOutputStream.Position := 0;
FOutputStream.Read(buff[1],i);
FOutputStream.Size := 0;
wrtr := CreateBinaryWriter(FOutputStream);
wrtr.WriteStr(buff);
SendOutputBuffer();
ClearBuffers();
end;
end;
except
on e : Exception do begin
Logger().Log('Error : ThreadID = %d; Message = %s',[Self.ThreadID,e.Message]);
end;
end;
finally
FreeAndNil(FSocketObject);
end;
end;
{ TServerListnerThread }
constructor TServerListnerThread.Create();
begin
FSocketObject := TTCPBlockSocket.Create();
FreeOnTerminate := True;
FDefaultTimeOut := 1000;
inherited Create(false);
end;
destructor TServerListnerThread.Destroy();
begin
FreeAndNil(FSocketObject);
inherited Destroy();
end;
procedure TServerListnerThread.Execute();
var
ClientSock : TSocket;
begin
try
FSocketObject.RaiseExcept := True;
FSocketObject.CreateSocket();
FSocketObject.SetLinger(True,10);
FSocketObject.Bind('127.0.0.1',sSERVER_PORT);
FSocketObject.Listen();
while not Terminated do begin
if FSocketObject.CanRead(DefaultTimeOut) then begin
ClientSock := FSocketObject.Accept();
TClientHandlerThread.Create(ClientSock);
end;
end;
except
on e : Exception do begin
Logger().Log('Listner Thread Error : ThreadID = %d; Message = %s',[Self.ThreadID,e.Message]);
Logger().Log('Listner stoped.');
end;
end;
end;
end.

452
wst/tags/0.4/tests/amazon/amazon.lpi Normal file
View File

@ -0,0 +1,452 @@
<?xml version="1.0"?>
<CONFIG>
<ProjectOptions>
<PathDelim Value="\"/>
<Version Value="5"/>
<General>
<MainUnit Value="0"/>
<IconPath Value="./"/>
<TargetFileExt Value=".exe"/>
<ActiveEditorIndexAtStart Value="6"/>
</General>
<VersionInfo>
<ProjectVersion Value=""/>
<Language Value=""/>
<CharSet Value=""/>
</VersionInfo>
<PublishOptions>
<Version Value="2"/>
<IgnoreBinaries Value="False"/>
<IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/>
<ExcludeFileFilter Value="*.(bak|ppu|ppw|o|so);*~;backup"/>
</PublishOptions>
<RunParams>
<local>
<FormatVersion Value="1"/>
<LaunchingApplication PathPlusParams="/usr/X11R6/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/>
</local>
</RunParams>
<RequiredPackages Count="1">
<Item1>
<PackageName Value="LCL"/>
</Item1>
</RequiredPackages>
<Units Count="23">
<Unit0>
<Filename Value="amazon.lpr"/>
<IsPartOfProject Value="True"/>
<UnitName Value="amazon"/>
<CursorPos X="1" Y="17"/>
<TopLine Value="1"/>
<UsageCount Value="100"/>
</Unit0>
<Unit1>
<Filename Value="umain.pas"/>
<ComponentName Value="fMain"/>
<IsPartOfProject Value="True"/>
<ResourceFilename Value="umain.lrs"/>
<UnitName Value="umain"/>
<CursorPos X="34" Y="60"/>
<TopLine Value="50"/>
<EditorIndex Value="0"/>
<UsageCount Value="100"/>
<Loaded Value="True"/>
</Unit1>
<Unit2>
<Filename Value="..\files\free\AWSECommerceService.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="AWSECommerceService"/>
<CursorPos X="3" Y="19328"/>
<TopLine Value="19324"/>
<EditorIndex Value="6"/>
<UsageCount Value="100"/>
<Bookmarks Count="2">
<Item0 X="5" Y="3387" ID="1"/>
<Item1 X="12" Y="2429" ID="2"/>
</Bookmarks>
<Loaded Value="True"/>
</Unit2>
<Unit3>
<Filename Value="..\..\base_service_intf.pas"/>
<UnitName Value="base_service_intf"/>
<CursorPos X="21" Y="97"/>
<TopLine Value="71"/>
<EditorIndex Value="5"/>
<UsageCount Value="45"/>
<Loaded Value="True"/>
</Unit3>
<Unit4>
<Filename Value="..\..\service_intf.pas"/>
<UnitName Value="service_intf"/>
<CursorPos X="1" Y="203"/>
<TopLine Value="178"/>
<EditorIndex Value="1"/>
<UsageCount Value="42"/>
<Bookmarks Count="1">
<Item0 X="41" Y="178" ID="3"/>
</Bookmarks>
<Loaded Value="True"/>
</Unit4>
<Unit5>
<Filename Value="..\..\metadata_repository.pas"/>
<UnitName Value="metadata_repository"/>
<CursorPos X="78" Y="117"/>
<TopLine Value="148"/>
<EditorIndex Value="7"/>
<UsageCount Value="19"/>
<Loaded Value="True"/>
</Unit5>
<Unit6>
<Filename Value="..\..\wst_resources_imp.pas"/>
<UnitName Value="wst_resources_imp"/>
<CursorPos X="3" Y="182"/>
<TopLine Value="183"/>
<UsageCount Value="6"/>
</Unit6>
<Unit7>
<Filename Value="..\files\free\AWSECommerceService_proxy.pas"/>
<UnitName Value="AWSECommerceService_proxy"/>
<CursorPos X="1" Y="86"/>
<TopLine Value="84"/>
<EditorIndex Value="4"/>
<UsageCount Value="40"/>
<Loaded Value="True"/>
</Unit7>
<Unit8>
<Filename Value="..\..\soap_formatter.pas"/>
<UnitName Value="soap_formatter"/>
<CursorPos X="10" Y="254"/>
<TopLine Value="221"/>
<UsageCount Value="37"/>
</Unit8>
<Unit9>
<Filename Value="..\..\synapse_http_protocol.pas"/>
<UnitName Value="synapse_http_protocol"/>
<CursorPos X="1" Y="151"/>
<TopLine Value="140"/>
<EditorIndex Value="2"/>
<UsageCount Value="17"/>
<Loaded Value="True"/>
</Unit9>
<Unit10>
<Filename Value="..\..\imp_utils.pas"/>
<UnitName Value="imp_utils"/>
<CursorPos X="15" Y="13"/>
<TopLine Value="1"/>
<EditorIndex Value="3"/>
<UsageCount Value="36"/>
<Loaded Value="True"/>
</Unit10>
<Unit11>
<Filename Value="..\..\base_soap_formatter.pas"/>
<UnitName Value="base_soap_formatter"/>
<CursorPos X="3" Y="28"/>
<TopLine Value="7"/>
<UsageCount Value="37"/>
</Unit11>
<Unit12>
<Filename Value="..\..\..\..\..\lazarusClean\fpc\2.0.4\source\rtl\objpas\typinfo.pp"/>
<UnitName Value="typinfo"/>
<CursorPos X="3" Y="925"/>
<TopLine Value="921"/>
<UsageCount Value="7"/>
</Unit12>
<Unit13>
<Filename Value="..\..\ics_http_protocol.pas"/>
<UnitName Value="ics_http_protocol"/>
<CursorPos X="1" Y="183"/>
<TopLine Value="161"/>
<UsageCount Value="14"/>
</Unit13>
<Unit14>
<Filename Value="..\..\..\..\..\lazarusClean\fpc\2.0.4\source\fcl\xml\dom.pp"/>
<UnitName Value="DOM"/>
<CursorPos X="15" Y="269"/>
<TopLine Value="256"/>
<UsageCount Value="7"/>
</Unit14>
<Unit15>
<Filename Value="..\..\..\..\..\lazarusClean\others_package\ics\latest_distr\Delphi\Vc32\HttpProt.pas"/>
<UnitName Value="HttpProt"/>
<CursorPos X="1" Y="2555"/>
<TopLine Value="2544"/>
<UsageCount Value="7"/>
</Unit15>
<Unit16>
<Filename Value="..\..\..\..\..\lazarusClean\fpc\2.0.4\source\rtl\objpas\sysutils\sysstrh.inc"/>
<CursorPos X="10" Y="112"/>
<TopLine Value="91"/>
<UsageCount Value="8"/>
</Unit16>
<Unit17>
<Filename Value="..\..\..\..\..\lazarus211\fpc\2.1.1\source\packages\fcl-xml\src\dom.pp"/>
<UnitName Value="DOM"/>
<CursorPos X="17" Y="302"/>
<TopLine Value="289"/>
<UsageCount Value="9"/>
</Unit17>
<Unit18>
<Filename Value="..\..\..\..\..\lazarus211\fpc\2.1.1\source\rtl\i386\i386.inc"/>
<CursorPos X="3" Y="1284"/>
<TopLine Value="1270"/>
<UsageCount Value="10"/>
</Unit18>
<Unit19>
<Filename Value="..\..\..\..\..\lazarus211\fpc\2.1.1\source\rtl\inc\except.inc"/>
<CursorPos X="1" Y="223"/>
<TopLine Value="210"/>
<UsageCount Value="10"/>
</Unit19>
<Unit20>
<Filename Value="..\..\..\..\..\lazarus211\fpc\2.1.1\source\rtl\objpas\typinfo.pp"/>
<UnitName Value="typinfo"/>
<CursorPos X="68" Y="116"/>
<TopLine Value="115"/>
<UsageCount Value="9"/>
</Unit20>
<Unit21>
<Filename Value="..\..\..\..\..\lazarus211\fpc\2.1.1\source\rtl\inc\objpas.inc"/>
<CursorPos X="1" Y="58"/>
<TopLine Value="45"/>
<UsageCount Value="10"/>
</Unit21>
<Unit22>
<Filename Value="..\..\..\..\..\lazarus211\fpc\2.1.1\source\rtl\i386\setjump.inc"/>
<CursorPos X="3" Y="36"/>
<TopLine Value="20"/>
<UsageCount Value="10"/>
</Unit22>
</Units>
<JumpHistory Count="30" HistoryIndex="29">
<Position1>
<Filename Value="..\..\imp_utils.pas"/>
<Caret Line="183" Column="1" TopLine="162"/>
</Position1>
<Position2>
<Filename Value="..\..\imp_utils.pas"/>
<Caret Line="105" Column="2" TopLine="85"/>
</Position2>
<Position3>
<Filename Value="..\..\imp_utils.pas"/>
<Caret Line="86" Column="1" TopLine="73"/>
</Position3>
<Position4>
<Filename Value="..\..\imp_utils.pas"/>
<Caret Line="105" Column="1" TopLine="92"/>
</Position4>
<Position5>
<Filename Value="..\..\imp_utils.pas"/>
<Caret Line="105" Column="1" TopLine="92"/>
</Position5>
<Position6>
<Filename Value="..\..\service_intf.pas"/>
<Caret Line="252" Column="1" TopLine="239"/>
</Position6>
<Position7>
<Filename Value="..\..\service_intf.pas"/>
<Caret Line="253" Column="1" TopLine="240"/>
</Position7>
<Position8>
<Filename Value="..\..\synapse_http_protocol.pas"/>
<Caret Line="151" Column="1" TopLine="157"/>
</Position8>
<Position9>
<Filename Value="..\..\imp_utils.pas"/>
<Caret Line="86" Column="1" TopLine="73"/>
</Position9>
<Position10>
<Filename Value="umain.pas"/>
<Caret Line="72" Column="43" TopLine="58"/>
</Position10>
<Position11>
<Filename Value="..\files\free\AWSECommerceService.pas"/>
<Caret Line="24" Column="75" TopLine="19"/>
</Position11>
<Position12>
<Filename Value="..\..\metadata_repository.pas"/>
<Caret Line="215" Column="13" TopLine="196"/>
</Position12>
<Position13>
<Filename Value="..\..\imp_utils.pas"/>
<Caret Line="86" Column="1" TopLine="73"/>
</Position13>
<Position14>
<Filename Value="..\..\metadata_repository.pas"/>
<Caret Line="171" Column="1" TopLine="151"/>
</Position14>
<Position15>
<Filename Value="..\..\imp_utils.pas"/>
<Caret Line="47" Column="67" TopLine="31"/>
</Position15>
<Position16>
<Filename Value="..\..\metadata_repository.pas"/>
<Caret Line="158" Column="41" TopLine="145"/>
</Position16>
<Position17>
<Filename Value="umain.pas"/>
<Caret Line="72" Column="43" TopLine="58"/>
</Position17>
<Position18>
<Filename Value="..\files\free\AWSECommerceService_proxy.pas"/>
<Caret Line="86" Column="219" TopLine="73"/>
</Position18>
<Position19>
<Filename Value="umain.pas"/>
<Caret Line="65" Column="34" TopLine="60"/>
</Position19>
<Position20>
<Filename Value="umain.pas"/>
<Caret Line="54" Column="21" TopLine="42"/>
</Position20>
<Position21>
<Filename Value="umain.pas"/>
<Caret Line="43" Column="24" TopLine="31"/>
</Position21>
<Position22>
<Filename Value="..\files\free\AWSECommerceService_proxy.pas"/>
<Caret Line="1" Column="1" TopLine="1"/>
</Position22>
<Position23>
<Filename Value="..\files\free\AWSECommerceService.pas"/>
<Caret Line="2" Column="68" TopLine="1"/>
</Position23>
<Position24>
<Filename Value="umain.pas"/>
<Caret Line="43" Column="24" TopLine="31"/>
</Position24>
<Position25>
<Filename Value="umain.pas"/>
<Caret Line="122" Column="1" TopLine="100"/>
</Position25>
<Position26>
<Filename Value="umain.pas"/>
<Caret Line="110" Column="8" TopLine="100"/>
</Position26>
<Position27>
<Filename Value="umain.pas"/>
<Caret Line="114" Column="1" TopLine="96"/>
</Position27>
<Position28>
<Filename Value="umain.pas"/>
<Caret Line="25" Column="45" TopLine="17"/>
</Position28>
<Position29>
<Filename Value="umain.pas"/>
<Caret Line="32" Column="14" TopLine="17"/>
</Position29>
<Position30>
<Filename Value="umain.pas"/>
<Caret Line="60" Column="34" TopLine="50"/>
</Position30>
</JumpHistory>
</ProjectOptions>
<CompilerOptions>
<Version Value="5"/>
<PathDelim Value="\"/>
<SearchPaths>
<OtherUnitFiles Value="..\files\free\;$(LazarusDir)\others_package\synapse\;..\..\;$(LazarusDir)\others_package\ics\latest_distr\Delphi\Vc32\"/>
<SrcPath Value="$(LazarusDir)\lcl\;$(LazarusDir)\lcl\interfaces\$(LCLWidgetType)\;$(LazarusDir)\others_package\synapse\"/>
</SearchPaths>
<CodeGeneration>
<Generate Value="Faster"/>
</CodeGeneration>
<Linking>
<Options>
<Win32>
<GraphicApplication Value="True"/>
</Win32>
</Options>
</Linking>
<Other>
<CompilerPath Value="$(CompPath)"/>
</Other>
</CompilerOptions>
<Debugging>
<BreakPoints Count="19">
<Item1>
<Source Value="..\google_api\home\inoussa\Projets\Laz\tests\soap\test_soap.pas"/>
<Line Value="15"/>
</Item1>
<Item2>
<Source Value="..\google_api\home\inoussa\Projets\Laz\tests\soap\test_soap.pas"/>
<Line Value="16"/>
</Item2>
<Item3>
<Source Value="..\google_api\home\inoussa\Projets\Laz\tests\soap\test_soap.pas"/>
<Line Value="18"/>
</Item3>
<Item4>
<Source Value="..\google_api\home\inoussa\Projets\Laz\tests\soap\googleintfimpunit.pas"/>
<Line Value="63"/>
</Item4>
<Item5>
<Source Value="..\google_api\home\inoussa\Projets\Laz\v0.2\indy_http_protocol.pas"/>
<Line Value="69"/>
</Item5>
<Item6>
<Source Value="..\google_api\home\inoussa\Projets\Laz\v0.2\service_intf.pas"/>
<Line Value="567"/>
</Item6>
<Item7>
<Source Value="..\google_api\home\inoussa\Projets\Laz\v0.2\imp_utils.pas"/>
<Line Value="83"/>
</Item7>
<Item8>
<Source Value="..\test_suite\testformatter_unit.pas"/>
<Line Value="572"/>
</Item8>
<Item9>
<Source Value="..\test_suite\testformatter_unit.pas"/>
<Line Value="587"/>
</Item9>
<Item10>
<Source Value="..\test_suite\testformatter_unit.pas"/>
<Line Value="588"/>
</Item10>
<Item11>
<Source Value="..\test_suite\testformatter_unit.pas"/>
<Line Value="571"/>
</Item11>
<Item12>
<Source Value="..\test_suite\testformatter_unit.pas"/>
<Line Value="570"/>
</Item12>
<Item13>
<Source Value="..\test_suite\testformatter_unit.pas"/>
<Line Value="568"/>
</Item13>
<Item14>
<Source Value="..\test_suite\testformatter_unit.pas"/>
<Line Value="909"/>
</Item14>
<Item15>
<Source Value="..\..\base_service_intf.pas"/>
<Line Value="1698"/>
</Item15>
<Item16>
<Source Value="..\..\base_service_intf.pas"/>
<Line Value="1699"/>
</Item16>
<Item17>
<Source Value="..\..\base_service_intf.pas"/>
<Line Value="3662"/>
</Item17>
<Item18>
<Source Value="..\..\service_intf.pas"/>
<Line Value="253"/>
</Item18>
<Item19>
<Source Value="..\..\service_intf.pas"/>
<Line Value="250"/>
</Item19>
</BreakPoints>
<Watches Count="2">
<Item1>
<Expression Value="FScopeObject.Name"/>
</Item1>
<Item2>
<Expression Value="AOwner^.DataType"/>
</Item2>
</Watches>
</Debugging>
</CONFIG>

18
wst/tags/0.4/tests/amazon/amazon.lpr Normal file
View File

@ -0,0 +1,18 @@
program amazon;
{$mode objfpc}{$H+}
uses
{$IFDEF UNIX}{$IFDEF UseCThreads}
cthreads,
{$ENDIF}{$ENDIF}
Interfaces, // this includes the LCL widgetset
Forms,
umain, AWSECommerceService;
begin
Application.Initialize;
Application.CreateForm(TfMain, fMain);
Application.Run;
end.

120
wst/tags/0.4/tests/amazon/umain.lfm Normal file
View File

@ -0,0 +1,120 @@
object fMain: TfMain
Left = 339
Height = 471
Top = 181
Width = 476
HorzScrollBar.Page = 475
VertScrollBar.Page = 470
ActiveControl = edtAccessID
Caption = 'WST Amazon - Sample'
Position = poDesktopCenter
object Label1: TLabel
Left = 16
Height = 18
Top = 24
Width = 69
Caption = 'Access Key'
Color = clNone
ParentColor = False
end
object Bevel1: TBevel
Left = 16
Height = 8
Top = 64
Width = 451
Anchors = [akTop, akLeft, akRight]
Shape = bsBottomLine
end
object Label2: TLabel
Left = 16
Height = 18
Top = 91
Width = 82
Caption = 'Search Index'
Color = clNone
ParentColor = False
end
object Label3: TLabel
Left = 16
Height = 18
Top = 142
Width = 82
Caption = 'Manufacturer'
Color = clNone
ParentColor = False
end
object Label4: TLabel
Left = 16
Height = 18
Top = 188
Width = 65
Caption = 'Key words'
Color = clNone
ParentColor = False
end
object Bevel2: TBevel
Left = 16
Height = 8
Top = 216
Width = 450
Anchors = [akTop, akLeft, akRight]
Shape = bsBottomLine
end
object edtAccessID: TEdit
Left = 118
Height = 23
Top = 24
Width = 202
TabOrder = 0
end
object edtSearchIndex: TEdit
Left = 127
Height = 23
Top = 91
Width = 338
Anchors = [akTop, akLeft, akRight]
TabOrder = 1
Text = 'All'
end
object edtManufacturer: TEdit
Left = 127
Height = 23
Top = 142
Width = 338
Anchors = [akTop, akLeft, akRight]
TabOrder = 2
end
object mmoRes: TMemo
Left = 16
Height = 210
Top = 248
Width = 449
Anchors = [akTop, akLeft, akRight, akBottom]
Lines.Strings = (
'Memo1'
)
ScrollBars = ssAutoBoth
TabOrder = 3
WordWrap = False
end
object btnSearch: TButton
Left = 390
Height = 25
Top = 24
Width = 75
Anchors = [akTop, akRight]
BorderSpacing.InnerBorder = 4
Caption = 'Search'
OnClick = btnSearchClick
TabOrder = 4
end
object edtKeywords: TEdit
Left = 127
Height = 23
Top = 188
Width = 338
Anchors = [akTop, akLeft, akRight]
TabOrder = 5
Text = 'Harry Potter'
end
end

34
wst/tags/0.4/tests/amazon/umain.lrs Normal file
View File

@ -0,0 +1,34 @@
{ Ceci est un fichier ressource g�n�r� automatiquement par Lazarus }
LazarusResources.Add('TfMain','FORMDATA',[
'TPF0'#6'TfMain'#5'fMain'#4'Left'#3'S'#1#6'Height'#3#215#1#3'Top'#3#181#0#5'W'
+'idth'#3#220#1#18'HorzScrollBar.Page'#3#219#1#18'VertScrollBar.Page'#3#214#1
+#13'ActiveControl'#7#11'edtAccessID'#7'Caption'#6#19'WST Amazon - Sample'#8
+'Position'#7#15'poDesktopCenter'#0#6'TLabel'#6'Label1'#4'Left'#2#16#6'Height'
+#2#18#3'Top'#2#24#5'Width'#2'E'#7'Caption'#6#10'Access Key'#5'Color'#7#6'clN'
+'one'#11'ParentColor'#8#0#0#6'TBevel'#6'Bevel1'#4'Left'#2#16#6'Height'#2#8#3
+'Top'#2'@'#5'Width'#3#195#1#7'Anchors'#11#5'akTop'#6'akLeft'#7'akRight'#0#5
+'Shape'#7#12'bsBottomLine'#0#0#6'TLabel'#6'Label2'#4'Left'#2#16#6'Height'#2
+#18#3'Top'#2'['#5'Width'#2'R'#7'Caption'#6#12'Search Index'#5'Color'#7#6'clN'
+'one'#11'ParentColor'#8#0#0#6'TLabel'#6'Label3'#4'Left'#2#16#6'Height'#2#18#3
+'Top'#3#142#0#5'Width'#2'R'#7'Caption'#6#12'Manufacturer'#5'Color'#7#6'clNon'
+'e'#11'ParentColor'#8#0#0#6'TLabel'#6'Label4'#4'Left'#2#16#6'Height'#2#18#3
+'Top'#3#188#0#5'Width'#2'A'#7'Caption'#6#9'Key words'#5'Color'#7#6'clNone'#11
+'ParentColor'#8#0#0#6'TBevel'#6'Bevel2'#4'Left'#2#16#6'Height'#2#8#3'Top'#3
+#216#0#5'Width'#3#194#1#7'Anchors'#11#5'akTop'#6'akLeft'#7'akRight'#0#5'Shap'
+'e'#7#12'bsBottomLine'#0#0#5'TEdit'#11'edtAccessID'#4'Left'#2'v'#6'Height'#2
+#23#3'Top'#2#24#5'Width'#3#202#0#8'TabOrder'#2#0#0#0#5'TEdit'#14'edtSearchIn'
+'dex'#4'Left'#2''#6'Height'#2#23#3'Top'#2'['#5'Width'#3'R'#1#7'Anchors'#11#5
+'akTop'#6'akLeft'#7'akRight'#0#8'TabOrder'#2#1#4'Text'#6#3'All'#0#0#5'TEdit'
+#15'edtManufacturer'#4'Left'#2''#6'Height'#2#23#3'Top'#3#142#0#5'Width'#3'R'
+#1#7'Anchors'#11#5'akTop'#6'akLeft'#7'akRight'#0#8'TabOrder'#2#2#0#0#5'TMemo'
+#6'mmoRes'#4'Left'#2#16#6'Height'#3#210#0#3'Top'#3#248#0#5'Width'#3#193#1#7
+'Anchors'#11#5'akTop'#6'akLeft'#7'akRight'#8'akBottom'#0#13'Lines.Strings'#1
+#6#5'Memo1'#0#10'ScrollBars'#7#10'ssAutoBoth'#8'TabOrder'#2#3#8'WordWrap'#8#0
+#0#7'TButton'#9'btnSearch'#4'Left'#3#134#1#6'Height'#2#25#3'Top'#2#24#5'Widt'
+'h'#2'K'#7'Anchors'#11#5'akTop'#7'akRight'#0#25'BorderSpacing.InnerBorder'#2
+#4#7'Caption'#6#6'Search'#7'OnClick'#7#14'btnSearchClick'#8'TabOrder'#2#4#0#0
+#5'TEdit'#11'edtKeywords'#4'Left'#2''#6'Height'#2#23#3'Top'#3#188#0#5'Width'
+#3'R'#1#7'Anchors'#11#5'akTop'#6'akLeft'#7'akRight'#0#8'TabOrder'#2#5#4'Text'
+#6#12'Harry Potter'#0#0#0
]);

120
wst/tags/0.4/tests/amazon/umain.pas Normal file
View File

@ -0,0 +1,120 @@
unit umain;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs,
AWSECommerceService, StdCtrls, ExtCtrls, Buttons;
type
{ TfMain }
TfMain = class(TForm)
Bevel1: TBevel;
Bevel2: TBevel;
btnSearch: TButton;
edtAccessID: TEdit;
edtKeywords: TEdit;
edtSearchIndex: TEdit;
edtManufacturer: TEdit;
Label1: TLabel;
Label2: TLabel;
Label3: TLabel;
Label4: TLabel;
mmoRes: TMemo;
procedure btnSearchClick(Sender: TObject);
private
{ private declarations }
public
{ public declarations }
end;
var
fMain: TfMain;
implementation
uses soap_formatter,
synapse_http_protocol,
AWSECommerceService_proxy,
metadata_repository;
{ TfMain }
procedure TfMain.btnSearchClick(Sender: TObject);
var
locService : AWSECommerceServicePortType;
rqst : ItemSearch_Type;
rsps : ItemSearchResponse_Type;
rspsItem : Items_Type;
i, j, k : Integer;
itm : Item_Type;
begin
mmoRes.Clear();
rsps := nil;
rqst := ItemSearch_Type.Create();
try
Screen.Cursor := crHourGlass;
locService := wst_CreateInstance_AWSECommerceServicePortType();
rqst.AWSAccessKeyId := edtAccessID.Text;
rqst.Request.SetLength(1);
rqst.Request[0].Manufacturer := edtManufacturer.Text;
rqst.Request[0].SearchIndex := edtSearchIndex.Text;
rqst.Request[0].Availability := Available;
rqst.Request[0].Count := 10;
rqst.Request[0].MerchantId := 'Amazon';
rqst.Request[0].ItemPage := 1;
rqst.Request[0].Keywords := edtKeywords.Text;
rsps := locService.ItemSearch(rqst);
if ( rsps.OperationRequest.Errors.Length > 0 ) then begin
mmoRes.Lines.Add(Format('Errors ( %d ) : ',[rsps.OperationRequest.Errors.Length]));
for i := 0 to Pred(rsps.OperationRequest.Errors.Length) do begin
mmoRes.Lines.Add(Format(' Error[%d] :',[i]));
mmoRes.Lines.Add(' ' + rsps.OperationRequest.Errors[i].Code);
mmoRes.Lines.Add(' ' + rsps.OperationRequest.Errors[i].Message);
end;
end else begin
mmoRes.Lines.Add(Format('Response ( %d ) : ',[rsps.Items.Length]));
if Assigned(rsps) then begin
for i := 0 to Pred(rsps.Items.Length) do begin
rspsItem := rsps.Items[i];
mmoRes.Lines.Add(' TotalPages :' + IntToStr(rspsItem.TotalPages));
mmoRes.Lines.Add(' TotalResults :' + IntToStr(rspsItem.TotalResults));
mmoRes.Lines.Add(' Items :' + IntToStr(rspsItem._Item.Length));
mmoRes.Lines.Add('');
for j := 0 to Pred(rspsItem._Item.Length) do begin
itm := rspsItem._Item[j];;
mmoRes.Lines.Add(' ASIN :' + itm.ASIN);
mmoRes.Lines.Add(' DetailPageURL :' + itm.DetailPageURL);
if Assigned(itm.ItemAttributes) then begin
mmoRes.Lines.Add(' Title :' + itm.ItemAttributes.Title);
for k := 0 to Pred(itm.ItemAttributes.Author.Length) do begin
mmoRes.Lines.Add(' Author[ ' + IntToStr(k) + ' ] ' + itm.ItemAttributes.Author.Item[k]);
end;
mmoRes.Lines.Add(' Manufacturer :' + itm.ItemAttributes.Manufacturer);
mmoRes.Lines.Add(' ProductGroup :' + itm.ItemAttributes.ProductGroup);
end;
mmoRes.Lines.Add('');
end;
end;
mmoRes.SelStart := 0;
end else begin
ShowMessage('not Assigned(rsps)');
end;
end;
finally
Screen.Cursor := crDefault;
FreeAndNil(rqst);
FreeAndNil(rsps);
end;
end;
initialization
{$I umain.lrs}
SYNAPSE_RegisterHTTP_Transport();
end.

257
wst/tags/0.4/tests/apache_module/mod_wst.lpi Normal file
View File

@ -0,0 +1,257 @@
<?xml version="1.0"?>
<CONFIG>
<ProjectOptions>
<PathDelim Value="\"/>
<Version Value="5"/>
<General>
<MainUnit Value="0"/>
<IconPath Value="./"/>
<TargetFileExt Value=".exe"/>
<ActiveEditorIndexAtStart Value="0"/>
</General>
<PublishOptions>
<Version Value="2"/>
<IgnoreBinaries Value="False"/>
<IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/>
<ExcludeFileFilter Value="*.(bak|ppu|ppw|o|so);*~;backup"/>
</PublishOptions>
<RunParams>
<local>
<FormatVersion Value="1"/>
<LaunchingApplication PathPlusParams="/usr/X11R6/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/>
</local>
</RunParams>
<RequiredPackages Count="1">
<Item1>
<PackageName Value="LCL"/>
</Item1>
</RequiredPackages>
<Units Count="26">
<Unit0>
<Filename Value="mod_wst.lpr"/>
<IsPartOfProject Value="True"/>
<UnitName Value="mod_wst"/>
<CursorPos X="3" Y="10"/>
<TopLine Value="1"/>
<EditorIndex Value="0"/>
<UsageCount Value="50"/>
<Loaded Value="True"/>
</Unit0>
<Unit1>
<Filename Value="D:\lazarusClean\others_package\apache\httpd-0.2\httpd\httpd_2_0\httpd.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="httpd"/>
<CursorPos X="1" Y="1"/>
<TopLine Value="82"/>
<UsageCount Value="50"/>
</Unit1>
<Unit2>
<Filename Value="D:\lazarusClean\others_package\apache\httpd-0.2\httpd\httpd_2_0\apr\apr.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="apr"/>
<CursorPos X="20" Y="141"/>
<TopLine Value="122"/>
<UsageCount Value="50"/>
</Unit2>
<Unit3>
<Filename Value="D:\lazarusClean\others_package\apache\httpd-0.2\httpd\httpd_2_0\apriconv\apriconv.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="apriconv"/>
<CursorPos X="1" Y="1"/>
<TopLine Value="21"/>
<UsageCount Value="50"/>
</Unit3>
<Unit4>
<Filename Value="D:\lazarusClean\others_package\apache\httpd-0.2\httpd\httpd_2_0\aprutil\aprutil.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="aprutil"/>
<CursorPos X="1" Y="1"/>
<TopLine Value="26"/>
<UsageCount Value="50"/>
</Unit4>
<Unit5>
<Filename Value="D:\lazarusClean\others_package\apache\httpd-0.2\httpd\httpd_2_0\http_config.inc"/>
<CursorPos X="11" Y="1123"/>
<TopLine Value="1112"/>
<UsageCount Value="8"/>
</Unit5>
<Unit6>
<Filename Value="D:\lazarusClean\others_package\apache\httpd-0.2\httpd\httpd_2_0\httpd.inc"/>
<CursorPos X="22" Y="751"/>
<TopLine Value="906"/>
<UsageCount Value="8"/>
</Unit6>
<Unit7>
<Filename Value="D:\lazarusClean\others_package\apache\httpd-0.2\httpd\httpd_2_0\http_protocol.inc"/>
<CursorPos X="11" Y="385"/>
<TopLine Value="385"/>
<UsageCount Value="12"/>
</Unit7>
<Unit8>
<Filename Value="D:\lazarusClean\others_package\apache\httpd-0.2\httpd\httpd_2_0\apr\apr_lib.inc"/>
<CursorPos X="7" Y="44"/>
<TopLine Value="33"/>
<UsageCount Value="8"/>
</Unit8>
<Unit9>
<Filename Value="D:\lazarusClean\others_package\apache\httpd-0.2\httpd\httpd_2_0\apr\apr_time.inc"/>
<CursorPos X="1" Y="1"/>
<TopLine Value="224"/>
<UsageCount Value="8"/>
</Unit9>
<Unit10>
<Filename Value="D:\lazarusClean\others_package\apache\httpd-0.2\httpd\httpd_2_0\apr\apr_network_io.inc"/>
<CursorPos X="1" Y="1"/>
<TopLine Value="162"/>
<UsageCount Value="8"/>
</Unit10>
<Unit11>
<Filename Value="D:\lazarusClean\fpc\2.0.4\source\rtl\inc\systemh.inc"/>
<CursorPos X="36" Y="679"/>
<TopLine Value="669"/>
<UsageCount Value="8"/>
</Unit11>
<Unit12>
<Filename Value="D:\lazarusClean\fpc\2.0.4\source\rtl\win32\sysutils.pp"/>
<UnitName Value="sysutils"/>
<CursorPos X="1" Y="1"/>
<TopLine Value="45"/>
<UsageCount Value="8"/>
</Unit12>
<Unit13>
<Filename Value="wst_apache_binding.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="wst_apache_binding"/>
<CursorPos X="29" Y="298"/>
<TopLine Value="113"/>
<EditorIndex Value="1"/>
<UsageCount Value="50"/>
<Loaded Value="True"/>
</Unit13>
<Unit14>
<Filename Value="D:\lazarusClean\others_package\apache\httpd-0.2\httpd\httpd_2_0\http_log.inc"/>
<CursorPos X="11" Y="204"/>
<TopLine Value="193"/>
<UsageCount Value="8"/>
</Unit14>
<Unit15>
<Filename Value="D:\lazarusClean\fpc\2.0.4\source\rtl\inc\system.inc"/>
<CursorPos X="33" Y="1063"/>
<TopLine Value="1025"/>
<UsageCount Value="8"/>
</Unit15>
<Unit16>
<Filename Value="D:\lazarusClean\others_package\apache\httpd-0.2\httpd\httpd_2_0\apr\apr_errno.inc"/>
<CursorPos X="23" Y="131"/>
<TopLine Value="116"/>
<UsageCount Value="8"/>
</Unit16>
<Unit17>
<Filename Value="..\..\metadata_repository.pas"/>
<UnitName Value="metadata_repository"/>
<CursorPos X="19" Y="105"/>
<TopLine Value="94"/>
<EditorIndex Value="4"/>
<UsageCount Value="24"/>
<Loaded Value="True"/>
</Unit17>
<Unit18>
<Filename Value="..\..\metadata_wsdl.pas"/>
<UnitName Value="metadata_wsdl"/>
<CursorPos X="5" Y="20"/>
<TopLine Value="1"/>
<EditorIndex Value="6"/>
<UsageCount Value="24"/>
<Loaded Value="True"/>
</Unit18>
<Unit19>
<Filename Value="D:\lazarusClean\fpc\2.0.4\source\rtl\objpas\classes\classesh.inc"/>
<CursorPos X="15" Y="616"/>
<TopLine Value="605"/>
<UsageCount Value="8"/>
</Unit19>
<Unit20>
<Filename Value="D:\lazarusClean\fpc\2.0.4\source\rtl\objpas\classes\streams.inc"/>
<CursorPos X="5" Y="339"/>
<TopLine Value="334"/>
<UsageCount Value="8"/>
</Unit20>
<Unit21>
<Filename Value="D:\lazarusClean\others_package\apache\httpd-0.2\httpd\httpd_2_0\apr\apr_tables.inc"/>
<CursorPos X="23" Y="230"/>
<TopLine Value="219"/>
<UsageCount Value="8"/>
</Unit21>
<Unit22>
<Filename Value="..\..\server_binary_formatter.pas"/>
<UnitName Value="server_binary_formatter"/>
<CursorPos X="3" Y="25"/>
<TopLine Value="14"/>
<EditorIndex Value="3"/>
<UsageCount Value="24"/>
<Loaded Value="True"/>
</Unit22>
<Unit23>
<Filename Value="..\..\base_binary_formatter.pas"/>
<UnitName Value="base_binary_formatter"/>
<CursorPos X="1" Y="1"/>
<TopLine Value="1"/>
<UsageCount Value="8"/>
</Unit23>
<Unit24>
<Filename Value="..\..\server_service_intf.pas"/>
<UnitName Value="server_service_intf"/>
<CursorPos X="5" Y="20"/>
<TopLine Value="6"/>
<EditorIndex Value="2"/>
<UsageCount Value="16"/>
<Loaded Value="True"/>
</Unit24>
<Unit25>
<Filename Value="..\..\wst_resources_imp.pas"/>
<UnitName Value="wst_resources_imp"/>
<CursorPos X="1" Y="1"/>
<TopLine Value="1"/>
<EditorIndex Value="5"/>
<UsageCount Value="12"/>
<Loaded Value="True"/>
</Unit25>
</Units>
<JumpHistory Count="1" HistoryIndex="0">
<Position1>
<Filename Value="mod_wst.lpr"/>
<Caret Line="47" Column="36" TopLine="1"/>
</Position1>
</JumpHistory>
</ProjectOptions>
<CompilerOptions>
<Version Value="5"/>
<PathDelim Value="\"/>
<Target>
<Filename Value="mod_wst.so"/>
</Target>
<SearchPaths>
<OtherUnitFiles Value="$(LazarusDir)\others_package\apache\httpd\httpd-2.2\;$(LazarusDir)\others_package\apache\httpd\httpd-2.2\apr\;$(LazarusDir)\others_package\apache\httpd\httpd-2.2\apriconv\;$(LazarusDir)\others_package\apache\httpd\httpd-2.2\aprutil\;..\..\;..\..\tests\calculator\;..\..\tests\calculator\srv\"/>
<UnitOutputDirectory Value="obj"/>
<SrcPath Value="D:\lazarusClean\others_package\apache\httpd-0.2\httpd\httpd_2_0\;D:\lazarusClean\others_package\apache\httpd-0.2\httpd\httpd_2_0\apr\;D:\lazarusClean\others_package\apache\httpd-0.2\httpd\httpd_2_0\apriconv\;D:\lazarusClean\others_package\apache\httpd-0.2\httpd\httpd_2_0\aprutil\;..\..\;..\..\tests\calculator\;..\..\tests\calculator\srv\"/>
</SearchPaths>
<Parsing>
<SyntaxOptions>
<CStyleMacros Value="True"/>
</SyntaxOptions>
</Parsing>
<CodeGeneration>
<Generate Value="Faster"/>
</CodeGeneration>
<Linking>
<Options>
<ExecutableType Value="Library"/>
</Options>
</Linking>
<Other>
<CustomOptions Value="-WR
"/>
<CompilerPath Value="$(CompPath)"/>
</Other>
</CompilerOptions>
</CONFIG>

51
wst/tags/0.4/tests/apache_module/mod_wst.lpr Normal file
View File

@ -0,0 +1,51 @@
library mod_wst;
{$mode objfpc}{$H+}
{$IFDEF WIN32}
{$DEFINE WINDOWS}
{$ENDIF}
uses
SysUtils,
httpd, apr, apriconv, aprutil, wst_apache_binding;
var
wst_module: module; {$ifdef Unix} public name 'wst_module'; {$endif}
default_module_ptr: Pmodule;
const
MODULE_NAME = 'mod_wst.so';
{$ifdef WINDOWS}
exports
wst_module name 'wst_module';
{$endif}
function DefaultHandler(r: Prequest_rec): Integer; cdecl;
begin
if not SameText(r^.handler, 'wst-handler') then
begin
Result := DECLINED;
Exit;
end;
Result := wst_RequestHandler(r);
end;
procedure RegisterHooks(p: Papr_pool_t); cdecl;
begin
ap_hook_handler(@DefaultHandler, nil, nil, APR_HOOK_MIDDLE);
end;
begin
default_module_ptr := @wst_module;
FillChar(default_module_ptr^, SizeOf(default_module_ptr^), 0);
STANDARD20_MODULE_STUFF(default_module_ptr^);
with wst_module do
begin
name := MODULE_NAME;
magic := MODULE_MAGIC_COOKIE;
register_hooks := @RegisterHooks;
end;
end.

318
wst/tags/0.4/tests/apache_module/wst_apache_binding.pas Normal file
View File

@ -0,0 +1,318 @@
//{$DEFINE WST_DBG}
unit wst_apache_binding;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils,
httpd, apr, apriconv, aprutil;
const
sWST_ROOT = 'wst';
sSEPARATOR = '/';
sSERVICES_PREFIXE = 'services';
sWSDL = 'WSDL';
sHTTP_BINARY_CONTENT_TYPE = 'application/octet-stream';
sCONTENT_TYPE = 'Content-Type';
function wst_RequestHandler(r: Prequest_rec): Integer;
implementation
uses base_service_intf,
server_service_intf, server_service_imputils,
server_service_soap, server_binary_formatter,
metadata_repository, metadata_wsdl, DOM, XMLWrite,
calculator, calculator_binder, calculator_imp,
metadata_service, metadata_service_binder, metadata_service_imp;
type
TRequestInfo = record
Root : string;
URI : string;
ContentType : string;
Buffer : string;
end;
TResponseInfo = record
ContentText : string;
ContentType : string;
end;
procedure SaveStringToFile(const AStr,AFile:string;const AKeepExisting : Boolean);
begin
with TMemoryStream.Create() do try
if AKeepExisting and FileExists(AFile) then begin
LoadFromFile(AFile);
Position := Size;
end;
if ( Length(AStr) > 0 ) then
Write(AStr[1],Length(AStr));
SaveToFile(AFile);
finally
Free();
end;
end;
function ReadBuffer(r : Prequest_rec; out rbuf : string ) : Integer;
var
argsbuffer : string;
rsize, len_read, rpos : Integer;
loc_length : Integer;
begin
rbuf := '';
Result := ap_setup_client_block(r, REQUEST_CHUNKED_ERROR);
if ( Result <> OK ) then
Exit;
if ( ap_should_client_block(r) <> 0 ) then begin
SetLength(argsbuffer,HUGE_STRING_LEN);
FillChar(argsbuffer[1],Length(argsbuffer),0);
rsize := 0; len_read := 0; rpos := 0;
loc_length := r^.remaining;
SetLength(rbuf, loc_length );
while True do begin
len_read := ap_get_client_block(r, @(argsbuffer[1]), Length(argsbuffer));
if ( len_read <= 0 ) then
Exit;
if ( ( rpos + len_read ) > loc_length ) then
rsize := loc_length - rpos
else
rsize := len_read;
Move(argsbuffer[1],rbuf[ ( 1 + rpos ) ], rsize);
Inc(rpos,rsize);
end;
end;
end;
function ExtractNextPathElement(var AFullPath : string):string;
var
i : SizeInt;
begin
Result := '';
if ( Length(AFullPath) > 0 ) then begin
while ( Length(AFullPath) > 0 ) and ( AFullPath[1] = sSEPARATOR ) do begin
Delete(AFullPath,1,1);
end;
i := Pos(sSEPARATOR,AFullPath);
if ( i < 1 ) then begin
Result := AFullPath;
AFullPath := '';
end else begin
Result := Copy(AFullPath,1,Pred(i));
Delete(AFullPath,1,i);
end;
end;
end;
function GetWSDL(const ARepName, ARootAddress: shortstring):string;
var
strm : TMemoryStream;
rep : PServiceRepository;
doc :TXMLDocument;
i : SizeInt;
s : string;
begin
Result := '';
rep := nil;
doc := Nil;
i := GetModuleMetadataMngr().IndexOfName(ARepName);
if ( i < 0 ) then
Exit;
strm := TMemoryStream.Create();
try
s := GetModuleMetadataMngr().GetRepositoryName(i);
GetModuleMetadataMngr().LoadRepositoryName(s,ARootAddress,rep);
strm.Clear();
doc := TXMLDocument.Create();
GenerateWSDL(rep,doc);
WriteXMLFile(doc,strm);
i := strm.Size;
if ( i > 0 ) then begin
SetLength(Result,i);
Move(strm.memory^,Result[1],i);
end;
finally
doc.Free();
strm.Free();
GetModuleMetadataMngr().ClearRepository(rep);
end;
end;
function GenerateWSDLTable(): string;
var
r : IModuleMetadataMngr;
i : Integer;
begin
r := GetModuleMetadataMngr();
Result := '<html>' +
'<head>'+
'<title>'+
'The Web Service Toolkit generated Metadata table'+
'</title>'+
'<body>' +
'<p BGCOLOR="#DDEEFF"><FONT FACE="Arial" COLOR="#0000A0" SIZE="+2">The following repositories has available. Click on the link to view the corresponding WSDL.</FONT></p>'+
'<table width="100%">';
for i := 0 to Pred(r.GetCount()) do
Result := Result + '<tr>' +
'<td>' +
Format('<a href="%s">',[sSEPARATOR+sWST_ROOT+sSEPARATOR+sSERVICES_PREFIXE+sSEPARATOR+sWSDL+sSEPARATOR+r.GetRepositoryName(i)])+
r.GetRepositoryName(i) +
'</a>'+
'</td>' +
'</tr>';
Result := Result +
'</tr>'+
'</table>'+
'</body>'+
'</head>'+
'</html>';
end;
procedure ProcessWSDLRequest(
const ARequestInfo : TRequestInfo;
out AResponseInfo : TResponseInfo
);
var
locRepName, strBuff, locPath : string;
i : Integer;
begin
FillChar(AResponseInfo,SizeOf(TResponseInfo),#0);
locPath := ARequestInfo.URI;
locRepName := ExtractNextPathElement(locPath);
if AnsiSameText(sWSDL,locRepName) then
locRepName := ExtractNextPathElement(locPath);
strBuff := GetWSDL(locRepName,ARequestInfo.Root);
i := Length(strBuff);
if ( i > 0 ) then begin
AResponseInfo.ContentType := 'text/xml';
AResponseInfo.ContentText := strBuff;
Exit;
end;
AResponseInfo.ContentText := GenerateWSDLTable();
AResponseInfo.ContentType := 'text/html';
end;
function ProcessServiceRequest(
const ARequestInfo : TRequestInfo;
out AResponseInfo : TResponseInfo
):Boolean;
var
trgt,ctntyp, loc_path : string;
rqst : IRequestBuffer;
inStream, outStream: TMemoryStream;
i : Integer;
begin
FillChar(AResponseInfo,SizeOf(TResponseInfo),#0);
loc_path := ARequestInfo.URI;
trgt := ExtractNextPathElement(loc_path);
Result := False;
if AnsiSameText(sWSDL,trgt) then
Exit;
Result := True;
inStream := nil;
outStream := nil;
try
inStream := TMemoryStream.Create();
outStream := TMemoryStream.Create();
ctntyp := ARequestInfo.ContentType;
i := Length(ARequestInfo.Buffer);
if ( i > 0 ) then
inStream.Write(ARequestInfo.Buffer[1],i);
inStream.Position := 0;
if AnsiSameText(sBINARY_CONTENT_TYPE,ctntyp) then
AResponseInfo.ContentType := sHTTP_BINARY_CONTENT_TYPE
else
AResponseInfo.ContentType := ctntyp;
rqst := TRequestBuffer.Create(trgt,ctntyp,inStream,outStream);
HandleServiceRequest(rqst);
i := outStream.Size;
if ( i > 0 ) then begin
SetLength(AResponseInfo.ContentText,i);
Move(outStream.Memory^,AResponseInfo.ContentText[1],i);
end;
finally
outStream.Free();
inStream.Free();
{$IFDEF WST_DBG}
{SaveStringToFile('RequestInfo.ContentType=' + ARequestInfo.ContentType + LineEnding,'E:\Inoussa\Sources\lazarus\wst\v0.3\tests\apache_module\log.log',False);
SaveStringToFile('RequestInfo.Buffer=' + ARequestInfo.Buffer + LineEnding,'E:\Inoussa\Sources\lazarus\wst\v0.3\tests\apache_module\log.log',True);
SaveStringToFile('RequestInfo.URI=' + ARequestInfo.URI + LineEnding,'E:\Inoussa\Sources\lazarus\wst\v0.3\tests\apache_module\log.log',True);
SaveStringToFile('ResponseInfo.ContentType=' + AResponseInfo.ContentType + LineEnding,'E:\Inoussa\Sources\lazarus\wst\v0.3\tests\apache_module\log.log',True);
SaveStringToFile('ResponseInfo.ContentText=' + AResponseInfo.ContentText + LineEnding,'E:\Inoussa\Sources\lazarus\wst\v0.3\tests\apache_module\log.log',True);
}
{$ENDIF}
end;
end;
function wst_RequestHandler(r: Prequest_rec): Integer;
function FillRequestInfo(var ARequestInfo : TRequestInfo):Integer;
begin
ARequestInfo.ContentType := apr_table_get(r^.headers_in,sCONTENT_TYPE);
ARequestInfo.Root := ap_get_server_name(r) + sSEPARATOR + sWST_ROOT + sSEPARATOR;
ARequestInfo.URI := r^.uri;
Result := ReadBuffer(r,ARequestInfo.Buffer);
end;
var
sInputBuffer : string;
iRet, iLen : Integer;
loc_RequestInfo : TRequestInfo;
loc_ResponseInfo : TResponseInfo;
begin
Result := FillRequestInfo(loc_RequestInfo);
if not AnsiSameText(sWST_ROOT,ExtractNextPathElement(loc_RequestInfo.URI)) then
Result := DECLINED;
if ( Result <> OK ) then
Exit;
try
if AnsiSameText(sSERVICES_PREFIXE,ExtractNextPathElement(loc_RequestInfo.URI)) then begin
if not ProcessServiceRequest(loc_RequestInfo,loc_ResponseInfo) then
ProcessWSDLRequest(loc_RequestInfo,loc_ResponseInfo);
end else begin
ProcessWSDLRequest(loc_RequestInfo,loc_ResponseInfo);
end;
ap_set_content_type(r, PCHAR(loc_ResponseInfo.ContentType));
if AnsiSameText(sHTTP_BINARY_CONTENT_TYPE,loc_ResponseInfo.ContentType) then begin
ap_set_content_length(r,Length(loc_ResponseInfo.ContentText));
ap_rwrite(@(loc_ResponseInfo.ContentText[1]),Length(loc_ResponseInfo.ContentText),r);
ap_rflush(r);
end else begin
ap_rputs(PCHAR(loc_ResponseInfo.ContentText), r);
end;
Result := OK;
Exit;
except
on e : Exception do begin
ap_set_content_type(r, 'text/html');
ap_rputs('<HTML><HEAD> <TITLE>Error</TITLE></HEAD>' + LineEnding, r);
ap_rputs('<BODY></BODY></HTML>',r);
ap_rprintf(r, '<BODY><H1>"%s"</H1></BODY></HTML>' + LineEnding, [PCHAR(e.Message)]);
Exit;
end;
end;
end;
initialization
RegisterStdTypes();
Server_service_RegisterBinaryFormat();
Server_service_RegisterSoapFormat();
RegisterCalculatorImplementationFactory();
Server_service_RegisterCalculatorService();
Server_service_RegisterWSTMetadataServiceService();
RegisterWSTMetadataServiceImplementationFactory();
end.

121
wst/tags/0.4/tests/calculator/calculator.pas Normal file
View File

@ -0,0 +1,121 @@
unit calculator;
{$IFDEF FPC}
{$mode objfpc}{$H+}
{$DEFINE HAS_QWORD}
{$DEFINE USE_INLINE}
{$ELSE}
{$UNDEF HAS_QWORD}
{$UNDEF USE_INLINE}
{$ENDIF}
interface
uses SysUtils,
base_service_intf;
Type
TCalc_Op = ( coAdd, coSub, coMul, coDiv );
{ TCalcHeader }
TCalcHeader = class(THeaderBlock)
private
FLogin: string;
FPassword: string;
FWantedPrecision: Integer;
published
property Login : string read FLogin write FLogin;
property Password : string read FPassword write FPassword;
property WantedPrecision : Integer read FWantedPrecision write FWantedPrecision;
end;
{ TCalcResultHeader }
TCalcResultHeader = class(TCalcHeader)
private
FSessionID: string;
FTimeStamp: string;
published
property TimeStamp : string read FTimeStamp write FTimeStamp;
property SessionID : string read FSessionID write FSessionID;
end;
TBinaryArgsResult = class(TBaseComplexRemotable)
private
FArg_A: Integer;
FArg_B: Integer;
FArg_OP: string;
FArg_OpEnum: TCalc_Op;
FArg_R: Integer;
FComment: string;
private
function GetHasComment: boolean;
Published
Property Arg_A : Integer Read FArg_A Write FArg_A;
Property Arg_B : Integer Read FArg_B Write FArg_B;
Property Arg_R : Integer Read FArg_R Write FArg_R;
Property Arg_OP : string Read FArg_OP Write FArg_OP;
Property Arg_OpEnum : TCalc_Op Read FArg_OpEnum Write FArg_OpEnum;
property Comment : string read FComment write FComment stored GetHasComment;
End;
TBinaryArgsResultArray = class(TBaseObjectArrayRemotable)
private
function GetItem(AIndex: Integer): TBinaryArgsResult;
Public
class function GetItemClass():TBaseRemotableClass;override;
Property Item[AIndex:Integer] : TBinaryArgsResult Read GetItem;Default;
End;
ICalculator = Interface
function AddInt(
Const A:Integer;
Const B:Integer
):TBinaryArgsResult;
function DivInt(
Const A:Integer;
Const B:Integer
):Integer;
function DoAllOperations(
Const A:Integer;
Const B:Integer
):TBinaryArgsResultArray;
function DoOperation(
Const A:Integer;
Const B:Integer;
const AOperation : TCalc_Op
):TBinaryArgsResult;
End;
implementation
{ TBinaryArgsResultArray }
function TBinaryArgsResultArray.GetItem(AIndex: Integer): TBinaryArgsResult;
begin
Result := Inherited GetItem(AIndex) as TBinaryArgsResult;
end;
class function TBinaryArgsResultArray.GetItemClass(): TBaseRemotableClass;
begin
Result := TBinaryArgsResult;
end;
{ TBinaryArgsResult }
function TBinaryArgsResult.GetHasComment: boolean;
begin
Result := ( Length(Trim(FComment)) > 0 ) ;
end;
Initialization
GetTypeRegistry().Register('urn:calculator',TypeInfo(TCalc_Op),'TCalc_Op');
GetTypeRegistry().Register('urn:calculator',TypeInfo(TBinaryArgsResult),'TBinaryArgsResult');
GetTypeRegistry().Register('urn:calculator',TypeInfo(TBinaryArgsResultArray),'TBinaryArgsResultArray');
GetTypeRegistry().Register('urn:calculator',TypeInfo(TCalcHeader),'CalcHeader').AddPascalSynonym('TCalcHeader');
GetTypeRegistry().Register('urn:calculator',TypeInfo(TCalcResultHeader),'CalcResultHeader').AddPascalSynonym('TCalcResultHeader');
end.

BIN
wst/tags/0.4/tests/calculator/calculator.wst_meta Normal file
View File

Binary file not shown.

251
wst/tags/0.4/tests/calculator/client/calc_client.lpi Normal file
View File

@ -0,0 +1,251 @@
<?xml version="1.0"?>
<CONFIG>
<ProjectOptions>
<PathDelim Value="\"/>
<Version Value="5"/>
<General>
<Flags>
<MainUnitHasUsesSectionForAllUnits Value="False"/>
<MainUnitHasCreateFormStatements Value="False"/>
<MainUnitHasTitleStatement Value="False"/>
</Flags>
<MainUnit Value="0"/>
<IconPath Value="./"/>
<TargetFileExt Value=".exe"/>
</General>
<PublishOptions>
<Version Value="2"/>
<IgnoreBinaries Value="False"/>
<IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/>
<ExcludeFileFilter Value="*.(bak|ppu|ppw|o|so);*~;backup"/>
</PublishOptions>
<RunParams>
<local>
<FormatVersion Value="1"/>
<LaunchingApplication PathPlusParams="/usr/X11R6/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/>
</local>
</RunParams>
<Units Count="21">
<Unit0>
<Filename Value="calc_client.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="calc_client"/>
<CursorPos X="22" Y="49"/>
<TopLine Value="1"/>
<UsageCount Value="68"/>
</Unit0>
<Unit1>
<Filename Value="calculator_proxy.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="calculator_proxy"/>
<CursorPos X="44" Y="155"/>
<TopLine Value="4"/>
<UsageCount Value="68"/>
</Unit1>
<Unit2>
<Filename Value="..\..\..\..\base_service_intf.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="base_service_intf"/>
<CursorPos X="87" Y="348"/>
<TopLine Value="348"/>
<UsageCount Value="44"/>
</Unit2>
<Unit3>
<Filename Value="..\..\..\..\service_intf.pas"/>
<UnitName Value="service_intf"/>
<CursorPos X="1" Y="1"/>
<TopLine Value="121"/>
<UsageCount Value="30"/>
</Unit3>
<Unit4>
<Filename Value="..\..\..\..\soap_formatter.pas"/>
<UnitName Value="soap_formatter"/>
<CursorPos X="1" Y="17"/>
<TopLine Value="1"/>
<UsageCount Value="24"/>
</Unit4>
<Unit5>
<Filename Value="..\..\..\..\binary_formatter.pas"/>
<UnitName Value="binary_formatter"/>
<CursorPos X="1" Y="40"/>
<TopLine Value="31"/>
<UsageCount Value="34"/>
<Bookmarks Count="1">
<Item0 X="26" Y="94" ID="3"/>
</Bookmarks>
</Unit5>
<Unit6>
<Filename Value="..\..\..\..\ics_tcp_protocol.pas"/>
<UnitName Value="ics_tcp_protocol"/>
<CursorPos X="55" Y="127"/>
<TopLine Value="111"/>
<UsageCount Value="25"/>
</Unit6>
<Unit7>
<Filename Value="..\..\..\..\ics_http_protocol.pas"/>
<UnitName Value="ics_http_protocol"/>
<CursorPos X="23" Y="1"/>
<TopLine Value="2"/>
<UsageCount Value="13"/>
</Unit7>
<Unit8>
<Filename Value="..\..\..\..\base_soap_formatter.pas"/>
<UnitName Value="base_soap_formatter"/>
<CursorPos X="39" Y="730"/>
<TopLine Value="729"/>
<UsageCount Value="24"/>
</Unit8>
<Unit9>
<Filename Value="..\calculator.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="calculator"/>
<CursorPos X="53" Y="67"/>
<TopLine Value="33"/>
<UsageCount Value="68"/>
</Unit9>
<Unit10>
<Filename Value="D:\lazarusClean\fpcsrc\rtl\win32\system.pp"/>
<UnitName Value="System"/>
<CursorPos X="4" Y="506"/>
<TopLine Value="496"/>
<UsageCount Value="9"/>
</Unit10>
<Unit11>
<Filename Value="D:\lazarusClean\fpcsrc\fcl\xml\xmlread.pp"/>
<UnitName Value="XMLRead"/>
<CursorPos X="26" Y="245"/>
<TopLine Value="240"/>
<UsageCount Value="6"/>
</Unit11>
<Unit12>
<Filename Value="D:\Lazarus\others_package\ics\latest_distr\Delphi\Vc32\WSocket.pas"/>
<UnitName Value="WSocket"/>
<CursorPos X="24" Y="844"/>
<TopLine Value="834"/>
<UsageCount Value="6"/>
</Unit12>
<Unit13>
<Filename Value="..\..\..\..\base_binary_formatter.pas"/>
<UnitName Value="base_binary_formatter"/>
<CursorPos X="21" Y="885"/>
<TopLine Value="895"/>
<UsageCount Value="28"/>
<Bookmarks Count="2">
<Item0 X="24" Y="969" ID="1"/>
<Item1 X="19" Y="802" ID="2"/>
</Bookmarks>
</Unit13>
<Unit14>
<Filename Value="D:\lazarusClean\fpcsrc\fcl\inc\contnrs.pp"/>
<UnitName Value="contnrs"/>
<CursorPos X="55" Y="791"/>
<TopLine Value="777"/>
<UsageCount Value="9"/>
</Unit14>
<Unit15>
<Filename Value="D:\lazarusClean\fpcsrc\rtl\objpas\typinfo.pp"/>
<UnitName Value="typinfo"/>
<CursorPos X="31" Y="36"/>
<TopLine Value="17"/>
<UsageCount Value="13"/>
</Unit15>
<Unit16>
<Filename Value="..\..\..\..\binary_streamer.pas"/>
<UnitName Value="binary_streamer"/>
<CursorPos X="3" Y="30"/>
<TopLine Value="20"/>
<UsageCount Value="21"/>
</Unit16>
<Unit17>
<Filename Value="D:\lazarusClean\fpcsrc\rtl\objpas\objpas.pp"/>
<UnitName Value="objpas"/>
<CursorPos X="5" Y="108"/>
<TopLine Value="91"/>
<UsageCount Value="9"/>
</Unit17>
<Unit18>
<Filename Value="D:\lazarusClean\fpcsrc\rtl\inc\systemh.inc"/>
<CursorPos X="1" Y="1"/>
<TopLine Value="83"/>
<UsageCount Value="9"/>
</Unit18>
<Unit19>
<Filename Value="..\..\..\metadata_repository.pas"/>
<UnitName Value="metadata_repository"/>
<CursorPos X="6" Y="105"/>
<TopLine Value="94"/>
<UsageCount Value="10"/>
</Unit19>
<Unit20>
<Filename Value="..\..\..\ics_tcp_protocol.pas"/>
<UnitName Value="ics_tcp_protocol"/>
<CursorPos X="3" Y="22"/>
<TopLine Value="8"/>
<UsageCount Value="10"/>
</Unit20>
</Units>
<JumpHistory Count="0" HistoryIndex="-1"/>
</ProjectOptions>
<CompilerOptions>
<Version Value="5"/>
<PathDelim Value="\"/>
<SearchPaths>
<OtherUnitFiles Value="C:\LazarusClean\others_package\ics\latest_distr\Delphi\Vc32\;..\..\..\;..\..\..\tests\calculator\"/>
<UnitOutputDirectory Value="obj"/>
<SrcPath Value="..\..\..\;C:\LazarusClean\others_package\ics\latest_distr\Delphi\Vc32\"/>
</SearchPaths>
<CodeGeneration>
<Generate Value="Faster"/>
</CodeGeneration>
<Other>
<CustomOptions Value="-Xi
"/>
<CompilerPath Value="$(CompPath)"/>
</Other>
</CompilerOptions>
<Debugging>
<BreakPoints Count="9">
<Item1>
<Source Value="..\..\..\google_api\home\inoussa\Projets\Laz\tests\soap\test_soap.pas"/>
<Line Value="15"/>
</Item1>
<Item2>
<Source Value="..\..\..\google_api\home\inoussa\Projets\Laz\tests\soap\test_soap.pas"/>
<Line Value="16"/>
</Item2>
<Item3>
<Source Value="..\..\..\google_api\home\inoussa\Projets\Laz\tests\soap\test_soap.pas"/>
<Line Value="18"/>
</Item3>
<Item4>
<Source Value="..\..\..\google_api\home\inoussa\Projets\Laz\tests\soap\googleintfimpunit.pas"/>
<Line Value="63"/>
</Item4>
<Item5>
<Source Value="..\..\..\google_api\home\inoussa\Projets\Laz\v0.2\indy_http_protocol.pas"/>
<Line Value="69"/>
</Item5>
<Item6>
<Source Value="..\..\..\google_api\home\inoussa\Projets\Laz\v0.2\service_intf.pas"/>
<Line Value="567"/>
</Item6>
<Item7>
<Source Value="..\..\..\google_api\home\inoussa\Projets\Laz\v0.2\imp_utils.pas"/>
<Line Value="83"/>
</Item7>
<Item8>
<Source Value="..\..\..\..\base_service_intf.pas"/>
<Line Value="505"/>
</Item8>
<Item9>
<Source Value="..\..\..\..\base_binary_formatter.pas"/>
<Line Value="928"/>
</Item9>
</BreakPoints>
<Watches Count="1">
<Item1>
<Expression Value="ASource.Memory^"/>
</Item1>
</Watches>
</Debugging>
</CONFIG>

83
wst/tags/0.4/tests/calculator/client/calc_client.pas Normal file
View File

@ -0,0 +1,83 @@
program calc_client;
{$mode objfpc}{$H+}
uses
Classes, SysUtils,
service_intf,
base_soap_formatter, soap_formatter, binary_formatter,
ics_tcp_protocol,
calculator, calculator_proxy, TypInfo;
Var
calcObj : ICalculator;
i, j, k : Integer;
rk : TBinaryArgsResult;
vA : TBinaryArgsResultArray;
f : IFormatterClient;
s : TStream;
msgProt : string;
begin
{ vA := TBinaryArgsResultArray.Create();
vA.SetLength(2);
f := TBinaryFormatter.Create() as IFormatterClient;
f.BeginCall('pr','trgt');
f.Put('xx',TypeInfo(TBinaryArgsResultArray),vA);
f.EndCall();
s:= TMemoryStream.Create();
f.SaveToStream(s);
f := Nil;
f := TBinaryFormatter.Create() as IFormatterClient;
s.Position := 0;
WriteLn('------------------------------------------');
WriteLn('------------------------------------------');
f.LoadFromStream(s);
ReadLn();
Exit;}
//Client
Write('Enter msg protocol :');
ReadLn(msgProt);
If Not( AnsiSameText(msgProt,'SOAP') Or AnsiSameText(msgProt,'binary') ) Then
msgProt := 'binary';
Writeln('USED Msg protocol = ',msgProt);
ICS_RegisterTCP_Transport();
rk := nil;
Try
Try
calcObj := TCalculator_Proxy.Create(
'ICalculator', // Target
msgProt,//'SOAP',//'binary', // Protocol Data
'TCP:Address=127.0.0.1;Port=1234;target=ICalculator' // Transport Data
);
WriteLn('Calculator test.');
Write('Enter A = '); ReadLn(i);
Write('Enter B = '); ReadLn(j);
k := calcObj.DivInt(i,j);
Write(' A / B = '); WriteLn(k);
rk := calcObj.AddInt(i,j);
WriteLn(Format(' ( %d %s %d ) = %d',[rk.Arg_A, rk.Arg_OP, rk.Arg_B, rk.Arg_R]));
WriteLn('----------------------------------------------');
vA := calcObj.DoAllOperations(i,j);
Try
For i := 0 To Pred(vA.Length) Do
WriteLn(Format(' ( %d %s %d ) = %d; OP=%s',[vA[i].Arg_A, vA[i].Arg_OP, vA[i].Arg_B, vA[i].Arg_R,GetEnumName(TypeInfo(TCalc_Op),Ord(vA[i].Arg_OpEnum))]));
Finally
vA.Free();
End;
Except
On E : ESOAPException Do Begin
WriteLn('Oups ( SOAP Exception ) :');
WriteLn(' Code=',E.FaultCode);
WriteLn(' String=',E.FaultString);
End;
On E : Exception Do Begin
WriteLn('Oups:');
WriteLn(E.Message);
End;
End;
Finally
rk.Free();
End;
ReadLn();
end.

13
wst/tags/0.4/tests/calculator/client/calculator.wst Normal file
View File

@ -0,0 +1,13 @@
GetWSTResourceManager().AddResource('CALCULATOR',
#0#0#0#20'WST_METADATA_0.2.2.0'#0#0#0#10'calculator'#1#0#0#0#11'ICalculator'#4
+#0#0#0#6'AddInt'#3#0#0#0#1'A'#0#0#0#7'Integer'#0#0#0#0#0#0#0#1#0#0#0#1'B'#0#0
+#0#7'Integer'#0#0#0#0#0#0#0#1#0#0#0#6'result'#0#0#0#17'TBinaryArgsResult'#0#0
+#0#0#0#0#0#3#0#0#0#6'DivInt'#3#0#0#0#1'A'#0#0#0#7'Integer'#0#0#0#0#0#0#0#1#0
+#0#0#1'B'#0#0#0#7'Integer'#0#0#0#0#0#0#0#1#0#0#0#6'result'#0#0#0#7'Integer'#0
+#0#0#0#0#0#0#3#0#0#0#15'DoAllOperations'#3#0#0#0#1'A'#0#0#0#7'Integer'#0#0#0
+#0#0#0#0#1#0#0#0#1'B'#0#0#0#7'Integer'#0#0#0#0#0#0#0#1#0#0#0#6'result'#0#0#0
+#22'TBinaryArgsResultArray'#0#0#0#0#0#0#0#3#0#0#0#11'DoOperation'#4#0#0#0#1'A'
+#0#0#0#7'Integer'#0#0#0#0#0#0#0#1#0#0#0#1'B'#0#0#0#7'Integer'#0#0#0#0#0#0#0#1
+#0#0#0#10'AOperation'#0#0#0#8'TCalc_Op'#0#0#0#0#0#0#0#1#0#0#0#6'result'#0#0#0
+#17'TBinaryArgsResult'#0#0#0#0#0#0#0#3''
);

164
wst/tags/0.4/tests/calculator/client/calculator_proxy.pas Normal file
View File

@ -0,0 +1,164 @@
{
This unit has been produced by ws_helper.
Input unit name : "calculator".
This unit name : "calculator_proxy".
Date : "12/11/2006 11:21".
}
Unit calculator_proxy;
{$mode objfpc}{$H+}
Interface
Uses SysUtils, Classes, TypInfo, base_service_intf, service_intf, calculator;
Type
TCalculator_Proxy=class(TBaseProxy,ICalculator)
Protected
class function GetServiceType() : PTypeInfo;override;
function AddInt(
Const A : Integer;
Const B : Integer
):TBinaryArgsResult;
function DivInt(
Const A : Integer;
Const B : Integer
):Integer;
function DoAllOperations(
Const A : Integer;
Const B : Integer
):TBinaryArgsResultArray;
function DoOperation(
Const A : Integer;
Const B : Integer;
Const AOperation : TCalc_Op
):TBinaryArgsResult;
End;
Implementation
uses wst_resources_imp, metadata_repository;
{ TCalculator_Proxy implementation }
class function TCalculator_Proxy.GetServiceType() : PTypeInfo;
begin
result := TypeInfo(ICalculator);
end;
function TCalculator_Proxy.AddInt(
Const A : Integer;
Const B : Integer
):TBinaryArgsResult;
Var
locSerializer : IFormatterClient;
strPrmName : string;
Begin
locSerializer := GetSerializer();
Try
locSerializer.BeginCall('AddInt', GetTarget(),(Self as ICallContext));
locSerializer.Put('A', TypeInfo(Integer), A);
locSerializer.Put('B', TypeInfo(Integer), B);
locSerializer.EndCall();
MakeCall();
locSerializer.BeginCallRead((Self as ICallContext));
Pointer(Result) := Nil;
strPrmName := 'return';
locSerializer.Get(TypeInfo(TBinaryArgsResult), strPrmName, result);
Finally
locSerializer.Clear();
End;
End;
function TCalculator_Proxy.DivInt(
Const A : Integer;
Const B : Integer
):Integer;
Var
locSerializer : IFormatterClient;
strPrmName : string;
Begin
locSerializer := GetSerializer();
Try
locSerializer.BeginCall('DivInt', GetTarget(),(Self as ICallContext));
locSerializer.Put('A', TypeInfo(Integer), A);
locSerializer.Put('B', TypeInfo(Integer), B);
locSerializer.EndCall();
MakeCall();
locSerializer.BeginCallRead((Self as ICallContext));
strPrmName := 'return';
locSerializer.Get(TypeInfo(Integer), strPrmName, result);
Finally
locSerializer.Clear();
End;
End;
function TCalculator_Proxy.DoAllOperations(
Const A : Integer;
Const B : Integer
):TBinaryArgsResultArray;
Var
locSerializer : IFormatterClient;
strPrmName : string;
Begin
locSerializer := GetSerializer();
Try
locSerializer.BeginCall('DoAllOperations', GetTarget(),(Self as ICallContext));
locSerializer.Put('A', TypeInfo(Integer), A);
locSerializer.Put('B', TypeInfo(Integer), B);
locSerializer.EndCall();
MakeCall();
locSerializer.BeginCallRead((Self as ICallContext));
Pointer(Result) := Nil;
strPrmName := 'return';
locSerializer.Get(TypeInfo(TBinaryArgsResultArray), strPrmName, result);
Finally
locSerializer.Clear();
End;
End;
function TCalculator_Proxy.DoOperation(
Const A : Integer;
Const B : Integer;
Const AOperation : TCalc_Op
):TBinaryArgsResult;
Var
locSerializer : IFormatterClient;
strPrmName : string;
Begin
locSerializer := GetSerializer();
Try
locSerializer.BeginCall('DoOperation', GetTarget(),(Self as ICallContext));
locSerializer.Put('A', TypeInfo(Integer), A);
locSerializer.Put('B', TypeInfo(Integer), B);
locSerializer.Put('AOperation', TypeInfo(TCalc_Op), AOperation);
locSerializer.EndCall();
MakeCall();
locSerializer.BeginCallRead((Self as ICallContext));
Pointer(Result) := Nil;
strPrmName := 'return';
locSerializer.Get(TypeInfo(TBinaryArgsResult), strPrmName, result);
Finally
locSerializer.Clear();
End;
End;
initialization
{$i calculator.wst}
{$IF DECLARED(Register_calculator_ServiceMetadata)}
Register_calculator_ServiceMetadata();
{$ENDIF}
End.

13
wst/tags/0.4/tests/calculator/gui_client/calculator.wst Normal file
View File

@ -0,0 +1,13 @@
GetWSTResourceManager().AddResource('CALCULATOR',
#0#0#0#20'WST_METADATA_0.2.2.0'#0#0#0#10'calculator'#1#0#0#0#11'ICalculator'#4
+#0#0#0#6'AddInt'#3#0#0#0#1'A'#0#0#0#7'Integer'#0#0#0#0#0#0#0#1#0#0#0#1'B'#0#0
+#0#7'Integer'#0#0#0#0#0#0#0#1#0#0#0#6'result'#0#0#0#17'TBinaryArgsResult'#0#0
+#0#0#0#0#0#3#0#0#0#6'DivInt'#3#0#0#0#1'A'#0#0#0#7'Integer'#0#0#0#0#0#0#0#1#0
+#0#0#1'B'#0#0#0#7'Integer'#0#0#0#0#0#0#0#1#0#0#0#6'result'#0#0#0#7'Integer'#0
+#0#0#0#0#0#0#3#0#0#0#15'DoAllOperations'#3#0#0#0#1'A'#0#0#0#7'Integer'#0#0#0
+#0#0#0#0#1#0#0#0#1'B'#0#0#0#7'Integer'#0#0#0#0#0#0#0#1#0#0#0#6'result'#0#0#0
+#22'TBinaryArgsResultArray'#0#0#0#0#0#0#0#3#0#0#0#11'DoOperation'#4#0#0#0#1'A'
+#0#0#0#7'Integer'#0#0#0#0#0#0#0#1#0#0#0#1'B'#0#0#0#7'Integer'#0#0#0#0#0#0#0#1
+#0#0#0#10'AOperation'#0#0#0#8'TCalc_Op'#0#0#0#0#0#0#0#1#0#0#0#6'result'#0#0#0
+#17'TBinaryArgsResult'#0#0#0#0#0#0#0#3''
);

BIN
wst/tags/0.4/tests/calculator/gui_client/calculator.wst_meta Normal file
View File

Binary file not shown.

164
wst/tags/0.4/tests/calculator/gui_client/calculator_proxy.pas Normal file
View File

@ -0,0 +1,164 @@
{
This unit has been produced by ws_helper.
Input unit name : "calculator".
This unit name : "calculator_proxy".
Date : "12/11/2006 11:22".
}
Unit calculator_proxy;
{$mode objfpc}{$H+}
Interface
Uses SysUtils, Classes, TypInfo, base_service_intf, service_intf, calculator;
Type
TCalculator_Proxy=class(TBaseProxy,ICalculator)
Protected
class function GetServiceType() : PTypeInfo;override;
function AddInt(
Const A : Integer;
Const B : Integer
):TBinaryArgsResult;
function DivInt(
Const A : Integer;
Const B : Integer
):Integer;
function DoAllOperations(
Const A : Integer;
Const B : Integer
):TBinaryArgsResultArray;
function DoOperation(
Const A : Integer;
Const B : Integer;
Const AOperation : TCalc_Op
):TBinaryArgsResult;
End;
Implementation
uses wst_resources_imp, metadata_repository;
{ TCalculator_Proxy implementation }
class function TCalculator_Proxy.GetServiceType() : PTypeInfo;
begin
result := TypeInfo(ICalculator);
end;
function TCalculator_Proxy.AddInt(
Const A : Integer;
Const B : Integer
):TBinaryArgsResult;
Var
locSerializer : IFormatterClient;
strPrmName : string;
Begin
locSerializer := GetSerializer();
Try
locSerializer.BeginCall('AddInt', GetTarget(),(Self as ICallContext));
locSerializer.Put('A', TypeInfo(Integer), A);
locSerializer.Put('B', TypeInfo(Integer), B);
locSerializer.EndCall();
MakeCall();
locSerializer.BeginCallRead((Self as ICallContext));
Pointer(Result) := Nil;
strPrmName := 'return';
locSerializer.Get(TypeInfo(TBinaryArgsResult), strPrmName, result);
Finally
locSerializer.Clear();
End;
End;
function TCalculator_Proxy.DivInt(
Const A : Integer;
Const B : Integer
):Integer;
Var
locSerializer : IFormatterClient;
strPrmName : string;
Begin
locSerializer := GetSerializer();
Try
locSerializer.BeginCall('DivInt', GetTarget(),(Self as ICallContext));
locSerializer.Put('A', TypeInfo(Integer), A);
locSerializer.Put('B', TypeInfo(Integer), B);
locSerializer.EndCall();
MakeCall();
locSerializer.BeginCallRead((Self as ICallContext));
strPrmName := 'return';
locSerializer.Get(TypeInfo(Integer), strPrmName, result);
Finally
locSerializer.Clear();
End;
End;
function TCalculator_Proxy.DoAllOperations(
Const A : Integer;
Const B : Integer
):TBinaryArgsResultArray;
Var
locSerializer : IFormatterClient;
strPrmName : string;
Begin
locSerializer := GetSerializer();
Try
locSerializer.BeginCall('DoAllOperations', GetTarget(),(Self as ICallContext));
locSerializer.Put('A', TypeInfo(Integer), A);
locSerializer.Put('B', TypeInfo(Integer), B);
locSerializer.EndCall();
MakeCall();
locSerializer.BeginCallRead((Self as ICallContext));
Pointer(Result) := Nil;
strPrmName := 'return';
locSerializer.Get(TypeInfo(TBinaryArgsResultArray), strPrmName, result);
Finally
locSerializer.Clear();
End;
End;
function TCalculator_Proxy.DoOperation(
Const A : Integer;
Const B : Integer;
Const AOperation : TCalc_Op
):TBinaryArgsResult;
Var
locSerializer : IFormatterClient;
strPrmName : string;
Begin
locSerializer := GetSerializer();
Try
locSerializer.BeginCall('DoOperation', GetTarget(),(Self as ICallContext));
locSerializer.Put('A', TypeInfo(Integer), A);
locSerializer.Put('B', TypeInfo(Integer), B);
locSerializer.Put('AOperation', TypeInfo(TCalc_Op), AOperation);
locSerializer.EndCall();
MakeCall();
locSerializer.BeginCallRead((Self as ICallContext));
Pointer(Result) := Nil;
strPrmName := 'return';
locSerializer.Get(TypeInfo(TBinaryArgsResult), strPrmName, result);
Finally
locSerializer.Clear();
End;
End;
initialization
{$i calculator.wst}
{$IF DECLARED(Register_calculator_ServiceMetadata)}
Register_calculator_ServiceMetadata();
{$ENDIF}
End.

128
wst/tags/0.4/tests/calculator/gui_client/main_unit.lfm Normal file
View File

@ -0,0 +1,128 @@
object fmain: Tfmain
Left = 269
Height = 300
Top = 234
Width = 528
HorzScrollBar.Page = 527
VertScrollBar.Page = 299
ActiveControl = edtA
Caption = '"calculator" service test'
ClientHeight = 300
ClientWidth = 528
OnCreate = FormCreate
object Label1: TLabel
Left = 16
Height = 18
Top = 48
Width = 64
Caption = 'Param "A"'
Color = clNone
ParentColor = False
end
object Label2: TLabel
Left = 17
Height = 18
Top = 80
Width = 64
Caption = 'Param "B"'
Color = clNone
ParentColor = False
end
object Label3: TLabel
Left = 240
Height = 18
Top = 52
Width = 45
Caption = 'Format'
Color = clNone
ParentColor = False
end
object Label4: TLabel
Left = 16
Height = 18
Top = 8
Width = 49
Caption = 'Address'
Color = clNone
ParentColor = False
end
object edtA: TEdit
Left = 80
Height = 23
Top = 48
Width = 80
TabOrder = 0
Text = '5'
end
object edtB: TEdit
Left = 80
Height = 23
Top = 80
Width = 80
TabOrder = 1
Text = '2'
end
object btnExec: TButton
Left = 384
Height = 25
Top = 8
Width = 128
BorderSpacing.InnerBorder = 4
Caption = 'Execute'
OnClick = btnExecClick
TabOrder = 2
end
object mmoLog: TMemo
Height = 180
Top = 120
Width = 528
Align = alBottom
Anchors = [akTop, akLeft, akRight, akBottom]
Font.CharSet = ANSI_CHARSET
Font.Color = clBlack
Font.Height = -19
Font.Name = 'Courier New'
Font.Pitch = fpFixed
Lines.Strings = (
''
)
ScrollBars = ssBoth
TabOrder = 3
end
object edtFormat: TEdit
Left = 288
Height = 23
Top = 50
Width = 80
TabOrder = 4
Text = 'SOAP'
end
object btnInit: TButton
Left = 384
Height = 25
Top = 48
Width = 75
BorderSpacing.InnerBorder = 4
Caption = 'Init Obj'
OnClick = btnInitClick
TabOrder = 5
end
object btnClearLog: TButton
Left = 384
Height = 25
Top = 80
Width = 75
BorderSpacing.InnerBorder = 4
Caption = 'Clear Log'
OnClick = btnClearLogClick
TabOrder = 6
end
object edtAddress: TEdit
Left = 80
Height = 23
Top = 11
Width = 288
TabOrder = 7
Text = 'http:Address=http://127.0.0.1:8000/services/ICalculator'
end
end

35
wst/tags/0.4/tests/calculator/gui_client/main_unit.lrs Normal file
View File

@ -0,0 +1,35 @@
{ Ceci est un fichier ressource g�n�r� automatiquement par Lazarus }
LazarusResources.Add('Tfmain','FORMDATA',[
'TPF0'#6'Tfmain'#5'fmain'#4'Left'#3#13#1#6'Height'#3','#1#3'Top'#3#234#0#5'Wi'
+'dth'#3#16#2#18'HorzScrollBar.Page'#3#15#2#18'VertScrollBar.Page'#3'+'#1#13
+'ActiveControl'#7#4'edtA'#7'Caption'#6#25'"calculator" service test'#12'Clie'
+'ntHeight'#3','#1#11'ClientWidth'#3#16#2#8'OnCreate'#7#10'FormCreate'#0#6'TL'
+'abel'#6'Label1'#4'Left'#2#16#6'Height'#2#18#3'Top'#2'0'#5'Width'#2'@'#7'Cap'
+'tion'#6#9'Param "A"'#5'Color'#7#6'clNone'#11'ParentColor'#8#0#0#6'TLabel'#6
+'Label2'#4'Left'#2#17#6'Height'#2#18#3'Top'#2'P'#5'Width'#2'@'#7'Caption'#6#9
+'Param "B"'#5'Color'#7#6'clNone'#11'ParentColor'#8#0#0#6'TLabel'#6'Label3'#4
+'Left'#3#240#0#6'Height'#2#18#3'Top'#2'4'#5'Width'#2'-'#7'Caption'#6#6'Forma'
+'t'#5'Color'#7#6'clNone'#11'ParentColor'#8#0#0#6'TLabel'#6'Label4'#4'Left'#2
+#16#6'Height'#2#18#3'Top'#2#8#5'Width'#2'1'#7'Caption'#6#7'Address'#5'Color'
+#7#6'clNone'#11'ParentColor'#8#0#0#5'TEdit'#4'edtA'#4'Left'#2'P'#6'Height'#2
+#23#3'Top'#2'0'#5'Width'#2'P'#8'TabOrder'#2#0#4'Text'#6#1'5'#0#0#5'TEdit'#4
+'edtB'#4'Left'#2'P'#6'Height'#2#23#3'Top'#2'P'#5'Width'#2'P'#8'TabOrder'#2#1
+#4'Text'#6#1'2'#0#0#7'TButton'#7'btnExec'#4'Left'#3#128#1#6'Height'#2#25#3'T'
+'op'#2#8#5'Width'#3#128#0#25'BorderSpacing.InnerBorder'#2#4#7'Caption'#6#7'E'
+'xecute'#7'OnClick'#7#12'btnExecClick'#8'TabOrder'#2#2#0#0#5'TMemo'#6'mmoLog'
+#6'Height'#3#180#0#3'Top'#2'x'#5'Width'#3#16#2#5'Align'#7#8'alBottom'#7'Anch'
+'ors'#11#5'akTop'#6'akLeft'#7'akRight'#8'akBottom'#0#12'Font.CharSet'#7#12'A'
+'NSI_CHARSET'#10'Font.Color'#7#7'clBlack'#11'Font.Height'#2#237#9'Font.Name'
+#6#11'Courier New'#10'Font.Pitch'#7#7'fpFixed'#13'Lines.Strings'#1#6#0#0#10
+'ScrollBars'#7#6'ssBoth'#8'TabOrder'#2#3#0#0#5'TEdit'#9'edtFormat'#4'Left'#3
+' '#1#6'Height'#2#23#3'Top'#2'2'#5'Width'#2'P'#8'TabOrder'#2#4#4'Text'#6#4'S'
+'OAP'#0#0#7'TButton'#7'btnInit'#4'Left'#3#128#1#6'Height'#2#25#3'Top'#2'0'#5
+'Width'#2'K'#25'BorderSpacing.InnerBorder'#2#4#7'Caption'#6#8'Init Obj'#7'On'
+'Click'#7#12'btnInitClick'#8'TabOrder'#2#5#0#0#7'TButton'#11'btnClearLog'#4
+'Left'#3#128#1#6'Height'#2#25#3'Top'#2'P'#5'Width'#2'K'#25'BorderSpacing.Inn'
+'erBorder'#2#4#7'Caption'#6#9'Clear Log'#7'OnClick'#7#16'btnClearLogClick'#8
+'TabOrder'#2#6#0#0#5'TEdit'#10'edtAddress'#4'Left'#2'P'#6'Height'#2#23#3'Top'
+#2#11#5'Width'#3' '#1#8'TabOrder'#2#7#4'Text'#6'7http:Address=http://127.0.0'
+'.1:8000/services/ICalculator'#0#0#0
]);

146
wst/tags/0.4/tests/calculator/gui_client/main_unit.pas Normal file
View File

@ -0,0 +1,146 @@
unit main_unit;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, StdCtrls,
Buttons, calculator, calculator_proxy;
type
{ Tfmain }
Tfmain = class(TForm)
btnExec: TButton;
btnInit: TButton;
btnClearLog: TButton;
edtAddress: TEdit;
edtFormat: TEdit;
edtA: TEdit;
edtB: TEdit;
Label1: TLabel;
Label2: TLabel;
Label3: TLabel;
Label4: TLabel;
mmoLog: TMemo;
procedure btnClearLogClick(Sender: TObject);
procedure btnExecClick(Sender: TObject);
procedure btnInitClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
FObj : ICalculator;
procedure LogMsg(const AMsg : string);
public
end;
var
fmain: Tfmain;
implementation
uses TypInfo, base_service_intf, soap_formatter, binary_formatter,
ics_tcp_protocol, ics_http_protocol,
//synapse_http_protocol,
library_protocol,
service_intf;
{ Tfmain }
procedure Tfmain.btnExecClick(Sender: TObject);
Var
a, b, k : Integer;
rk : TBinaryArgsResult;
vA : TBinaryArgsResultArray;
ch : TCalcHeader;
rch : TCalcResultHeader;
hdrs : ICallContext;
begin
try
if not Assigned(FObj) then
FObj := TCalculator_Proxy.Create(
'ICalculator', // Target
edtFormat.Text,//'SOAP',//'binary', // Protocol Data
edtAddress.Text
//'http:Address=http://127.0.0.1:8000/services/ICalculator'
//'TCP:Address=127.0.0.1;Port=1234;target=ICalculator'
);//'TCP:Address=127.0.0.1;Port=1234;target=ICalculator'
ch := TCalcHeader.Create();
ch.mustUnderstand := 0;
ch.Login := 'azerty';
ch.Password := 'qwerty';
ch.WantedPrecision := 121076;
hdrs := FObj as ICallContext;
hdrs.AddHeader(ch,true);
ch := TCalcHeader.Create();
ch.Login := 'azerty';
ch.Password := '';
ch.WantedPrecision := 321654;
hdrs.AddHeader(ch,true);
ch := nil;
rk := Nil;
vA := Nil;
a := StrToInt(edtA.Text);
b := StrToInt(edtB.Text);
Try
rk := FObj.AddInt(a,b);
hdrs.ClearHeaders(hdOut);
LogMsg(Format('Header Count = %d',[hdrs.GetHeaderCount(AllHeaderDirection)]));
if ( hdrs.GetHeaderCount(AllHeaderDirection) > 0 ) then begin
LogMsg(Format('Header(0) Class = %s',[hdrs.GetHeader(0).ClassName]));
if hdrs.GetHeader(0).InheritsFrom(TCalcResultHeader) then begin
rch := hdrs.GetHeader(0) as TCalcResultHeader;
LogMsg(Format('Header(0) Dir = %d; TimeStamp = %s; SessionID = %s; Login =%s; Password = %s',[Ord(rch.Direction),rch.TimeStamp,rch.SessionID,rch.Login,rch.Password]));
end;
end;
LogMsg(Format(' ( %d %s %d ) = %d; Comment = %s',[rk.Arg_A, rk.Arg_OP, rk.Arg_B, rk.Arg_R,rk.Comment]));
rk := FObj.DoOperation(a,b,coSub);
LogMsg(Format(' ( %d %s %d ) = %d; Comment = %s',[rk.Arg_A, rk.Arg_OP, rk.Arg_B, rk.Arg_R,rk.Comment]));
vA := FObj.DoAllOperations(a,b);
For k := 0 To Pred(vA.Length) Do
LogMsg(Format(' ( %d %s %d ) = %d; OP=%s; Comment = %s',[vA[k].Arg_A, vA[k].Arg_OP, vA[k].Arg_B, vA[k].Arg_R,GetEnumName(TypeInfo(TCalc_Op),Ord(vA[k].Arg_OpEnum)),vA[k].Comment]));
Finally
FreeAndNil(rk);
FreeAndNil(vA);
End;
except
on e : Exception do
ShowMessage(e.Message);
end;
end;
procedure Tfmain.btnClearLogClick(Sender: TObject);
begin
mmoLog.Clear();
end;
procedure Tfmain.btnInitClick(Sender: TObject);
begin
FObj := Nil;
end;
procedure Tfmain.FormCreate(Sender: TObject);
begin
FObj := Nil;
ICS_RegisterTCP_Transport();
ICS_RegisterHTTP_Transport();
LIB_Register_Transport();
//SYNAPSE_RegisterHTTP_Transport();
end;
procedure Tfmain.LogMsg(const AMsg: string);
begin
mmoLog.Lines.Add(AMsg);
end;
initialization
{$I main_unit.lrs}
RegisterStdTypes();
end.

391
wst/tags/0.4/tests/calculator/gui_client/test_calc.lpi Normal file
View File

@ -0,0 +1,391 @@
<?xml version="1.0"?>
<CONFIG>
<ProjectOptions>
<PathDelim Value="\"/>
<Version Value="5"/>
<General>
<MainUnit Value="0"/>
<IconPath Value="./"/>
<TargetFileExt Value=".exe"/>
<ActiveEditorIndexAtStart Value="0"/>
</General>
<PublishOptions>
<Version Value="2"/>
<IgnoreBinaries Value="False"/>
<IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/>
<ExcludeFileFilter Value="*.(bak|ppu|ppw|o|so);*~;backup"/>
</PublishOptions>
<RunParams>
<local>
<FormatVersion Value="1"/>
<LaunchingApplication PathPlusParams="/usr/X11R6/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/>
</local>
</RunParams>
<RequiredPackages Count="1">
<Item1>
<PackageName Value="LCL"/>
</Item1>
</RequiredPackages>
<Units Count="41">
<Unit0>
<Filename Value="test_calc.lpr"/>
<IsPartOfProject Value="True"/>
<UnitName Value="test_calc"/>
<CursorPos X="66" Y="10"/>
<TopLine Value="1"/>
<UsageCount Value="82"/>
</Unit0>
<Unit1>
<Filename Value="main_unit.pas"/>
<ComponentName Value="fmain"/>
<IsPartOfProject Value="True"/>
<ResourceFilename Value="main_unit.lrs"/>
<UnitName Value="main_unit"/>
<CursorPos X="3" Y="129"/>
<TopLine Value="109"/>
<EditorIndex Value="0"/>
<UsageCount Value="82"/>
<Loaded Value="True"/>
</Unit1>
<Unit2>
<Filename Value="..\calculator.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="calculator"/>
<CursorPos X="30" Y="16"/>
<TopLine Value="8"/>
<UsageCount Value="82"/>
</Unit2>
<Unit3>
<Filename Value="calculator_proxy.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="calculator_proxy"/>
<CursorPos X="20" Y="39"/>
<TopLine Value="1"/>
<EditorIndex Value="3"/>
<UsageCount Value="82"/>
<Loaded Value="True"/>
</Unit3>
<Unit4>
<Filename Value="..\..\..\..\service_intf.pas"/>
<UnitName Value="service_intf"/>
<CursorPos X="1" Y="147"/>
<TopLine Value="136"/>
<UsageCount Value="12"/>
</Unit4>
<Unit5>
<Filename Value="..\..\..\..\ics_tcp_protocol.pas"/>
<UnitName Value="ics_tcp_protocol"/>
<CursorPos X="1" Y="181"/>
<TopLine Value="167"/>
<UsageCount Value="7"/>
</Unit5>
<Unit6>
<Filename Value="..\..\..\..\base_service_intf.pas"/>
<UnitName Value="base_service_intf"/>
<CursorPos X="12" Y="356"/>
<TopLine Value="345"/>
<UsageCount Value="12"/>
</Unit6>
<Unit7>
<Filename Value="D:\Lazarus\others_package\ics\latest_distr\Delphi\Vc32\WSocket.pas"/>
<UnitName Value="WSocket"/>
<CursorPos X="26" Y="1729"/>
<TopLine Value="1728"/>
<UsageCount Value="9"/>
</Unit7>
<Unit8>
<Filename Value="..\..\..\..\soap_formatter.pas"/>
<UnitName Value="soap_formatter"/>
<CursorPos X="1" Y="76"/>
<TopLine Value="65"/>
<UsageCount Value="13"/>
</Unit8>
<Unit9>
<Filename Value="..\..\..\..\base_soap_formatter.pas"/>
<UnitName Value="base_soap_formatter"/>
<CursorPos X="1" Y="908"/>
<TopLine Value="894"/>
<UsageCount Value="13"/>
</Unit9>
<Unit10>
<Filename Value="..\..\..\..\imp_utils.pas"/>
<UnitName Value="imp_utils"/>
<CursorPos X="1" Y="55"/>
<TopLine Value="41"/>
<UsageCount Value="10"/>
</Unit10>
<Unit11>
<Filename Value="..\..\..\..\binary_streamer.pas"/>
<UnitName Value="binary_streamer"/>
<CursorPos X="32" Y="393"/>
<TopLine Value="386"/>
<UsageCount Value="10"/>
</Unit11>
<Unit12>
<Filename Value="D:\lazarusClean\lcl\include\control.inc"/>
<CursorPos X="1" Y="2261"/>
<TopLine Value="2249"/>
<UsageCount Value="7"/>
</Unit12>
<Unit13>
<Filename Value="..\..\..\..\ics_http_protocol.pas"/>
<UnitName Value="ics_http_protocol"/>
<CursorPos X="65" Y="118"/>
<TopLine Value="109"/>
<UsageCount Value="10"/>
</Unit13>
<Unit14>
<Filename Value="D:\Lazarus\others_package\ics\latest_distr\Delphi\Vc32\HttpProt.pas"/>
<UnitName Value="HttpProt"/>
<CursorPos X="5" Y="840"/>
<TopLine Value="828"/>
<UsageCount Value="9"/>
</Unit14>
<Unit15>
<Filename Value="..\..\..\..\base_binary_formatter.pas"/>
<UnitName Value="base_binary_formatter"/>
<CursorPos X="27" Y="360"/>
<TopLine Value="351"/>
<UsageCount Value="10"/>
</Unit15>
<Unit16>
<Filename Value="..\..\..\base_binary_formatter.pas"/>
<UnitName Value="base_binary_formatter"/>
<CursorPos X="18" Y="151"/>
<TopLine Value="135"/>
<UsageCount Value="32"/>
</Unit16>
<Unit17>
<Filename Value="..\..\..\soap_formatter.pas"/>
<UnitName Value="soap_formatter"/>
<CursorPos X="24" Y="125"/>
<TopLine Value="172"/>
<EditorIndex Value="1"/>
<UsageCount Value="33"/>
<Loaded Value="True"/>
</Unit17>
<Unit18>
<Filename Value="..\..\..\service_intf.pas"/>
<UnitName Value="service_intf"/>
<CursorPos X="58" Y="47"/>
<TopLine Value="31"/>
<UsageCount Value="32"/>
</Unit18>
<Unit19>
<Filename Value="..\..\..\ics_http_protocol.pas"/>
<UnitName Value="ics_http_protocol"/>
<CursorPos X="35" Y="19"/>
<TopLine Value="1"/>
<UsageCount Value="13"/>
</Unit19>
<Unit20>
<Filename Value="..\..\..\base_soap_formatter.pas"/>
<UnitName Value="base_soap_formatter"/>
<CursorPos X="3" Y="466"/>
<TopLine Value="458"/>
<EditorIndex Value="2"/>
<UsageCount Value="32"/>
<Loaded Value="True"/>
</Unit20>
<Unit21>
<Filename Value="..\..\..\base_service_intf.pas"/>
<UnitName Value="base_service_intf"/>
<CursorPos X="3" Y="235"/>
<TopLine Value="229"/>
<UsageCount Value="31"/>
</Unit21>
<Unit22>
<Filename Value="D:\lazarusClean\fpcsrc\fcl\xml\dom.pp"/>
<UnitName Value="DOM"/>
<CursorPos X="3" Y="1394"/>
<TopLine Value="1389"/>
<UsageCount Value="10"/>
</Unit22>
<Unit23>
<Filename Value="D:\lazarusClean\fpcsrc\rtl\objpas\classes\classesh.inc"/>
<CursorPos X="32" Y="604"/>
<TopLine Value="593"/>
<UsageCount Value="11"/>
</Unit23>
<Unit24>
<Filename Value="D:\lazarusClean\fpcsrc\rtl\objpas\classes\stringl.inc"/>
<CursorPos X="44" Y="472"/>
<TopLine Value="82"/>
<UsageCount Value="11"/>
</Unit24>
<Unit25>
<Filename Value="..\..\..\imp_utils.pas"/>
<UnitName Value="imp_utils"/>
<CursorPos X="36" Y="104"/>
<TopLine Value="88"/>
<UsageCount Value="15"/>
</Unit25>
<Unit26>
<Filename Value="D:\lazarusClean\fpcsrc\rtl\win32\classes.pp"/>
<UnitName Value="Classes"/>
<CursorPos X="6" Y="28"/>
<TopLine Value="16"/>
<UsageCount Value="10"/>
</Unit26>
<Unit27>
<Filename Value="D:\lazarusClean\fpcsrc\rtl\objpas\rtlconsts.pp"/>
<UnitName Value="RtlConsts"/>
<CursorPos X="10" Y="1"/>
<TopLine Value="1"/>
<UsageCount Value="10"/>
</Unit27>
<Unit28>
<Filename Value="D:\lazarusClean\fpcsrc\rtl\objpas\rtlconst.inc"/>
<CursorPos X="1" Y="1"/>
<TopLine Value="55"/>
<UsageCount Value="10"/>
</Unit28>
<Unit29>
<Filename Value="D:\lazarusClean\fpcsrc\rtl\win32\sysutils.pp"/>
<UnitName Value="sysutils"/>
<CursorPos X="9" Y="56"/>
<TopLine Value="49"/>
<UsageCount Value="10"/>
</Unit29>
<Unit30>
<Filename Value="D:\lazarusClean\fpcsrc\rtl\objpas\sysconst.pp"/>
<UnitName Value="sysconst"/>
<CursorPos X="1" Y="1"/>
<TopLine Value="1"/>
<UsageCount Value="10"/>
</Unit30>
<Unit31>
<Filename Value="D:\lazarusClean\fpcsrc\rtl\objpas\types.pp"/>
<UnitName Value="types"/>
<CursorPos X="1" Y="1"/>
<TopLine Value="1"/>
<UsageCount Value="10"/>
</Unit31>
<Unit32>
<Filename Value="..\..\..\synapse_http_protocol.pas"/>
<UnitName Value="synapse_http_protocol"/>
<CursorPos X="34" Y="148"/>
<TopLine Value="131"/>
<UsageCount Value="10"/>
</Unit32>
<Unit33>
<Filename Value="D:\lazarusClean\fpcsrc\rtl\objpas\classes\streams.inc"/>
<CursorPos X="7" Y="159"/>
<TopLine Value="158"/>
<UsageCount Value="10"/>
</Unit33>
<Unit34>
<Filename Value="..\..\..\binary_formatter.pas"/>
<UnitName Value="binary_formatter"/>
<CursorPos X="44" Y="132"/>
<TopLine Value="120"/>
<UsageCount Value="10"/>
</Unit34>
<Unit35>
<Filename Value="..\..\..\ics_tcp_protocol.pas"/>
<UnitName Value="ics_tcp_protocol"/>
<CursorPos X="3" Y="22"/>
<TopLine Value="8"/>
<UsageCount Value="10"/>
</Unit35>
<Unit36>
<Filename Value="..\srv\calculator.lrs"/>
<CursorPos X="1" Y="1"/>
<TopLine Value="1"/>
<UsageCount Value="10"/>
</Unit36>
<Unit37>
<Filename Value="..\..\..\library_protocol.pas"/>
<UnitName Value="library_protocol"/>
<CursorPos X="39" Y="213"/>
<TopLine Value="199"/>
<UsageCount Value="10"/>
</Unit37>
<Unit38>
<Filename Value="..\..\metadata_browser\library_protocol.pas"/>
<UnitName Value="library_protocol"/>
<CursorPos X="18" Y="24"/>
<TopLine Value="10"/>
<UsageCount Value="10"/>
</Unit38>
<Unit39>
<Filename Value="..\..\..\wst_resources_imp.pas"/>
<UnitName Value="wst_resources_imp"/>
<CursorPos X="5" Y="132"/>
<TopLine Value="115"/>
<UsageCount Value="10"/>
</Unit39>
<Unit40>
<Filename Value="..\..\..\..\..\..\lazarusClean\fpc\2.0.4\source\fcl\xml\dom.pp"/>
<UnitName Value="DOM"/>
<CursorPos X="40" Y="373"/>
<TopLine Value="356"/>
<UsageCount Value="11"/>
</Unit40>
</Units>
<JumpHistory Count="1" HistoryIndex="0">
<Position1>
<Filename Value="main_unit.pas"/>
<Caret Line="42" Column="40" TopLine="25"/>
</Position1>
</JumpHistory>
</ProjectOptions>
<CompilerOptions>
<Version Value="5"/>
<PathDelim Value="\"/>
<SearchPaths>
<OtherUnitFiles Value="C:\lazarusClean\others_package\ics\latest_distr\Delphi\Vc32\;..\;..\..\..\;C:\lazarusClean\others_package\synapse\"/>
<UnitOutputDirectory Value="obj"/>
<SrcPath Value="$(LazarusDir)\lcl\;$(LazarusDir)\lcl\interfaces\$(LCLWidgetType)\"/>
</SearchPaths>
<Parsing>
<SyntaxOptions>
<IncludeAssertionCode Value="True"/>
</SyntaxOptions>
</Parsing>
<CodeGeneration>
<Generate Value="Faster"/>
</CodeGeneration>
<Linking>
<Options>
<Win32>
<GraphicApplication Value="True"/>
</Win32>
</Options>
</Linking>
<Other>
<CustomOptions Value="-Xi
"/>
<CompilerPath Value="$(CompPath)"/>
</Other>
</CompilerOptions>
<Debugging>
<BreakPoints Count="5">
<Item1>
<Source Value="..\..\..\..\home\inoussa\Projets\Laz\tests\soap\test_soap.pas"/>
<Line Value="15"/>
</Item1>
<Item2>
<Source Value="..\..\..\..\home\inoussa\Projets\Laz\tests\soap\test_soap.pas"/>
<Line Value="16"/>
</Item2>
<Item3>
<Source Value="..\..\..\..\home\inoussa\Projets\Laz\tests\soap\test_soap.pas"/>
<Line Value="18"/>
</Item3>
<Item4>
<Source Value="..\..\..\..\home\inoussa\Projets\Laz\tests\soap\googleintfimpunit.pas"/>
<Line Value="63"/>
</Item4>
<Item5>
<Source Value="..\..\..\..\basic_binder.pas"/>
<Line Value="62"/>
</Item5>
</BreakPoints>
<Watches Count="1">
<Item1>
<Expression Value="ASource.Memory^"/>
</Item1>
</Watches>
</Debugging>
</CONFIG>

18
wst/tags/0.4/tests/calculator/gui_client/test_calc.lpr Normal file
View File

@ -0,0 +1,18 @@
program test_calc;
{$mode objfpc}{$H+}
uses
{$IFDEF UNIX}{$IFDEF UseCThreads}
cthreads,
{$ENDIF}{$ENDIF}
Interfaces, // this includes the LCL widgetset
Forms
{ add your units here }, main_unit, calculator, calculator_proxy;
begin
Application.Initialize;
Application.CreateForm(Tfmain, fmain);
Application.Run;
end.

13
wst/tags/0.4/tests/calculator/srv/calculator.wst Normal file
View File

@ -0,0 +1,13 @@
GetWSTResourceManager().AddResource('CALCULATOR',
#0#0#0#20'WST_METADATA_0.2.2.0'#0#0#0#10'calculator'#1#0#0#0#11'ICalculator'#4
+#0#0#0#6'AddInt'#3#0#0#0#1'A'#0#0#0#7'Integer'#0#0#0#0#0#0#0#1#0#0#0#1'B'#0#0
+#0#7'Integer'#0#0#0#0#0#0#0#1#0#0#0#6'result'#0#0#0#17'TBinaryArgsResult'#0#0
+#0#0#0#0#0#3#0#0#0#6'DivInt'#3#0#0#0#1'A'#0#0#0#7'Integer'#0#0#0#0#0#0#0#1#0
+#0#0#1'B'#0#0#0#7'Integer'#0#0#0#0#0#0#0#1#0#0#0#6'result'#0#0#0#7'Integer'#0
+#0#0#0#0#0#0#3#0#0#0#15'DoAllOperations'#3#0#0#0#1'A'#0#0#0#7'Integer'#0#0#0
+#0#0#0#0#1#0#0#0#1'B'#0#0#0#7'Integer'#0#0#0#0#0#0#0#1#0#0#0#6'result'#0#0#0
+#22'TBinaryArgsResultArray'#0#0#0#0#0#0#0#3#0#0#0#11'DoOperation'#4#0#0#0#1'A'
+#0#0#0#7'Integer'#0#0#0#0#0#0#0#1#0#0#0#1'B'#0#0#0#7'Integer'#0#0#0#0#0#0#0#1
+#0#0#0#10'AOperation'#0#0#0#8'TCalc_Op'#0#0#0#0#0#0#0#1#0#0#0#6'result'#0#0#0
+#17'TBinaryArgsResult'#0#0#0#0#0#0#0#3''
);

207
wst/tags/0.4/tests/calculator/srv/calculator_binder.pas Normal file
View File

@ -0,0 +1,207 @@
{
This unit has been produced by ws_helper.
Input unit name : "calculator".
This unit name : "calculator_binder".
Date : "12/11/2006 11:22".
}
unit calculator_binder;
{$mode objfpc}{$H+}
interface
uses SysUtils, Classes, base_service_intf, server_service_intf, calculator;
type
TCalculator_ServiceBinder=class(TBaseServiceBinder)
Protected
procedure AddIntHandler(AFormatter:IFormatterResponse);
procedure DivIntHandler(AFormatter:IFormatterResponse);
procedure DoAllOperationsHandler(AFormatter:IFormatterResponse);
procedure DoOperationHandler(AFormatter:IFormatterResponse);
Public
constructor Create();
End;
TCalculator_ServiceBinderFactory = class(TInterfacedObject,IItemFactory)
protected
function CreateInstance():IInterface;
End;
procedure Server_service_RegisterCalculatorService();
Implementation
uses TypInfo, wst_resources_imp,metadata_repository;
{ TCalculator_ServiceBinder implementation }
procedure TCalculator_ServiceBinder.AddIntHandler(AFormatter:IFormatterResponse);
Var
cllCntrl : ICallControl;
tmpObj : ICalculator;
callCtx : ICallContext;
strPrmName : string;
procName,trgName : string;
A : Integer;
B : Integer;
returnVal : TBinaryArgsResult;
Begin
callCtx := GetCallContext();
Pointer(returnVal) := Nil;
strPrmName := 'A'; AFormatter.Get(TypeInfo(Integer),strPrmName,A);
strPrmName := 'B'; AFormatter.Get(TypeInfo(Integer),strPrmName,B);
tmpObj := Self.GetFactory().CreateInstance() as ICalculator;
if Supports(tmpObj,ICallControl,cllCntrl) then
cllCntrl.SetCallContext(GetCallContext());
returnVal := tmpObj.AddInt(A,B);
If Assigned(Pointer(returnVal)) Then
callCtx.AddObjectToFree(TObject(returnVal));
procName := AFormatter.GetCallProcedureName();
trgName := AFormatter.GetCallTarget();
AFormatter.Clear();
AFormatter.BeginCallResponse(procName,trgName);
AFormatter.Put('return',TypeInfo(TBinaryArgsResult),returnVal);
AFormatter.EndCallResponse();
callCtx := Nil;
End;
procedure TCalculator_ServiceBinder.DivIntHandler(AFormatter:IFormatterResponse);
Var
cllCntrl : ICallControl;
tmpObj : ICalculator;
callCtx : ICallContext;
strPrmName : string;
procName,trgName : string;
A : Integer;
B : Integer;
returnVal : Integer;
Begin
callCtx := GetCallContext();
strPrmName := 'A'; AFormatter.Get(TypeInfo(Integer),strPrmName,A);
strPrmName := 'B'; AFormatter.Get(TypeInfo(Integer),strPrmName,B);
tmpObj := Self.GetFactory().CreateInstance() as ICalculator;
if Supports(tmpObj,ICallControl,cllCntrl) then
cllCntrl.SetCallContext(GetCallContext());
returnVal := tmpObj.DivInt(A,B);
procName := AFormatter.GetCallProcedureName();
trgName := AFormatter.GetCallTarget();
AFormatter.Clear();
AFormatter.BeginCallResponse(procName,trgName);
AFormatter.Put('return',TypeInfo(Integer),returnVal);
AFormatter.EndCallResponse();
callCtx := Nil;
End;
procedure TCalculator_ServiceBinder.DoAllOperationsHandler(AFormatter:IFormatterResponse);
Var
cllCntrl : ICallControl;
tmpObj : ICalculator;
callCtx : ICallContext;
strPrmName : string;
procName,trgName : string;
A : Integer;
B : Integer;
returnVal : TBinaryArgsResultArray;
Begin
callCtx := GetCallContext();
Pointer(returnVal) := Nil;
strPrmName := 'A'; AFormatter.Get(TypeInfo(Integer),strPrmName,A);
strPrmName := 'B'; AFormatter.Get(TypeInfo(Integer),strPrmName,B);
tmpObj := Self.GetFactory().CreateInstance() as ICalculator;
if Supports(tmpObj,ICallControl,cllCntrl) then
cllCntrl.SetCallContext(GetCallContext());
returnVal := tmpObj.DoAllOperations(A,B);
If Assigned(Pointer(returnVal)) Then
callCtx.AddObjectToFree(TObject(returnVal));
procName := AFormatter.GetCallProcedureName();
trgName := AFormatter.GetCallTarget();
AFormatter.Clear();
AFormatter.BeginCallResponse(procName,trgName);
AFormatter.Put('return',TypeInfo(TBinaryArgsResultArray),returnVal);
AFormatter.EndCallResponse();
callCtx := Nil;
End;
procedure TCalculator_ServiceBinder.DoOperationHandler(AFormatter:IFormatterResponse);
Var
cllCntrl : ICallControl;
tmpObj : ICalculator;
callCtx : ICallContext;
strPrmName : string;
procName,trgName : string;
A : Integer;
B : Integer;
AOperation : TCalc_Op;
returnVal : TBinaryArgsResult;
Begin
callCtx := GetCallContext();
Pointer(returnVal) := Nil;
strPrmName := 'A'; AFormatter.Get(TypeInfo(Integer),strPrmName,A);
strPrmName := 'B'; AFormatter.Get(TypeInfo(Integer),strPrmName,B);
strPrmName := 'AOperation'; AFormatter.Get(TypeInfo(TCalc_Op),strPrmName,AOperation);
tmpObj := Self.GetFactory().CreateInstance() as ICalculator;
if Supports(tmpObj,ICallControl,cllCntrl) then
cllCntrl.SetCallContext(GetCallContext());
returnVal := tmpObj.DoOperation(A,B,AOperation);
If Assigned(Pointer(returnVal)) Then
callCtx.AddObjectToFree(TObject(returnVal));
procName := AFormatter.GetCallProcedureName();
trgName := AFormatter.GetCallTarget();
AFormatter.Clear();
AFormatter.BeginCallResponse(procName,trgName);
AFormatter.Put('return',TypeInfo(TBinaryArgsResult),returnVal);
AFormatter.EndCallResponse();
callCtx := Nil;
End;
constructor TCalculator_ServiceBinder.Create();
Begin
Inherited Create(GetServiceImplementationRegistry().FindFactory('ICalculator'));
RegisterVerbHandler('AddInt',@AddIntHandler);
RegisterVerbHandler('DivInt',@DivIntHandler);
RegisterVerbHandler('DoAllOperations',@DoAllOperationsHandler);
RegisterVerbHandler('DoOperation',@DoOperationHandler);
End;
{ TCalculator_ServiceBinderFactory }
function TCalculator_ServiceBinderFactory.CreateInstance():IInterface;
Begin
Result := TCalculator_ServiceBinder.Create() as IInterface;
End;
procedure Server_service_RegisterCalculatorService();
Begin
GetServerServiceRegistry().Register('ICalculator',TCalculator_ServiceBinderFactory.Create() as IItemFactory);
End;
initialization
{$IF DECLARED(Register_calculator_NameSpace)}
Register_calculator_NameSpace();
{$ENDIF}
{$i calculator.wst}
End.

Some files were not shown because too many files have changed in this diff Show More