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

3.1 tag creation

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@5 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
inoussa
2006-08-26 02:24:19 +00:00
parent 4381e28da6
commit eb00bf60c9
104 changed files with 27836 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

481
wst/tags/3.1/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/3.1/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

1273
wst/tags/3.1/base_binary_formatter.pas Normal file
View File

File diff suppressed because it is too large Load Diff

2858
wst/tags/3.1/base_service_intf.pas Normal file
View File

File diff suppressed because it is too large Load Diff

1280
wst/tags/3.1/base_soap_formatter.pas Normal file
View File

File diff suppressed because it is too large Load Diff

204
wst/tags/3.1/binary_formatter.pas Normal file
View File

@ -0,0 +1,204 @@
{
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;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, TypInfo,
base_service_intf, service_intf, imp_utils,
base_binary_formatter;
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';
BeginScopeRead(s,nil);
s := StackTop().GetByIndex(0)^.Name;
If AnsiSameText(s,'Fault') Then Begin
BeginScopeRead(s,nil,stObject);
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;
BeginScopeRead(FCallTarget,nil);
FCallProcedureName := StackTop().GetByIndex(0)^.Name;
BeginScopeRead(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.

436
wst/tags/3.1/binary_streamer.pas Normal file
View File

@ -0,0 +1,436 @@
{
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;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils;
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;inline;
function Reverse_32(AValue:DWord):DWord;inline;
function Reverse_64(AValue:QWord):QWord;inline;
function Reverse_Single(AValue:Single):Single;inline;
function Reverse_Double(AValue:Double):Double;inline;
function Reverse_Extended(AValue:Extended):Extended;inline;
function Reverse_Currency(AValue:Currency):Currency;inline;
implementation
{$IFDEF ENDIAN_BIG}
procedure ReverseBytes(var AData; const ALength : Integer);inline;
begin
end;
{$ELSE} // assume ENDIAN_LITTLE
procedure ReverseBytes(var AData; const ALength : Integer);
Var
i,j : PtrInt;
c : Byte;
pDt : ^Byte;
begin
pDt := @AData;
j := ALength div 2;
For i := 0 To Pred(j) Do Begin
c := pDt[i];
pDt[i] := pDt[(ALength - 1 ) - i];
pDt[(ALength - 1 ) - i] := c;
End;
end;
{$ENDIF}
function Reverse_16(AValue:Word):Word;inline;
begin
Result := AValue;
ReverseBytes(Result,2)
end;
function Reverse_32(AValue:DWord):DWord;inline;
begin
Result := AValue;
ReverseBytes(Result,4)
end;
function Reverse_64(AValue:QWord):QWord;inline;
begin
Result := AValue;
ReverseBytes(Result,8)
end;
function Reverse_Single(AValue:Single):Single;inline;
begin
Result := AValue;
ReverseBytes(Result,4)
end;
function Reverse_Double(AValue:Double):Double;inline;
begin
Result := AValue;
ReverseBytes(Result,8)
end;
function Reverse_Extended(AValue:Extended):Extended;inline;
begin
Result := AValue;
ReverseBytes(Result,10);
end;
function Reverse_Currency(AValue:Currency):Currency;inline;
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;
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;
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;
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;
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/3.1/doc/WebServiceToolKit.odt Normal file
View File

Binary file not shown.

1170
wst/tags/3.1/doc/WebServiceToolKit.rtf Normal file
View File

File diff suppressed because it is too large Load Diff

198
wst/tags/3.1/ics_http_protocol.pas Normal file
View File

@ -0,0 +1,198 @@
{
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,
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);
WriteLn(s);
ARequest.Position := i;
{$ENDIF WST_DBG}
FConnection.SendStream := ARequest;
FConnection.RcvdStream := AResponse;
FConnection.Post();
{$IFDEF WST_DBG}
i := AResponse.Position;
SetLength(s,AResponse.Size);
AResponse.Read(s[1],AResponse.Size);TMemoryStream(AResponse).SaveToFile('E:\Inoussa\Sources\lazarus\wst\v0.3\tests\apache_module\log.log');
WriteLn(s);
{$ENDIF WST_DBG}
end;
procedure ICS_RegisterHTTP_Transport();
begin
GetTransportRegistry().Register(sTRANSPORT_NAME,TSimpleItemFactory.Create(THTTPTransport) as IItemFactory);
end;
end.

222
wst/tags/3.1/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;
{$mode objfpc}{$H+}
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 := @DataAvailable;
FConnection.OnBgException := @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.

187
wst/tags/3.1/imp_utils.pas Normal file
View File

@ -0,0 +1,187 @@
{
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;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, TypInfo,
base_service_intf;
Type
EPropertyManagerException = class(EServiceException)
End;
{ TPublishedPropertyManager }
TPublishedPropertyManager = class(TInterfacedObject,IPropertyManager)
Private
FParent : TObject;
procedure Error(Const AMsg:string);
procedure Error(Const AMsg:string; Const AArgs : array of const);
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;
implementation
function IsStrEmpty(Const AStr:String):Boolean;
begin
Result := ( Length(Trim(AStr)) = 0 );
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
tkSString,tkLString,tkAString,tkWString:
SetStrProp(FParent,pinf,AValue);
tkEnumeration :
SetEnumProp(FParent,pinf,AValue);
tkInteger,tkInt64,tkQWord:
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
tkSString,tkLString,tkAString,tkWString:
Result := GetStrProp(FParent,pinf);
tkEnumeration :
Result := GetEnumProp(FParent,pinf);
tkInteger,tkInt64,tkQWord:
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
[ tkSString,tkLString,tkAString,tkWString,
tkEnumeration,
tkInteger,tkInt64,tkQWord
]
)
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/3.1/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.

700
wst/tags/3.1/metadata_repository.pas Normal file
View File

@ -0,0 +1,700 @@
{
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;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils;
const
sWST_SIGNATURE = 'WST_METADATA_0.2.2.0';
sWST_META = 'wst_meta';
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;
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 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);
implementation
uses LResources, binary_streamer;
procedure ClearProperties(var AProps : PPropertyData);
var
c : Integer;
q, p : PPropertyData;
begin
if not Assigned(AProps) then
Exit;
c := SizeOf(PPropertyData^);
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(PPropertyData^);
q0 := GetMem(c);
q := q0;
p := AProps;
while Assigned(p) do begin
q^.Next := 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 := GetMem(SizeOf(PPropertyData^));
FillChar(AProps^,SizeOf(PPropertyData^),#0);
AProps^.Next := nil;
Result := AProps;
end else begin
Result := Find(AProps,APropName);
if not Assigned(Result) then begin
AProps^.Next := GetMem(SizeOf(PPropertyData^));
FillChar(AProps^.Next^,SizeOf(PPropertyData^),#0);
Result := AProps^.Next;
Result^.Next := nil;
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(POperationParam^) );
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]));
end;
Freemem(AService^.Operations, k * SizeOf(PServiceOperation^) );
AService^.Operations := nil;
end;
if AFreeService then
Freemem(AService,SizeOf(PService^));
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);
end;
Freemem(ARepository^.Services, c * SizeOf(PService^) );
end;
Freemem(ARepository,SizeOf(PServiceRepository^));
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 := GetMem( cc * SizeOf(POperationParam^) );
FillChar(AOperation^.Params^, cc * SizeOf(POperationParam^), #0);
AOperation^.ParamsCount := cc;
pp := AOperation^.Params;
for ii := 0 to Pred(cc) do begin
LoadParam(@(pp[ii]));
end;
end;
end;
var
j, k : LongInt;
po : PServiceOperation;
begin
AService^.Name := rdr.ReadStr();
k := rdr.ReadInt8U();
if ( k > 0 ) then begin
AService^.Operations := GetMem( k * SizeOf(PServiceOperation^) );
AService^.OperationsCount := k;
FillChar(AService^.Operations^,k * SizeOf(PServiceOperation^), #0);
po := AService^.Operations;
for j := 0 to Pred(k) do begin
LoadOperation(@(po[j]));
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(PServiceRepository^);
ARepository := GetMem(c);
try
FillChar(ARepository^,c,#0);
ARepository^.Name := rdr.ReadStr();
c := rdr.ReadInt8U();
if ( c > 0 ) then begin
ARepository^.Services := GetMem( c * SizeOf(PService^) );
ARepository^.ServicesCount := c;
FillChar(ARepository^.Services^,c * SizeOf(PService^),#0);
ps := ARepository^.Services;
for i := 0 to Pred(c) do begin
LoadService(@(ps[i]));
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;
pp : POperationParam;
begin
ADstOperation^.Name := ASrcOperation^.Name;
ADstOperation^.Properties := CloneProperties(ASrcOperation^.Properties);
cc := ASrcOperation^.ParamsCount;
if ( cc > 0 ) then begin
ADstOperation^.Params := GetMem( cc * SizeOf(POperationParam^) );
FillChar(ADstOperation^.Params^, cc * SizeOf(POperationParam^), #0);
ADstOperation^.ParamsCount := cc;
pp := ADstOperation^.Params;
for ii := 0 to Pred(cc) do begin
CopyParam(@(ASrcOperation^.Params[ii]),@(pp[ii]));
end;
end;
end;
var
j, k : LongInt;
po : PServiceOperation;
begin
ADestService^.Name := ASrcService^.Name;
k := ASrcService^.OperationsCount;
if ( k > 0 ) then begin
ADestService^.Operations := GetMem( k * SizeOf(PServiceOperation^) );
ADestService^.OperationsCount := k;
FillChar(ADestService^.Operations^,k * SizeOf(PServiceOperation^), #0);
po := ADestService^.Operations;
for j := 0 to Pred(k) do begin
CopyOperation(@(ASrcService^.Operations[j]),@(po[j]));
end;
end;
end;
function CloneService(const ASrcService : PService) : PService;
var
c : Integer;
begin
c := SizeOf(PService^);
Result := GetMem(c);
FillChar(Result^,c,#0);
CopyService(ASrcService,Result);
end;
procedure CloneRepository(
const ASource : PServiceRepository;
out ADest : PServiceRepository
);
var
buf : string;
i, c : LongInt;
ps : PService;
begin
ADest := nil;
if not Assigned(ASource) then
Exit;
c := SizeOf(PServiceRepository^);
ADest := 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 := GetMem( c * SizeOf(PService^) );
ADest^.ServicesCount := c;
FillChar(ADest^.Services^,c * SizeOf(PService^),#0);
ps := ADest^.Services;
for i := 0 to Pred(c) do begin
CopyService(@(ASource^.Services[i]),@(ps[i]));
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 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, c : Integer;
itm : TLResource;
begin
c := LazarusResources.Count;
for i := 0 to Pred(c) do begin
itm := LazarusResources.Items[i];
if AnsiSameText(sWST_META,itm.ValueType) then
RegisterRepository(itm.Name);
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;
rs : TLResource;
tmpRes : PServiceRepository;
begin
rs := LazarusResources.Find(ARepName);
if not Assigned(rs) then
raise EMetadataException.CreateFmt('Repository not registered : "%s"',[ARepName]);
Result := FindInnerListIndex(ARepName);
if ( Result < 0 ) then begin
tmpStrm := TMemoryStream.Create();
try
strBuffer := LazarusResources.Find(ARepName).Value;
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;
begin
for i := 0 to Pred(ARep^.ServicesCount) do begin
if AnsiSameText(AServiceName,ARep^.Services[i].Name) then begin
Result := @(ARep^.Services[i]);
Exit;
end;
end;
Result := nil;
end;
function FindOperation(
const AServ : PService;
const AOperationName : shortstring
) : PServiceOperation;
var
i : Integer;
begin
for i := 0 to Pred(AServ^.OperationsCount) do begin
if AnsiSameText(AOperationName,AServ^.Operations[i].Name) then begin
Result := @(AServ^.Operations[i]);
Exit;
end;
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];
for i := 0 to Pred(rp^.ServicesCount) do begin
if AnsiSameText(AServiceName,rp^.Services[i].Name) then begin
Result := CloneService(@(rp^.Services[i]));
Exit;
end;
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.

7
wst/tags/3.1/metadata_service.lrs Normal file
View File

@ -0,0 +1,7 @@
LazarusResources.Add('METADATA_SERVICE','wst_meta',[
#0#0#0#20'WST_METADATA_0.2.2.0'#0#0#0#16'metadata_service'#1#0#0#0#19'IWSTMet'
+'adataService'#2#0#0#0#17'GetRepositoryList'#1#0#0#0#6'result'#0#0#0#23'TArr'
+'ayOfStringRemotable'#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
]);

254
wst/tags/3.1/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;
{$mode objfpc}{$H+}
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.

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

Binary file not shown.

129
wst/tags/3.1/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 : "31/07/2006 23:18".
}
unit metadata_service_binder;
{$mode objfpc}{$H+}
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, LResources,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.lrs}
End.

126
wst/tags/3.1/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;
{$mode objfpc}{$H+}
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/3.1/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 : "31/07/2006 23:11".
}
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 LResources, 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.lrs}
{$IF DECLARED(Register_metadata_service_ServiceMetadata)}
Register_metadata_service_ServiceMetadata();
{$ENDIF}
End.

803
wst/tags/3.1/metadata_wsdl.pas Normal file
View File

@ -0,0 +1,803 @@
{
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;
{$mode objfpc}{$H+}
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';
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.Count]) ;
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;
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);
inNode := CreateElement(sWSDL_INPUT,opNode,ADoc);
strBuff := Format('%s:%s',[sSOAP,sBODY]);
bdyNode := CreateElement(strBuff,inNode,ADoc);
bdyNode.SetAttribute(sSOAP_USE,sSOAP_ENCODED);
bdyNode.SetAttribute(sNAME_SPACE,Format('%s',[AMdtdRep^.NameSpace]));
bdyNode.SetAttribute(sSOAP_ENCODING_STYLE,sSOAP_ENC_NS);
outNode := CreateElement(sWSDL_OUTPUT,opNode,ADoc);
strBuff := Format('%s:%s',[sSOAP,sBODY]);
bdyNode := CreateElement(strBuff,outNode,ADoc);
bdyNode.SetAttribute(sSOAP_USE,sSOAP_ENCODED);
bdyNode.SetAttribute(sNAME_SPACE,Format('%s',[AMdtdRep^.NameSpace]));
bdyNode.SetAttribute(sSOAP_ENCODING_STYLE,sSOAP_ENC_NS);
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.Count]) ;
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));
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.Count]) ;
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/3.1/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.

137
wst/tags/3.1/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;
{$mode objfpc}{$H+}
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';
BeginScopeRead(s,nil);
FCallTarget := StackTop().GetByIndex(0)^.Name;
BeginScopeRead(FCallTarget,nil);
FCallProcedureName := StackTop().GetByIndex(0)^.Name;
BeginScopeRead(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/3.1/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/3.1/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;
{$mode objfpc}{$H+}
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.

209
wst/tags/3.1/server_service_soap.pas Normal file
View File

@ -0,0 +1,209 @@
{
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;
{$mode objfpc}{$H+}
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();
BeginScope('Envelope',sSOAP_ENV,'SOAP-ENV');
AddScopeAttribute('xmlns:xsi',sXSI_NS);
AddScopeAttribute('xmlns:'+sXSD, sXSD_NS);
AddScopeAttribute('xmlns:'+sSOAP_ENC_ABR, sSOAP_ENC);
BeginScope('Body',sSOAP_ENV);
BeginScope(AProcName + 'Response',ATarget);
}
Clear();
Prepare();
WriteHeaders(FCallContext);
BeginScope('Body',sSOAP_ENV);
BeginScope(AProcName + 'Response',ATarget);
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,stArray).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');
AddScopeAttribute('xmlns:xsi',sXSI_NS);
AddScopeAttribute('xmlns:'+sXSD, sXSD_NS);
BeginScope('Body',sSOAP_ENV);
BeginScope('Fault',sSOAP_ENV);
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.

571
wst/tags/3.1/service_intf.pas Normal file
View File

@ -0,0 +1,571 @@
{
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;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, TypInfo, Contnrs,
base_service_intf;
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!
Objects passed by the parameter "AProtocol" will be freed by
this instance( the new one create by this constructor call ). *)
constructor Create(
Const ATarget : String; // the target service
Const AProtocol : IServiceProtocol
);virtual;
(* A User friendly constructor *)
constructor Create(
Const ATarget : String;
Const AProtocolData : string;
Const ATransportData : string
);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;
const 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;
strBuffer : 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));
for i := 0 to Pred(sd^.OperationsCount) do begin
opd := @(sd^.Operations[i]);
strBuffer := '';
pd := opd^.Properties;
while Assigned(pd) do begin
strBuffer := Format('%s%s=%s;',[strBuffer,pd^.Name,pd^.Data]);
pd := pd^.Next;
end;
if not IsStrEmpty(strBuffer) then begin
Delete(strBuffer,Length(strBuffer),1);
FOperationsProperties.Values[opd^.Name] := strBuffer;
end;
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();
procedure PrepareTransport();
var
strBuffer : string;
begin
LoadProperties();
strBuffer := FOperationsProperties.Values[GetSerializer().GetCallProcedureName()];
if not IsStrEmpty(strBuffer) then
GetTransport().GetPropertyManager().SetProperties(strBuffer);
end;
begin
PrepareTransport();
GetCallHandler().MakeCall(GetSerializer(),GetTransport());
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.

267
wst/tags/3.1/soap_formatter.pas Normal file
View File

@ -0,0 +1,267 @@
{
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
//BeginScope('Envelope',sSOAP_ENV,sSOAP_ENV_ABR);
//AddScopeAttribute('xmlns:xsi',sXSI_NS);
//AddScopeAttribute('xmlns:'+sXSD, sXSD_NS);
//AddScopeAttribute('xmlns:'+sSOAP_ENC_ABR, sSOAP_ENC);
Prepare();
WriteHeaders(ACallContext);
BeginScope('Body',sSOAP_ENV);
if ( Style = RPC ) then
BeginScope(AProcName,ATarget);
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,stArray).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.

178
wst/tags/3.1/synapse_http_protocol.pas Normal file
View File

@ -0,0 +1,178 @@
{
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;
{$mode objfpc}{$H+}
//{$DEFINE WST_DBG}
interface
uses
Classes, SysUtils,{$IFDEF WST_DBG}Dialogs,{$ENDIF}
service_intf, imp_utils, base_service_intf,
httpsend;
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(AResponse).SaveToFile('log.log');
SetLength(s,AResponse.Size);
Move(TMemoryStream(AResponse).Memory^,s[1],Length(s));
ShowMessage(s);
{$ENDIF}
end;
procedure SYNAPSE_RegisterHTTP_Transport();
begin
GetTransportRegistry().Register(sTRANSPORT_NAME,TSimpleItemFactory.Create(THTTPTransport) as IItemFactory);
end;
end.

359
wst/tags/3.1/tests/apache_module/mod_wst.lpi Normal file
View File

@ -0,0 +1,359 @@
<?xml version="1.0"?>
<CONFIG>
<ProjectOptions>
<PathDelim Value="\"/>
<Version Value="5"/>
<General>
<MainUnit Value="0"/>
<IconPath Value="./"/>
<TargetFileExt Value=".exe"/>
<ActiveEditorIndexAtStart Value="1"/>
</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="25">
<Unit0>
<Filename Value="mod_wst.lpr"/>
<IsPartOfProject Value="True"/>
<UnitName Value="mod_wst"/>
<CursorPos X="36" Y="47"/>
<TopLine Value="1"/>
<EditorIndex Value="0"/>
<UsageCount Value="45"/>
<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="45"/>
</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="45"/>
</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="45"/>
</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="45"/>
</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="246"/>
<TopLine Value="297"/>
<EditorIndex Value="1"/>
<UsageCount Value="45"/>
<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="6" Y="105"/>
<TopLine Value="94"/>
<EditorIndex Value="4"/>
<UsageCount Value="22"/>
<Loaded Value="True"/>
</Unit17>
<Unit18>
<Filename Value="..\..\metadata_wsdl.pas"/>
<UnitName Value="metadata_wsdl"/>
<CursorPos X="3" Y="589"/>
<TopLine Value="576"/>
<EditorIndex Value="5"/>
<UsageCount Value="22"/>
<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="22"/>
<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="1" Y="1"/>
<TopLine Value="1"/>
<EditorIndex Value="2"/>
<UsageCount Value="14"/>
<Loaded Value="True"/>
</Unit24>
</Units>
<JumpHistory Count="29" HistoryIndex="28">
<Position1>
<Filename Value="wst_apache_binding.pas"/>
<Caret Line="85" Column="46" TopLine="74"/>
</Position1>
<Position2>
<Filename Value="wst_apache_binding.pas"/>
<Caret Line="323" Column="28" TopLine="312"/>
</Position2>
<Position3>
<Filename Value="wst_apache_binding.pas"/>
<Caret Line="324" Column="48" TopLine="313"/>
</Position3>
<Position4>
<Filename Value="wst_apache_binding.pas"/>
<Caret Line="349" Column="32" TopLine="337"/>
</Position4>
<Position5>
<Filename Value="wst_apache_binding.pas"/>
<Caret Line="1" Column="1" TopLine="1"/>
</Position5>
<Position6>
<Filename Value="wst_apache_binding.pas"/>
<Caret Line="18" Column="15" TopLine="7"/>
</Position6>
<Position7>
<Filename Value="wst_apache_binding.pas"/>
<Caret Line="25" Column="40" TopLine="14"/>
</Position7>
<Position8>
<Filename Value="wst_apache_binding.pas"/>
<Caret Line="85" Column="33" TopLine="74"/>
</Position8>
<Position9>
<Filename Value="wst_apache_binding.pas"/>
<Caret Line="323" Column="28" TopLine="312"/>
</Position9>
<Position10>
<Filename Value="wst_apache_binding.pas"/>
<Caret Line="1" Column="1" TopLine="1"/>
</Position10>
<Position11>
<Filename Value="wst_apache_binding.pas"/>
<Caret Line="18" Column="15" TopLine="7"/>
</Position11>
<Position12>
<Filename Value="wst_apache_binding.pas"/>
<Caret Line="25" Column="40" TopLine="14"/>
</Position12>
<Position13>
<Filename Value="wst_apache_binding.pas"/>
<Caret Line="79" Column="28" TopLine="67"/>
</Position13>
<Position14>
<Filename Value="wst_apache_binding.pas"/>
<Caret Line="265" Column="11" TopLine="246"/>
</Position14>
<Position15>
<Filename Value="wst_apache_binding.pas"/>
<Caret Line="1" Column="1" TopLine="1"/>
</Position15>
<Position16>
<Filename Value="wst_apache_binding.pas"/>
<Caret Line="49" Column="32" TopLine="30"/>
</Position16>
<Position17>
<Filename Value="wst_apache_binding.pas"/>
<Caret Line="79" Column="28" TopLine="60"/>
</Position17>
<Position18>
<Filename Value="wst_apache_binding.pas"/>
<Caret Line="269" Column="1" TopLine="264"/>
</Position18>
<Position19>
<Filename Value="wst_apache_binding.pas"/>
<Caret Line="1" Column="1" TopLine="1"/>
</Position19>
<Position20>
<Filename Value="wst_apache_binding.pas"/>
<Caret Line="52" Column="11" TopLine="30"/>
</Position20>
<Position21>
<Filename Value="wst_apache_binding.pas"/>
<Caret Line="58" Column="74" TopLine="52"/>
</Position21>
<Position22>
<Filename Value="wst_apache_binding.pas"/>
<Caret Line="19" Column="20" TopLine="1"/>
</Position22>
<Position23>
<Filename Value="wst_apache_binding.pas"/>
<Caret Line="43" Column="1" TopLine="41"/>
</Position23>
<Position24>
<Filename Value="wst_apache_binding.pas"/>
<Caret Line="309" Column="1" TopLine="271"/>
</Position24>
<Position25>
<Filename Value="wst_apache_binding.pas"/>
<Caret Line="296" Column="38" TopLine="277"/>
</Position25>
<Position26>
<Filename Value="mod_wst.lpr"/>
<Caret Line="16" Column="1" TopLine="3"/>
</Position26>
<Position27>
<Filename Value="wst_apache_binding.pas"/>
<Caret Line="238" Column="18" TopLine="223"/>
</Position27>
<Position28>
<Filename Value="wst_apache_binding.pas"/>
<Caret Line="245" Column="20" TopLine="240"/>
</Position28>
<Position29>
<Filename Value="wst_apache_binding.pas"/>
<Caret Line="1" Column="19" TopLine="1"/>
</Position29>
</JumpHistory>
</ProjectOptions>
<CompilerOptions>
<Version Value="5"/>
<PathDelim Value="\"/>
<Target>
<Filename Value="mod_wst.so"/>
</Target>
<SearchPaths>
<OtherUnitFiles 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\"/>
<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/3.1/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/3.1/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.

114
wst/tags/3.1/tests/calculator/calculator.pas Normal file
View File

@ -0,0 +1,114 @@
unit calculator;
{$mode objfpc}{$H+}
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/3.1/tests/calculator/calculator.wst_meta Normal file
View File

Binary file not shown.

278
wst/tags/3.1/tests/calculator/client/calc_client.lpi Normal file
View File

@ -0,0 +1,278 @@
<?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>
<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="20">
<Unit0>
<Filename Value="calc_client.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="calc_client"/>
<CursorPos X="22" Y="49"/>
<TopLine Value="37"/>
<EditorIndex Value="0"/>
<UsageCount Value="68"/>
<Loaded Value="True"/>
</Unit0>
<Unit1>
<Filename Value="calculator_proxy.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="calculator_proxy"/>
<CursorPos X="44" Y="155"/>
<TopLine Value="4"/>
<EditorIndex Value="3"/>
<UsageCount Value="68"/>
<Loaded Value="True"/>
</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"/>
<EditorIndex Value="2"/>
<UsageCount Value="68"/>
<Loaded Value="True"/>
</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"/>
<EditorIndex Value="1"/>
<UsageCount Value="10"/>
<Loaded Value="True"/>
</Unit19>
</Units>
<JumpHistory Count="5" HistoryIndex="4">
<Position1>
<Filename Value="calc_client.pas"/>
<Caret Line="61" Column="49" TopLine="45"/>
</Position1>
<Position2>
<Filename Value="calc_client.pas"/>
<Caret Line="1" Column="1" TopLine="1"/>
</Position2>
<Position3>
<Filename Value="calc_client.pas"/>
<Caret Line="3" Column="45" TopLine="1"/>
</Position3>
<Position4>
<Filename Value="..\..\..\metadata_repository.pas"/>
<Caret Line="1" Column="1" TopLine="1"/>
</Position4>
<Position5>
<Filename Value="calculator_proxy.pas"/>
<Caret Line="93" Column="49" TopLine="77"/>
</Position5>
</JumpHistory>
</ProjectOptions>
<CompilerOptions>
<Version Value="5"/>
<PathDelim Value="\"/>
<SearchPaths>
<OtherUnitFiles Value="D:\LazarusClean\others_package\ics\latest_distr\Delphi\Vc32\;..\..\..\;..\..\..\tests\calculator\"/>
<UnitOutputDirectory Value="obj"/>
<SrcPath Value="..\..\..\;D:\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/3.1/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/3.1/tests/calculator/client/calculator.lrs Normal file
View File

@ -0,0 +1,13 @@
LazarusResources.Add('CALCULATOR','wst_meta',[
#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/3.1/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 : "30/07/2006 01:54".
}
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 LResources, 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.lrs}
{$IF DECLARED(Register_calculator_ServiceMetadata)}
Register_calculator_ServiceMetadata();
{$ENDIF}
End.

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

@ -0,0 +1,13 @@
LazarusResources.Add('CALCULATOR','wst_meta',[
#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/3.1/tests/calculator/gui_client/calculator.wst_meta Normal file
View File

Binary file not shown.

164
wst/tags/3.1/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 : "30/07/2006 01:54".
}
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 LResources, 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.lrs}
{$IF DECLARED(Register_calculator_ServiceMetadata)}
Register_calculator_ServiceMetadata();
{$ENDIF}
End.

126
wst/tags/3.1/tests/calculator/gui_client/main_unit.lfm Normal file
View File

@ -0,0 +1,126 @@
object fmain: Tfmain
Left = 269
Height = 300
Top = 234
Width = 528
HorzScrollBar.Page = 527
VertScrollBar.Page = 299
ActiveControl = edtA
Caption = '"calculator" service test'
OnCreate = FormCreate
object Label1: TLabel
Left = 16
Height = 14
Top = 48
Width = 49
Caption = 'Param "A"'
Color = clNone
ParentColor = False
end
object Label2: TLabel
Left = 17
Height = 14
Top = 80
Width = 48
Caption = 'Param "B"'
Color = clNone
ParentColor = False
end
object Label3: TLabel
Left = 240
Height = 14
Top = 52
Width = 35
Caption = 'Format'
Color = clNone
ParentColor = False
end
object Label4: TLabel
Left = 16
Height = 14
Top = 8
Width = 40
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

34
wst/tags/3.1/tests/calculator/gui_client/main_unit.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#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'#8'OnCre'
+'ate'#7#10'FormCreate'#0#6'TLabel'#6'Label1'#4'Left'#2#16#6'Height'#2#14#3'T'
+'op'#2'0'#5'Width'#2'1'#7'Caption'#6#9'Param "A"'#5'Color'#7#6'clNone'#11'Pa'
+'rentColor'#8#0#0#6'TLabel'#6'Label2'#4'Left'#2#17#6'Height'#2#14#3'Top'#2'P'
+#5'Width'#2'0'#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#14#3'Top'#2'4'#5'Widt'
+'h'#2'#'#7'Caption'#6#6'Format'#5'Color'#7#6'clNone'#11'ParentColor'#8#0#0#6
+'TLabel'#6'Label4'#4'Left'#2#16#6'Height'#2#14#3'Top'#2#8#5'Width'#2'('#7'Ca'
+'ption'#6#7'Address'#5'Color'#7#6'clNone'#11'ParentColor'#8#0#0#5'TEdit'#4'e'
+'dtA'#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'Top'#2#8#5'Width'#3#128#0#25'BorderSpacing.InnerBo'
+'rder'#2#4#7'Caption'#6#7'Execute'#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'Anchors'#11#5'akTop'#6'akLeft'#7'akRight'#8'akBottom'
+#0#12'Font.CharSet'#7#12'ANSI_CHARSET'#10'Font.Color'#7#7'clBlack'#11'Font.H'
+'eight'#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'TEd'
+'it'#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'SOAP'#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'OnClick'#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.InnerBorder'#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'7ht'
+'tp:Address=http://127.0.0.1:8000/services/ICalculator'#0#0#0
]);

144
wst/tags/3.1/tests/calculator/gui_client/main_unit.pas Normal file
View File

@ -0,0 +1,144 @@
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,
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(
'Calculator', // 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();
//SYNAPSE_RegisterHTTP_Transport();
end;
procedure Tfmain.LogMsg(const AMsg: string);
begin
mmoLog.Lines.Add(AMsg);
end;
initialization
{$I main_unit.lrs}
RegisterStdTypes();
end.

369
wst/tags/3.1/tests/calculator/gui_client/test_calc.lpi Normal file
View File

@ -0,0 +1,369 @@
<?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="35">
<Unit0>
<Filename Value="test_calc.lpr"/>
<IsPartOfProject Value="True"/>
<UnitName Value="test_calc"/>
<CursorPos X="66" Y="10"/>
<TopLine Value="1"/>
<UsageCount Value="80"/>
</Unit0>
<Unit1>
<Filename Value="main_unit.pas"/>
<ComponentName Value="fmain"/>
<IsPartOfProject Value="True"/>
<ResourceFilename Value="main_unit.lrs"/>
<UnitName Value="main_unit"/>
<CursorPos X="28" Y="58"/>
<TopLine Value="1"/>
<EditorIndex Value="0"/>
<UsageCount Value="80"/>
<Loaded Value="True"/>
</Unit1>
<Unit2>
<Filename Value="..\calculator.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="calculator"/>
<CursorPos X="30" Y="16"/>
<TopLine Value="8"/>
<EditorIndex Value="8"/>
<UsageCount Value="80"/>
<Loaded Value="True"/>
</Unit2>
<Unit3>
<Filename Value="calculator_proxy.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="calculator_proxy"/>
<CursorPos X="28" Y="1"/>
<TopLine Value="1"/>
<EditorIndex Value="9"/>
<UsageCount Value="80"/>
<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"/>
<EditorIndex Value="7"/>
<UsageCount Value="32"/>
<Loaded Value="True"/>
</Unit16>
<Unit17>
<Filename Value="..\..\..\soap_formatter.pas"/>
<UnitName Value="soap_formatter"/>
<CursorPos X="42" Y="171"/>
<TopLine Value="157"/>
<EditorIndex Value="4"/>
<UsageCount Value="32"/>
<Loaded Value="True"/>
</Unit17>
<Unit18>
<Filename Value="..\..\..\service_intf.pas"/>
<UnitName Value="service_intf"/>
<CursorPos X="58" Y="47"/>
<TopLine Value="31"/>
<EditorIndex Value="3"/>
<UsageCount Value="32"/>
<Loaded Value="True"/>
</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="1" Y="1"/>
<TopLine Value="454"/>
<EditorIndex Value="6"/>
<UsageCount Value="31"/>
<Loaded Value="True"/>
</Unit20>
<Unit21>
<Filename Value="..\..\..\base_service_intf.pas"/>
<UnitName Value="base_service_intf"/>
<CursorPos X="3" Y="235"/>
<TopLine Value="229"/>
<EditorIndex Value="2"/>
<UsageCount Value="31"/>
<Loaded Value="True"/>
</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"/>
<EditorIndex Value="5"/>
<UsageCount Value="15"/>
<Loaded Value="True"/>
</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"/>
<EditorIndex Value="1"/>
<UsageCount Value="10"/>
<Loaded Value="True"/>
</Unit34>
</Units>
<JumpHistory Count="2" HistoryIndex="1">
<Position1>
<Filename Value="main_unit.pas"/>
<Caret Line="64" Column="31" TopLine="51"/>
</Position1>
<Position2>
<Filename Value="main_unit.pas"/>
<Caret Line="1" Column="1" TopLine="1"/>
</Position2>
</JumpHistory>
</ProjectOptions>
<CompilerOptions>
<Version Value="5"/>
<PathDelim Value="\"/>
<SearchPaths>
<OtherUnitFiles Value="D:\Lazarus\others_package\ics\latest_distr\Delphi\Vc32\;..\;..\..\..\;D:\Lazarus\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="6">
<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>
<Item6>
<Source Value="main_unit.pas"/>
<Line Value="54"/>
</Item6>
</BreakPoints>
<Watches Count="1">
<Item1>
<Expression Value="ASource.Memory^"/>
</Item1>
</Watches>
</Debugging>
</CONFIG>

18
wst/tags/3.1/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/3.1/tests/calculator/srv/calculator.lrs Normal file
View File

@ -0,0 +1,13 @@
LazarusResources.Add('CALCULATOR','wst_meta',[
#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/3.1/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 : "30/07/2006 01:52".
}
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, LResources,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.lrs}
End.

157
wst/tags/3.1/tests/calculator/srv/calculator_imp.pas Normal file
View File

@ -0,0 +1,157 @@
{
This unit has been produced by ws_helper.
Input unit name : "calculator".
This unit name : "calculator_imp".
Date : "02/07/2006 16:49".
}
Unit calculator_imp;
{$mode objfpc}{$H+}
Interface
Uses SysUtils, Classes,
base_service_intf, server_service_intf, server_service_imputils, calculator;
Type
TCalculator_ServiceImp=class(TBaseServiceImplementation,ICalculator)
Protected
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;
procedure RegisterCalculatorImplementationFactory();
Implementation
{ TCalculator_ServiceImp implementation }
function TCalculator_ServiceImp.AddInt(
Const A : Integer;
Const B : Integer
):TBinaryArgsResult;
var
hdr : TCalcResultHeader;
h : TCalcHeader;
cc : ICallContext;
Begin
hdr := TCalcResultHeader.Create();
cc := GetCallContext();
if Assigned(cc) and ( cc.GetHeaderCount([hdIn]) > 0 ) and ( cc.GetHeader(0).InheritsFrom(TCalcHeader) ) then begin
h := cc.GetHeader(0) as TCalcHeader;
h.Understood := True;
hdr.Assign(h);
end;
hdr.TimeStamp := DateTimeToStr(Now());
hdr.SessionID := 'testSession';
cc.AddHeader(hdr,True);
hdr := nil;
Result := TBinaryArgsResult.Create();
Try
Result.Arg_OP := '+';
Result.Arg_OpEnum := coAdd;
Result.Arg_A := A;
Result.Arg_B := B;
Result.Arg_R := A + B;
Result.Comment := 'Doing an + operation';
Except
FreeAndNil(Result);
Raise;
End;
End;
function TCalculator_ServiceImp.DivInt(
Const A : Integer;
Const B : Integer
):Integer;
Begin
Result := A div B;
End;
function TCalculator_ServiceImp.DoAllOperations(
Const A : Integer;
Const B : Integer
):TBinaryArgsResultArray;
Begin
Result := TBinaryArgsResultArray.Create();
Result.SetLength(4);
With Result[0] do Begin
Arg_A := A;
Arg_B := B;
Arg_OP := '-';
Arg_OpEnum := coSub;
Arg_R := Arg_A - Arg_B;
End;
With Result[1] do Begin
Arg_A := A;
Arg_B := B;
Arg_OP := '+';
Arg_OpEnum := coAdd;
Arg_R := Arg_A + Arg_B;
End;
With Result[2] do Begin
Arg_A := A;
Arg_B := B;
Arg_OP := '*';
Arg_OpEnum := coMul;
Arg_R := Arg_A * Arg_B;
End;
With Result[3] do Begin
Arg_A := A;
Arg_B := B;
Arg_OP := '/';
Arg_OpEnum := coDiv;
Arg_R := Arg_A div Arg_B;
End;
End;
function TCalculator_ServiceImp.DoOperation(
Const A : Integer;
Const B : Integer;
Const AOperation : TCalc_Op
):TBinaryArgsResult;
Begin
Result := TBinaryArgsResult.Create();
try
Result.Arg_A := A;
Result.Arg_B := B;
Result.Arg_OP := 'X';
Result.Arg_OpEnum := AOperation;
Result.Comment := 'Doing an operation...';
case AOperation of
coAdd : Result.Arg_R := Result.Arg_A + Result.Arg_B;
coSub : Result.Arg_R := Result.Arg_A - Result.Arg_B;
coMul : Result.Arg_R := Result.Arg_A * Result.Arg_B;
coDiv : Result.Arg_R := Result.Arg_A div Result.Arg_B;
end;
except
FreeAndNil(Result);
raise;
end;
End;
procedure RegisterCalculatorImplementationFactory();
Begin
GetServiceImplementationRegistry().Register(
'ICalculator',
TImplementationFactory.Create(TCalculator_ServiceImp) as IServiceImplementationFactory
).RegisterExtension(['TLoggerServiceExtension']);
End;
End.

81
wst/tags/3.1/tests/calculator/srv/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.

9
wst/tags/3.1/tests/ebay/ebay.lrs Normal file
View File

@ -0,0 +1,9 @@
LazarusResources.Add('EBAY','wst_meta',[
#0#0#0#20'WST_METADATA_0.2.2.0'#0#0#0#4'ebay'#1#0#0#0#24'IeBayAPIInterfaceSer'
+'vice'#2#0#0#0#13'GetCategories'#2#0#0#0#20'GetCategoriesRequest'#0#0#0#25'T'
+'GetCategoriesRequestType'#0#0#0#0#0#0#0#1#0#0#0#21'GetCategoriesResponse'#0
+#0#0#26'TGetCategoriesResponseType'#0#0#0#0#0#0#0#3#0#0#0#18'GetPopularKeywo'
+'rds'#2#0#0#0#25'GetPopularKeywordsRequest'#0#0#0#30'TGetPopularKeywordsRequ'
+'estType'#0#0#0#0#0#0#0#1#0#0#0#26'GetPopularKeywordsResponse'#0#0#0#31'TGet'
+'PopularKeywordsResponseType'#0#0#0#0#0#0#0#3
]);

562
wst/tags/3.1/tests/ebay/ebay.pas Normal file
View File

@ -0,0 +1,562 @@
unit ebay;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, base_service_intf;
const
sAPP_ID = '<your AppId>';
sEBAY_VERSION = '467';
type
TAckCodeType = ( Success, Failure, Warning, PartialFailure, CustomCode );
{ TErrorType = class(TBaseComplexRemotable)
published
property ShortMessage : string read FShortMessage write FShortMessage stored HasShortMessage;
property LongMessage : string read FLongMessage write FLongMessage stored HasLongMessage;
end;
}
{ TPaginationType }
TPaginationType = class(TBaseComplexRemotable)
private
FEntriesPerPage: Integer;
FPageNumber: Integer;
function HasEntriesPerPage: boolean;
function HasPageNumber: boolean;
published
property EntriesPerPage : Integer read FEntriesPerPage write FEntriesPerPage stored HasEntriesPerPage;
property PageNumber : Integer read FPageNumber write FPageNumber stored HasPageNumber;
end;
{ TPaginationResultType }
TPaginationResultType = class(TBaseComplexRemotable)
private
FTotalNumberOfEntries: Integer;
FTotalNumberOfPages: Integer;
function HasTotalNumberOfEntries: boolean;
function HasTotalNumberOfPages: boolean;
published
property TotalNumberOfPages : Integer read FTotalNumberOfPages write FTotalNumberOfPages stored HasTotalNumberOfPages;
property TotalNumberOfEntries : Integer read FTotalNumberOfEntries write FTotalNumberOfEntries stored HasTotalNumberOfEntries;
end;
{ TCategoryType }
TCategoryType = class(TBaseComplexRemotable)
private
FAutoPayEnabled: Boolean;
FB2BVATEnabled: Boolean;
FBestOfferEnabled: Boolean;
FCatalogEnabled: Boolean;
FCategoryID: string;
FCategoryLevel: Integer;
FCategoryName: string;
FCategoryParentID: string;
FCategoryParentName: string;
FKeywords: string;
FProductFinderAvailable: Boolean;
FProductFinderID: Integer;
FProductSearchPageAvailable: Boolean;
function HasCategoryID: boolean;
function HasCategoryLevel: boolean;
function HasCategoryName: boolean;
function HasCategoryParentID: boolean;
function HasCategoryParentName: boolean;
function HasKeywords: boolean;
function HasProductFinderID: boolean;
published
property BestOfferEnabled : Boolean read FBestOfferEnabled write FBestOfferEnabled stored FBestOfferEnabled;
property AutoPayEnabled : Boolean read FAutoPayEnabled write FAutoPayEnabled stored FAutoPayEnabled;
property B2BVATEnabled : Boolean read FB2BVATEnabled write FB2BVATEnabled stored FB2BVATEnabled;
property CatalogEnabled : Boolean read FCatalogEnabled write FCatalogEnabled stored FCatalogEnabled;
property CategoryID : string read FCategoryID write FCategoryID stored HasCategoryID;
property CategoryLevel : Integer read FCategoryLevel write FCategoryLevel stored HasCategoryLevel;
property CategoryName : string read FCategoryName write FCategoryName stored HasCategoryName;
property CategoryParentID : string read FCategoryParentID write FCategoryParentID stored HasCategoryParentID;
property CategoryParentName : string read FCategoryParentName write FCategoryParentName stored HasCategoryParentName;
property ProductFinderID : Integer read FProductFinderID write FProductFinderID stored HasProductFinderID;
property ProductSearchPageAvailable : Boolean read FProductSearchPageAvailable write FProductSearchPageAvailable stored FProductSearchPageAvailable;
property ProductFinderAvailable : Boolean read FProductFinderAvailable write FProductFinderAvailable stored FProductFinderAvailable;
property Keywords : string read FKeywords write FKeywords stored HasKeywords;
end;
{ TCategoryArrayType }
TCategoryArrayType = class(TBaseObjectArrayRemotable)
private
function GetCategoryItem(AIndex: Integer): TCategoryType;
public
class function GetItemClass():TBaseRemotableClass;override;
property Item[AIndex:Integer] : TCategoryType read GetCategoryItem;
property Category[AIndex:Integer] : TCategoryType read GetCategoryItem;default;
end;
{ TUserIdPasswordType }
TUserIdPasswordType = class(TBaseComplexRemotable)
private
FAppId: string;
FAuthCert: string;
FDevId: string;
FPassword: string;
FUsername: string;
function HasAppId: boolean;
function HasAuthCert: boolean;
function HasDevId: boolean;
function HasPassword: boolean;
function HasUsername: boolean;
published
property AppId : string read FAppId write FAppId stored HasAppId;
property DevId : string read FDevId write FDevId stored HasDevId;
property AuthCert : string read FAuthCert write FAuthCert stored HasAuthCert;
property Username : string read FUsername write FUsername stored HasUsername;
property Password : string read FPassword write FPassword stored HasPassword;
end;
{ TCustomSecurityHeaderType }
TCustomSecurityHeaderType = class(THeaderBlock)
private
FCredentials: TUserIdPasswordType;
FeBayAuthToken: string;
public
constructor Create();override;
destructor Destroy();override;
published
property eBayAuthToken : string read FeBayAuthToken write FeBayAuthToken;
property Credentials : TUserIdPasswordType read FCredentials write FCredentials;
end;
{ TAbstractRequestType }
TAbstractRequestType = class(TBaseComplexRemotable)
private
FVersion: string;
published
property Version : string read FVersion write FVersion;
end;
{ TAbstractResponseType }
TAbstractResponseType = class(TBaseComplexRemotable)
private
FAck: TAckCodeType;
FCorrelationID: string;
FMessage: string;
FVersion: string;
function HasAck: boolean;
function HasCorrelationID: boolean;
function HasMessage: boolean;
function HasVersion: boolean;
published
property CorrelationID : string read FCorrelationID write FCorrelationID stored HasCorrelationID;
property Message : string read FMessage write FMessage stored HasMessage;
property Version : string read FVersion write FVersion stored HasVersion;
property Ack : TAckCodeType read FAck write FAck stored HasAck;
end;
{ TGetCategoriesRequestType }
TGetCategoriesRequestType = class(TAbstractRequestType)
private
FCategorySiteID: string;
function HasCategorySiteID: boolean;
published
property CategorySiteID : string read FCategorySiteID write FCategorySiteID stored HasCategorySiteID;
end;
{ TGetCategoriesResponseType }
TGetCategoriesResponseType = class(TAbstractResponseType)
private
FCategoryCount: Integer;
FCategoryVersion: string;
FMinimumReservePrice: Double;
FReservePriceAllowed: Boolean;
function HasCategoryCount: boolean;
function HasCategoryVersion: boolean;
function HasMinimumReservePrice: boolean;
function HasReservePriceAllowed: boolean;
published
property CategoryCount : Integer read FCategoryCount write FCategoryCount stored HasCategoryCount;
property CategoryVersion : string read FCategoryVersion write FCategoryVersion stored HasCategoryVersion;
property ReservePriceAllowed : Boolean read FReservePriceAllowed write FReservePriceAllowed stored HasReservePriceAllowed;
property MinimumReservePrice : Double read FMinimumReservePrice write FMinimumReservePrice stored HasMinimumReservePrice;
end;
{ TGetPopularKeywordsRequestType }
TGetPopularKeywordsRequestType = class(TAbstractRequestType)
private
FCategoryID: string;
FIncludeChildCategories: Boolean;
FMaxKeywordsRetrieved: Integer;
FPagination: TPaginationType;
function HasCategoryID: boolean;
function HasIncludeChildCategories: boolean;
function HasMaxKeywordsRetrieved: boolean;
function HasPagination: boolean;
public
constructor Create();override;
destructor Destroy();override;
published
property CategoryID : string read FCategoryID write FCategoryID stored HasCategoryID;
property IncludeChildCategories : Boolean read FIncludeChildCategories write FIncludeChildCategories stored HasIncludeChildCategories;
property MaxKeywordsRetrieved : Integer read FMaxKeywordsRetrieved write FMaxKeywordsRetrieved stored HasMaxKeywordsRetrieved;
property Pagination : TPaginationType read FPagination write FPagination stored HasPagination;
end;
{ TGetPopularKeywordsResponseType }
TGetPopularKeywordsResponseType = class(TAbstractResponseType)
private
FCategoryArray: TCategoryArrayType;
FHasMore: Boolean;
FPaginationResult: TPaginationResultType;
function HasCategoryArray: boolean;
function HasPaginationResult: boolean;
procedure SetCategoryArray(const AValue: TCategoryArrayType);
procedure SetPaginationResult(const AValue: TPaginationResultType);
public
constructor Create();override;
destructor Destroy();override;
published
property HasMore : Boolean read FHasMore write FHasMore stored FHasMore;
property CategoryArray : TCategoryArrayType read FCategoryArray write SetCategoryArray stored HasCategoryArray;
property PaginationResult : TPaginationResultType read FPaginationResult write SetPaginationResult stored HasPaginationResult;
end;
IeBayAPIInterfaceService = interface
{function GetCategories(GetCategoriesRequest : TGetCategoriesRequestType ) : TGetCategoriesResponseType;}
procedure GetCategories(
const GetCategoriesRequest : TGetCategoriesRequestType;
out GetCategoriesResponse : TGetCategoriesResponseType
);
procedure GetPopularKeywords(
const GetPopularKeywordsRequest : TGetPopularKeywordsRequestType;
out GetPopularKeywordsResponse : TGetPopularKeywordsResponseType
);
end;
procedure Register_ebay_ServiceMetadata();
implementation
uses imp_utils, metadata_repository;
const
sE_BAY_API_VERSION = 'Version 467';
sE_BAY_NAME_SPACE = 'urn:ebay:apis:eBLBaseComponents';
{ TAbstractResponseType }
function TAbstractResponseType.HasCorrelationID: boolean;
begin
Result := not IsStrEmpty(FCorrelationID);
end;
function TAbstractResponseType.HasAck: boolean;
begin
Result := FAck > Success;
end;
function TAbstractResponseType.HasMessage: boolean;
begin
Result := not IsStrEmpty(FMessage);
end;
function TAbstractResponseType.HasVersion: boolean;
begin
Result := not IsStrEmpty(FVersion);
end;
{ TGetCategoriesRequestType }
function TGetCategoriesRequestType.HasCategorySiteID: boolean;
begin
Result := not IsStrEmpty(FCategorySiteID);
end;
{ TGetCategoriesResponseType }
function TGetCategoriesResponseType.HasCategoryCount: boolean;
begin
Result := ( FCategoryCount > 0 );
end;
function TGetCategoriesResponseType.HasCategoryVersion: boolean;
begin
Result := not IsStrEmpty(FCategoryVersion);
end;
function TGetCategoriesResponseType.HasMinimumReservePrice: boolean;
begin
Result := ( MinimumReservePrice <> 0 );
end;
function TGetCategoriesResponseType.HasReservePriceAllowed: boolean;
begin
Result := FReservePriceAllowed;
end;
{ TUserIdPasswordType }
function TUserIdPasswordType.HasAppId: boolean;
begin
Result := not IsStrEmpty(FAppId);
end;
function TUserIdPasswordType.HasAuthCert: boolean;
begin
Result := not IsStrEmpty(FAuthCert);
end;
function TUserIdPasswordType.HasDevId: boolean;
begin
Result := not IsStrEmpty(FDevId);
end;
function TUserIdPasswordType.HasPassword: boolean;
begin
Result := not IsStrEmpty(FPassword);
end;
function TUserIdPasswordType.HasUsername: boolean;
begin
Result := not IsStrEmpty(FUsername);
end;
{ TCustomSecurityHeaderType }
constructor TCustomSecurityHeaderType.Create();
begin
inherited Create();
FCredentials := TUserIdPasswordType.Create();
end;
destructor TCustomSecurityHeaderType.Destroy();
begin
FreeAndNil(FCredentials);
inherited Destroy();
end;
{ TPaginationType }
function TPaginationType.HasEntriesPerPage: boolean;
begin
Result := HasEntriesPerPage;
end;
function TPaginationType.HasPageNumber: boolean;
begin
Result := ( FPageNumber <> 0 );
end;
{ TGetPopularKeywordsRequestType }
function TGetPopularKeywordsRequestType.HasCategoryID: boolean;
begin
Result := not IsStrEmpty(FCategoryID);
end;
function TGetPopularKeywordsRequestType.HasIncludeChildCategories: boolean;
begin
Result := IncludeChildCategories;
end;
function TGetPopularKeywordsRequestType.HasMaxKeywordsRetrieved: boolean;
begin
Result := ( MaxKeywordsRetrieved <> 0 );
end;
function TGetPopularKeywordsRequestType.HasPagination: boolean;
begin
Result := Assigned(FPagination) and
( FPagination.HasEntriesPerPage or FPagination.HasPageNumber);
end;
constructor TGetPopularKeywordsRequestType.Create();
begin
inherited Create();
end;
destructor TGetPopularKeywordsRequestType.Destroy();
begin
FreeAndNil(FPagination);
inherited Destroy();
end;
{ TCategoryType }
function TCategoryType.HasCategoryID: boolean;
begin
Result := not IsStrEmpty(FCategoryID);
end;
function TCategoryType.HasCategoryLevel: boolean;
begin
Result := ( FCategoryLevel <> 0 );
end;
function TCategoryType.HasCategoryName: boolean;
begin
Result := not IsStrEmpty(FCategoryName);
end;
function TCategoryType.HasCategoryParentID: boolean;
begin
Result := not IsStrEmpty(FCategoryParentID);
end;
function TCategoryType.HasCategoryParentName: boolean;
begin
Result := not IsStrEmpty(FCategoryParentName);
end;
function TCategoryType.HasKeywords: boolean;
begin
Result := not IsStrEmpty(FKeywords);
end;
function TCategoryType.HasProductFinderID: boolean;
begin
Result := ( FProductFinderID > 0 );
end;
{ TCategoryArrayType }
function TCategoryArrayType.GetCategoryItem(AIndex: Integer): TCategoryType;
begin
Result := inherited GetItem(AIndex) as TCategoryType;
end;
class function TCategoryArrayType.GetItemClass(): TBaseRemotableClass;
begin
Result := TCategoryType;
end;
{ TGetPopularKeywordsResponseType }
function TGetPopularKeywordsResponseType.HasCategoryArray: boolean;
begin
Result := ( FCategoryArray.Length > 0 );
end;
function TGetPopularKeywordsResponseType.HasPaginationResult: boolean;
begin
Result := ( FPaginationResult.TotalNumberOfEntries <> 0 ) or
( FPaginationResult.TotalNumberOfPages <> 0 ) ;
end;
procedure TGetPopularKeywordsResponseType.SetCategoryArray(
const AValue: TCategoryArrayType
);
begin
if ( FCategoryArray = AValue ) then
exit;
FCategoryArray.Assign(AValue) ;
end;
procedure TGetPopularKeywordsResponseType.SetPaginationResult(
const AValue: TPaginationResultType
);
begin
if ( FPaginationResult = AValue ) then
exit;
FPaginationResult.Assign(AValue);
end;
constructor TGetPopularKeywordsResponseType.Create();
begin
FCategoryArray := TCategoryArrayType.Create();
FPaginationResult := TPaginationResultType.Create();
inherited Create();
end;
destructor TGetPopularKeywordsResponseType.Destroy();
begin
FreeAndNil(FPaginationResult);
FreeAndNil(FCategoryArray);
inherited Destroy();
end;
procedure RegisterEbayTypes();
Var
r : TTypeRegistry;
ri : TTypeRegistryItem;
begin
r := GetTypeRegistry();
r.Register(sE_BAY_NAME_SPACE,TypeInfo(TAckCodeType),'AckCodeType');
r.Register(sE_BAY_NAME_SPACE,TypeInfo(TCategoryType),'CategoryType');
r.Register(sE_BAY_NAME_SPACE,TypeInfo(TCategoryArrayType),'CategoryArrayType');
r.Register(sE_BAY_NAME_SPACE,TypeInfo(TPaginationType),'PaginationType');
r.Register(sE_BAY_NAME_SPACE,TypeInfo(TPaginationResultType),'PaginationResultType');
r.Register(sE_BAY_NAME_SPACE,TypeInfo(TGetPopularKeywordsRequestType),'GetPopularKeywordsRequestType');
r.Register(sE_BAY_NAME_SPACE,TypeInfo(TGetPopularKeywordsResponseType),'GetPopularKeywordsResponseType');
r.Register(sE_BAY_NAME_SPACE,TypeInfo(TUserIdPasswordType),'UserIdPasswordType');
r.Register(sE_BAY_NAME_SPACE,TypeInfo(TCustomSecurityHeaderType),'RequesterCredentials');//'CustomSecurityHeaderType');
r.Register(sE_BAY_NAME_SPACE,TypeInfo(TGetCategoriesRequestType),'GetCategoriesRequestType');
r.Register(sE_BAY_NAME_SPACE,TypeInfo(TGetCategoriesResponseType),'GetCategoriesResponseType');
end;
procedure Register_ebay_ServiceMetadata();
var
mm : IModuleMetadataMngr;
begin
mm := GetModuleMetadataMngr();
mm.SetOperationCustomData(
'ebay',
'IeBayAPIInterfaceService',
'GetCategories',
'Address',
'https://api.sandbox.ebay.com/wsapi?' +
'callname=GetCategories' +
'&siteid=0' +
'&appid=' + sAPP_ID +
'&version=' + sEBAY_VERSION
);
mm.SetOperationCustomData(
'ebay',
'IeBayAPIInterfaceService',
'GetPopularKeywords',
'Address',
'https://api.sandbox.ebay.com/wsapi?' +
'callname=GetPopularKeywords' +
'&siteid=0' +
'&appid=' + sAPP_ID +
'&version=' + sEBAY_VERSION
);
end;
{ TPaginationResultType }
function TPaginationResultType.HasTotalNumberOfEntries: boolean;
begin
Result := ( FTotalNumberOfEntries <> 0 );
end;
function TPaginationResultType.HasTotalNumberOfPages: boolean;
begin
Result := ( FTotalNumberOfPages <> 0 );
end;
initialization
RegisterEbayTypes();
end.

BIN
wst/tags/3.1/tests/ebay/ebay.wst_meta Normal file
View File

Binary file not shown.

98
wst/tags/3.1/tests/ebay/ebay_proxy.pas Normal file
View File

@ -0,0 +1,98 @@
{
This unit has been produced by ws_helper.
Input unit name : "ebay".
This unit name : "ebay_proxy".
Date : "30/07/2006 21:52".
}
Unit ebay_proxy;
{$mode objfpc}{$H+}
Interface
Uses SysUtils, Classes, TypInfo, base_service_intf, service_intf, ebay;
Type
TeBayAPIInterfaceService_Proxy=class(TBaseProxy,IeBayAPIInterfaceService)
Protected
class function GetServiceType() : PTypeInfo;override;
procedure GetCategories(
Const GetCategoriesRequest : TGetCategoriesRequestType;
Out GetCategoriesResponse : TGetCategoriesResponseType
);
procedure GetPopularKeywords(
Const GetPopularKeywordsRequest : TGetPopularKeywordsRequestType;
Out GetPopularKeywordsResponse : TGetPopularKeywordsResponseType
);
End;
Implementation
uses LResources, metadata_repository;
{ TeBayAPIInterfaceService_Proxy implementation }
class function TeBayAPIInterfaceService_Proxy.GetServiceType() : PTypeInfo;
begin
result := TypeInfo(IeBayAPIInterfaceService);
end;
procedure TeBayAPIInterfaceService_Proxy.GetCategories(
Const GetCategoriesRequest : TGetCategoriesRequestType;
Out GetCategoriesResponse : TGetCategoriesResponseType
);
Var
locSerializer : IFormatterClient;
strPrmName : string;
Begin
locSerializer := GetSerializer();
Try
locSerializer.BeginCall('GetCategories', GetTarget(),(Self as ICallContext));
locSerializer.Put('GetCategoriesRequest', TypeInfo(TGetCategoriesRequestType), GetCategoriesRequest);
locSerializer.EndCall();
MakeCall();
locSerializer.BeginCallRead((Self as ICallContext));
Pointer(GetCategoriesResponse) := Nil;
strPrmName := 'GetCategoriesResponse';
locSerializer.Get(TypeInfo(TGetCategoriesResponseType), strPrmName, GetCategoriesResponse);
Finally
locSerializer.Clear();
End;
End;
procedure TeBayAPIInterfaceService_Proxy.GetPopularKeywords(
Const GetPopularKeywordsRequest : TGetPopularKeywordsRequestType;
Out GetPopularKeywordsResponse : TGetPopularKeywordsResponseType
);
Var
locSerializer : IFormatterClient;
strPrmName : string;
Begin
locSerializer := GetSerializer();
Try
locSerializer.BeginCall('GetPopularKeywords', GetTarget(),(Self as ICallContext));
locSerializer.Put('GetPopularKeywordsRequest', TypeInfo(TGetPopularKeywordsRequestType), GetPopularKeywordsRequest);
locSerializer.EndCall();
MakeCall();
locSerializer.BeginCallRead((Self as ICallContext));
Pointer(GetPopularKeywordsResponse) := Nil;
strPrmName := 'GetPopularKeywordsResponse';
locSerializer.Get(TypeInfo(TGetPopularKeywordsResponseType), strPrmName, GetPopularKeywordsResponse);
Finally
locSerializer.Clear();
End;
End;
initialization
{$i ebay.lrs}
{$IF DECLARED(Register_ebay_ServiceMetadata)}
Register_ebay_ServiceMetadata();
{$ENDIF}
End.

386
wst/tags/3.1/tests/ebay/test_ebay.lpi Normal file
View File

@ -0,0 +1,386 @@
<?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="indylaz"/>
</Item1>
</RequiredPackages>
<Units Count="22">
<Unit0>
<Filename Value="test_ebay.lpr"/>
<IsPartOfProject Value="True"/>
<UnitName Value="test_ebay"/>
<CursorPos X="34" Y="63"/>
<TopLine Value="1"/>
<EditorIndex Value="0"/>
<UsageCount Value="43"/>
<Loaded Value="True"/>
</Unit0>
<Unit1>
<Filename Value="ebay.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="ebay"/>
<CursorPos X="18" Y="103"/>
<TopLine Value="156"/>
<UsageCount Value="43"/>
</Unit1>
<Unit2>
<Filename Value="..\..\service_intf.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="service_intf"/>
<CursorPos X="1" Y="151"/>
<TopLine Value="140"/>
<EditorIndex Value="2"/>
<UsageCount Value="43"/>
<Loaded Value="True"/>
</Unit2>
<Unit3>
<Filename Value="..\..\soap_formatter.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="soap_formatter"/>
<CursorPos X="25" Y="244"/>
<TopLine Value="236"/>
<EditorIndex Value="6"/>
<UsageCount Value="43"/>
<Loaded Value="True"/>
</Unit3>
<Unit4>
<Filename Value="..\..\base_service_intf.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="base_service_intf"/>
<CursorPos X="20" Y="30"/>
<TopLine Value="11"/>
<UsageCount Value="43"/>
</Unit4>
<Unit5>
<Filename Value="..\..\base_soap_formatter.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="base_soap_formatter"/>
<CursorPos X="1" Y="619"/>
<TopLine Value="608"/>
<UsageCount Value="43"/>
<Bookmarks Count="1">
<Item0 X="11" Y="610" ID="1"/>
</Bookmarks>
</Unit5>
<Unit6>
<Filename Value="ebay_proxy.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="ebay_proxy"/>
<CursorPos X="1" Y="34"/>
<TopLine Value="23"/>
<EditorIndex Value="1"/>
<UsageCount Value="43"/>
<Loaded Value="True"/>
</Unit6>
<Unit7>
<Filename Value="..\..\ics_http_protocol.pas"/>
<UnitName Value="ics_http_protocol"/>
<CursorPos X="33" Y="161"/>
<TopLine Value="143"/>
<UsageCount Value="19"/>
</Unit7>
<Unit8>
<Filename Value="D:\Lazarus\others_package\indy\indy-10.2.0.1\fpc\Protocols\IdSSLOpenSSL.pas"/>
<UnitName Value="IdSSLOpenSSL"/>
<CursorPos X="14" Y="267"/>
<TopLine Value="250"/>
<UsageCount Value="17"/>
</Unit8>
<Unit9>
<Filename Value="..\..\indy_http_protocol.pas"/>
<UnitName Value="indy_http_protocol"/>
<CursorPos X="1" Y="38"/>
<TopLine Value="38"/>
<UsageCount Value="20"/>
</Unit9>
<Unit10>
<Filename Value="D:\Lazarus\others_package\indy\indy-10.2.0.1\fpc\Protocols\IdHTTP.pas"/>
<UnitName Value="IdHTTP"/>
<CursorPos X="9" Y="342"/>
<TopLine Value="328"/>
<UsageCount Value="12"/>
</Unit10>
<Unit11>
<Filename Value="D:\Lazarus\others_package\indy\indy-10.2.0.1\fpc\Protocols\IdSSL.pas"/>
<UnitName Value="IdSSL"/>
<CursorPos X="1" Y="1"/>
<TopLine Value="14"/>
<UsageCount Value="10"/>
</Unit11>
<Unit12>
<Filename Value="D:\Lazarus\others_package\indy\indy-10.2.0.1\fpc\Core\IdTCPClient.pas"/>
<UnitName Value="IdTCPClient"/>
<CursorPos X="3" Y="144"/>
<TopLine Value="165"/>
<UsageCount Value="12"/>
</Unit12>
<Unit13>
<Filename Value="..\..\synapse_http_protocol.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="synapse_http_protocol"/>
<CursorPos X="1" Y="155"/>
<TopLine Value="132"/>
<EditorIndex Value="3"/>
<UsageCount Value="24"/>
<Loaded Value="True"/>
</Unit13>
<Unit14>
<Filename Value="D:\lazarusClean\others_package\synapse\httpsend.pas"/>
<UnitName Value="httpsend"/>
<CursorPos X="30" Y="143"/>
<TopLine Value="132"/>
<UsageCount Value="12"/>
</Unit14>
<Unit15>
<Filename Value="D:\lazarusClean\others_package\synapse\blcksock.pas"/>
<UnitName Value="blcksock"/>
<CursorPos X="1" Y="3571"/>
<TopLine Value="3560"/>
<UsageCount Value="12"/>
</Unit15>
<Unit16>
<Filename Value="D:\lazarusClean\others_package\synapse\ssl_openssl.pas"/>
<UnitName Value="ssl_openssl"/>
<CursorPos X="1" Y="506"/>
<TopLine Value="495"/>
<UsageCount Value="10"/>
</Unit16>
<Unit17>
<Filename Value="D:\lazarusClean\others_package\synapse\ssl_openssl_lib.pas"/>
<UnitName Value="ssl_openssl_lib"/>
<CursorPos X="1" Y="1233"/>
<TopLine Value="1222"/>
<UsageCount Value="10"/>
</Unit17>
<Unit18>
<Filename Value="D:\lazarusClean\fpcsrc\rtl\objpas\classes\classesh.inc"/>
<CursorPos X="14" Y="604"/>
<TopLine Value="593"/>
<UsageCount Value="10"/>
</Unit18>
<Unit19>
<Filename Value="D:\lazarusClean\fpcsrc\rtl\objpas\classes\streams.inc"/>
<CursorPos X="7" Y="180"/>
<TopLine Value="158"/>
<UsageCount Value="10"/>
</Unit19>
<Unit20>
<Filename Value="D:\Lazarus\others_package\synapse\httpsend.pas"/>
<UnitName Value="httpsend"/>
<CursorPos X="1" Y="566"/>
<TopLine Value="555"/>
<EditorIndex Value="4"/>
<UsageCount Value="10"/>
<Loaded Value="True"/>
</Unit20>
<Unit21>
<Filename Value="D:\Lazarus\others_package\synapse\blcksock.pas"/>
<UnitName Value="blcksock"/>
<CursorPos X="1" Y="1901"/>
<TopLine Value="1890"/>
<EditorIndex Value="5"/>
<UsageCount Value="10"/>
<Loaded Value="True"/>
</Unit21>
</Units>
<JumpHistory Count="26" HistoryIndex="25">
<Position1>
<Filename Value="D:\Lazarus\others_package\synapse\httpsend.pas"/>
<Caret Line="531" Column="1" TopLine="520"/>
</Position1>
<Position2>
<Filename Value="D:\Lazarus\others_package\synapse\httpsend.pas"/>
<Caret Line="534" Column="1" TopLine="523"/>
</Position2>
<Position3>
<Filename Value="D:\Lazarus\others_package\synapse\httpsend.pas"/>
<Caret Line="537" Column="1" TopLine="526"/>
</Position3>
<Position4>
<Filename Value="D:\Lazarus\others_package\synapse\httpsend.pas"/>
<Caret Line="538" Column="11" TopLine="527"/>
</Position4>
<Position5>
<Filename Value="D:\Lazarus\others_package\synapse\httpsend.pas"/>
<Caret Line="541" Column="32" TopLine="530"/>
</Position5>
<Position6>
<Filename Value="D:\Lazarus\others_package\synapse\httpsend.pas"/>
<Caret Line="543" Column="1" TopLine="532"/>
</Position6>
<Position7>
<Filename Value="D:\Lazarus\others_package\synapse\httpsend.pas"/>
<Caret Line="544" Column="1" TopLine="533"/>
</Position7>
<Position8>
<Filename Value="D:\Lazarus\others_package\synapse\httpsend.pas"/>
<Caret Line="558" Column="1" TopLine="547"/>
</Position8>
<Position9>
<Filename Value="D:\Lazarus\others_package\synapse\httpsend.pas"/>
<Caret Line="559" Column="1" TopLine="548"/>
</Position9>
<Position10>
<Filename Value="D:\Lazarus\others_package\synapse\httpsend.pas"/>
<Caret Line="561" Column="1" TopLine="550"/>
</Position10>
<Position11>
<Filename Value="D:\Lazarus\others_package\synapse\httpsend.pas"/>
<Caret Line="562" Column="1" TopLine="551"/>
</Position11>
<Position12>
<Filename Value="D:\Lazarus\others_package\synapse\httpsend.pas"/>
<Caret Line="563" Column="1" TopLine="552"/>
</Position12>
<Position13>
<Filename Value="D:\Lazarus\others_package\synapse\httpsend.pas"/>
<Caret Line="565" Column="1" TopLine="554"/>
</Position13>
<Position14>
<Filename Value="D:\Lazarus\others_package\synapse\httpsend.pas"/>
<Caret Line="566" Column="1" TopLine="555"/>
</Position14>
<Position15>
<Filename Value="D:\Lazarus\others_package\synapse\httpsend.pas"/>
<Caret Line="572" Column="1" TopLine="561"/>
</Position15>
<Position16>
<Filename Value="D:\Lazarus\others_package\synapse\httpsend.pas"/>
<Caret Line="574" Column="1" TopLine="563"/>
</Position16>
<Position17>
<Filename Value="D:\Lazarus\others_package\synapse\httpsend.pas"/>
<Caret Line="580" Column="1" TopLine="569"/>
</Position17>
<Position18>
<Filename Value="D:\Lazarus\others_package\synapse\httpsend.pas"/>
<Caret Line="582" Column="1" TopLine="571"/>
</Position18>
<Position19>
<Filename Value="D:\Lazarus\others_package\synapse\httpsend.pas"/>
<Caret Line="561" Column="1" TopLine="550"/>
</Position19>
<Position20>
<Filename Value="D:\Lazarus\others_package\synapse\httpsend.pas"/>
<Caret Line="562" Column="1" TopLine="551"/>
</Position20>
<Position21>
<Filename Value="D:\Lazarus\others_package\synapse\httpsend.pas"/>
<Caret Line="563" Column="1" TopLine="552"/>
</Position21>
<Position22>
<Filename Value="D:\Lazarus\others_package\synapse\httpsend.pas"/>
<Caret Line="565" Column="1" TopLine="554"/>
</Position22>
<Position23>
<Filename Value="D:\Lazarus\others_package\synapse\httpsend.pas"/>
<Caret Line="566" Column="1" TopLine="555"/>
</Position23>
<Position24>
<Filename Value="test_ebay.lpr"/>
<Caret Line="75" Column="64" TopLine="58"/>
</Position24>
<Position25>
<Filename Value="test_ebay.lpr"/>
<Caret Line="1" Column="1" TopLine="1"/>
</Position25>
<Position26>
<Filename Value="test_ebay.lpr"/>
<Caret Line="63" Column="34" TopLine="52"/>
</Position26>
</JumpHistory>
</ProjectOptions>
<CompilerOptions>
<Version Value="5"/>
<PathDelim Value="\"/>
<SearchPaths>
<OtherUnitFiles Value="..\..\;D:\Lazarus\others_package\ics\latest_distr\Delphi\Vc32\;D:\Lazarus\others_package\indy\indy-10.2.0.1\fpc\Protocols\;D:\lazarus\others_package\synapse\"/>
<UnitOutputDirectory Value="obj"/>
</SearchPaths>
<CodeGeneration>
<Generate Value="Faster"/>
</CodeGeneration>
<Other>
<CompilerPath Value="$(CompPath)"/>
</Other>
</CompilerOptions>
<Debugging>
<BreakPoints Count="12">
<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_ebay.lpr"/>
<Line Value="67"/>
</Item8>
<Item9>
<Source Value="..\..\synapse_http_protocol.pas"/>
<Line Value="160"/>
</Item9>
<Item10>
<Source Value="D:\lazarusClean\others_package\synapse\ssl_openssl.pas"/>
<Line Value="813"/>
</Item10>
<Item11>
<Source Value="..\..\synapse_http_protocol.pas"/>
<Line Value="156"/>
</Item11>
<Item12>
<Source Value="..\..\synapse_http_protocol.pas"/>
<Line Value="150"/>
</Item12>
</BreakPoints>
<Watches Count="1">
<Item1>
<Expression Value="ASource.Memory^"/>
</Item1>
</Watches>
</Debugging>
</CONFIG>

83
wst/tags/3.1/tests/ebay/test_ebay.lpr Normal file
View File

@ -0,0 +1,83 @@
program test_ebay;
{$mode objfpc}{$H+}
uses
{$IFDEF UNIX}{$IFDEF UseCThreads}
cthreads,
{$ENDIF}{$ENDIF}
Classes, SysUtils,
service_intf, soap_formatter, base_service_intf, base_soap_formatter,
//ics_http_protocol,
//indylaz,
//indy_http_protocol,
ebay, ebay_proxy,
ssl_openssl, synapse_http_protocol;
var
locService : IeBayAPIInterfaceService;
locHdr : TCustomSecurityHeaderType;
r : TGetCategoriesRequestType;
rsp : TGetCategoriesResponseType;
begin
//Indy_RegisterHTTP_Transport();
SYNAPSE_RegisterHTTP_Transport();
r := nil;
rsp := nil;
locHdr := TCustomSecurityHeaderType.Create();
try
locHdr.eBayAuthToken := {
'AgAAAA**AQAAAA**aAAAAA**OeGvRA**nY+sHZ2PrBmdj6wVnY+sEZ2PrA2dj6wJnY+lAZOE'+
'pgqdj6x9nY+seQ**uoUAAA**AAMAAA**z5djiOw1a7Tk12KGGPqSpvnxxNYOVUtaSbmQ7hYd4p'+
'X4XfafLKBtImKsW9SUsbmBS9fXOyBnXA3k0jLelpiMptvlZ8N52UQA/ePc6+JE7LJFrARMoBaW5l'+
'HEQOMESJLAdFJiGmLwrnagdeo6WRI89guRtDkydPyHwHUJ7aCFQvwzeD/b+1pnXelHQvQBRFtD3drU'+
'BV9FbAf1/d4w/C+x5EHrBHyA+/T9uBelb3wkI8Rk/jnwF+L1qZlSW90pcyi3uxoSuBGVolgihrL/IKE'+
'2mPcK3GAtqROu6Tsasjzz/tqkSIuFLeJ9HphAzdB+LNhyR1NGbe+l+goY74saRbEb2iqYo5wCTTLELC2k3'+
'9p0V1Fp7CWn3Fet+y6fz8PXMb1BfYKg6fLzHXaqCRaffHJCSkvhrWwIVEuxbot4o5T8/v'+
'TcmmAm3T78S4B6NBdLPv7f4WxbzYYRS8Y8k7Y9GZ1/8Jomfv+LlGNrs0/sN+PkCJATAJZ3W'+
'tIWqyg9GHnHVA+oKCdmItd2j6nEiNq7whNdJegMOWp3jI2BvJoauJc06lw6ZMHhuj4zDiDnEwP'+
'DCBmY6sHWMUx1xacahKYrRsvKYvE9/eOlEaQP7OCDmJm6VVwJIkSejOnmnMmUxLGMu6to17jruAj'+
'Wb4s0oXSKPg9J/M2rvgE0l0tWj3O6kt9jPH533K5Wj2I/i6s0blc9z9eY/WY4+HDHe+VFX9AqMmHuD'+
'yog//CUNDaG5HUSw10GM26gvswNpYWGih5Ju5ylvf9B';}
'AgAAAA**AQAAAA**aAAAAA**5Ca0RA**nY+sHZ2PrBmdj6wVnY+sEZ2PrA2dj6wJnY+lAZSFpg'+
'Wdj6x9nY+seQ**uoUAAA**AAMAAA**CVYGMzI5zQ2Wh9dcHROrT0o6/BWlHNSzb+sPVl+W7UK8o0'+
'zpmispZNrnzXjlqd5m5nZjWfXzEGFTZVw7B+2k14tcQyiCQQn0nD6ft5KUWsxZ4Ugx/EgilEFNhT7l'+
'iQXBxblWq1K3CJJtyCRu1Q/eyW0c4cttutktG3c5wFGR20QUm8pFBaXVNEB11jAyzz2dB+Ij3efuSTZR'+
'umGNaVHeNXkLXTfaVuOzREjU5zye4bh1cHtw72pS+oTbmKB+Svflhtq7asqnfrsllRENP6fEpCzJSVqbMW'+
'Om+rulRa0qKOOpEGk2Mme8HDdccwtqHIq1MwT9WbcF2pV6aGKpllU4H+ii7SYwDTr8mwb45t7l26loyszoZo'+
'NelhXq3TS85KwmDqwgZzVlHoY+4yZVe8FRvOY7rYbtCJtZnwv7fx8+tdoogeE2eW5hNkXPvuS+Wh9yj+T1yexp'+
'5szSfOVmn1Obik6Cz/qOxF+AIHpdO1N8qC6D/x85nlkxUbvVWBHkAVYsAxbQ1uZzpRIednc8wKLZ47cTUGPinP1B'+
'hgC9+l14Isquhsx5gx9t3vc79lzfRPMOaQ5k42vZaUFYTpQ2tYn7kQ9y850NPBdNVmUxLi5hCActWCHFplNrYVnnnm'+
'WOcuZT+DTUmh2OHiL59Av33CPhGNCGktEX0/I3FNTbM2OHCqet/eSRXNHM4JuuLhP2p7IyDfbowkXpwDZtanew64itUr'+
'iSInDbHpO9xlVK32t/+na6yNuCGqFEEtnl5gJ2OI1P';
//locHdr.Credentials.Username := 'inousa12';
//locHdr.Credentials.Password := 'atou121076';
locHdr.Credentials.AppId := 'INOUSSAOUEU258CIC9Z5E83UXC1BE5';
locHdr.Credentials.DevId := 'L11ZDC63VDJ1FPLJL5EA161OQ2MS95';
locHdr.Credentials.AuthCert := 'A266GKZC9F5$HI2HIH58A-D3JH2YA4';//'L11ZDC63VDJ1FPLJL5EA161OQ2MS95;INOUSSAOUEU258CIC9Z5E83UXC1BE5;A266GKZC9F5$HI2HIH58A-D3JH2YA4';
locService := TeBayAPIInterfaceService_Proxy.Create(
'eBayAPIInterfaceService',
'SOAP:Style=Document;EncodingStyle=Litteral',
'http:Address=https://api.sandbox.ebay.com/wsapi?callname=GetCategories&siteid=0&appid=INOUSSAOUEU258CIC9Z5E83UXC1BE5&version=467'
); //https://api.sandbox.ebay.com/wsapi
//https://api.sandbox.ebay.com/wsapi
//https://api.sandbox.ebay.com/ws/api.dll
(locService as ICallContext).AddHeader(locHdr,True);
r := TGetCategoriesRequestType.Create();
r.Version := '467';
try
locService.GetCategories(r,rsp);
except
on e : Exception do begin
WriteLn('Exception : ',e.Message);
raise;
end;
end;
finally
r.Free();
rsp.Free();
end;
end.

304
wst/tags/3.1/tests/ebay/test_ebay_gui.lpi Normal file
View File

@ -0,0 +1,304 @@
<?xml version="1.0"?>
<CONFIG>
<ProjectOptions>
<PathDelim Value="\"/>
<Version Value="5"/>
<General>
<MainUnit Value="0"/>
<IconPath Value="./"/>
<TargetFileExt Value=".exe"/>
<ActiveEditorIndexAtStart Value="3"/>
</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="23">
<Unit0>
<Filename Value="test_ebay_gui.lpr"/>
<IsPartOfProject Value="True"/>
<UnitName Value="test_ebay_gui"/>
<CursorPos X="1" Y="17"/>
<TopLine Value="1"/>
<UsageCount Value="63"/>
</Unit0>
<Unit1>
<Filename Value="umain.pas"/>
<ComponentName Value="Form1"/>
<IsPartOfProject Value="True"/>
<ResourceFilename Value="umain.lrs"/>
<UnitName Value="umain"/>
<CursorPos X="39" Y="144"/>
<TopLine Value="137"/>
<EditorIndex Value="1"/>
<UsageCount Value="63"/>
<Loaded Value="True"/>
</Unit1>
<Unit2>
<Filename Value="..\..\synapse_http_protocol.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="synapse_http_protocol"/>
<CursorPos X="1" Y="1"/>
<TopLine Value="157"/>
<EditorIndex Value="0"/>
<UsageCount Value="63"/>
<Loaded Value="True"/>
</Unit2>
<Unit3>
<Filename Value="..\..\base_service_intf.pas"/>
<UnitName Value="base_service_intf"/>
<CursorPos X="1" Y="1"/>
<TopLine Value="1"/>
<EditorIndex Value="4"/>
<UsageCount Value="30"/>
<Loaded Value="True"/>
</Unit3>
<Unit4>
<Filename Value="..\..\service_intf.pas"/>
<UnitName Value="service_intf"/>
<CursorPos X="23" Y="333"/>
<TopLine Value="320"/>
<UsageCount Value="31"/>
</Unit4>
<Unit5>
<Filename Value="..\..\soap_formatter.pas"/>
<UnitName Value="soap_formatter"/>
<CursorPos X="60" Y="159"/>
<TopLine Value="149"/>
<UsageCount Value="24"/>
</Unit5>
<Unit6>
<Filename Value="..\..\imp_utils.pas"/>
<UnitName Value="imp_utils"/>
<CursorPos X="3" Y="119"/>
<TopLine Value="109"/>
<UsageCount Value="17"/>
</Unit6>
<Unit7>
<Filename Value="..\..\base_soap_formatter.pas"/>
<UnitName Value="base_soap_formatter"/>
<CursorPos X="33" Y="86"/>
<TopLine Value="76"/>
<UsageCount Value="26"/>
<Bookmarks Count="2">
<Item0 X="14" Y="670" ID="1"/>
<Item1 X="1" Y="437" ID="2"/>
</Bookmarks>
</Unit7>
<Unit8>
<Filename Value="D:\lazarusClean\others_package\synapse\httpsend.pas"/>
<UnitName Value="httpsend"/>
<CursorPos X="40" Y="123"/>
<TopLine Value="122"/>
<UsageCount Value="10"/>
</Unit8>
<Unit9>
<Filename Value="ebay.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="ebay"/>
<CursorPos X="13" Y="536"/>
<TopLine Value="525"/>
<EditorIndex Value="3"/>
<UsageCount Value="47"/>
<Loaded Value="True"/>
</Unit9>
<Unit10>
<Filename Value="..\..\metadata_service.pas"/>
<UnitName Value="metadata_service"/>
<CursorPos X="1" Y="1"/>
<TopLine Value="43"/>
<UsageCount Value="8"/>
</Unit10>
<Unit11>
<Filename Value="..\..\metadata_repository.pas"/>
<UnitName Value="metadata_repository"/>
<CursorPos X="46" Y="84"/>
<TopLine Value="84"/>
<UsageCount Value="17"/>
<Bookmarks Count="1">
<Item0 X="1" Y="91" ID="3"/>
</Bookmarks>
</Unit11>
<Unit12>
<Filename Value="ebay_proxy.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="ebay_proxy"/>
<CursorPos X="26" Y="96"/>
<TopLine Value="77"/>
<EditorIndex Value="2"/>
<UsageCount Value="47"/>
<Loaded Value="True"/>
</Unit12>
<Unit13>
<Filename Value="D:\lazarusClean\fpcsrc\rtl\inc\heaph.inc"/>
<CursorPos X="10" Y="94"/>
<TopLine Value="82"/>
<UsageCount Value="8"/>
</Unit13>
<Unit14>
<Filename Value="D:\lazarusClean\fpcsrc\rtl\inc\heap.inc"/>
<CursorPos X="3" Y="342"/>
<TopLine Value="346"/>
<UsageCount Value="8"/>
</Unit14>
<Unit15>
<Filename Value="D:\lazarusClean\fpcsrc\rtl\objpas\typinfo.pp"/>
<UnitName Value="typinfo"/>
<CursorPos X="1" Y="1"/>
<TopLine Value="94"/>
<UsageCount Value="9"/>
</Unit15>
<Unit16>
<Filename Value="ebay.lrs"/>
<CursorPos X="20" Y="1"/>
<TopLine Value="1"/>
<UsageCount Value="9"/>
</Unit16>
<Unit17>
<Filename Value="D:\lazarusClean\lcl\lresources.pp"/>
<UnitName Value="LResources"/>
<CursorPos X="3" Y="930"/>
<TopLine Value="907"/>
<UsageCount Value="9"/>
</Unit17>
<Unit18>
<Filename Value="D:\Lazarus\fpcsrc\rtl\inc\objpash.inc"/>
<CursorPos X="20" Y="169"/>
<TopLine Value="157"/>
<UsageCount Value="10"/>
</Unit18>
<Unit19>
<Filename Value="D:\Lazarus\fpcsrc\rtl\inc\objpas.inc"/>
<CursorPos X="28" Y="446"/>
<TopLine Value="428"/>
<UsageCount Value="10"/>
</Unit19>
<Unit20>
<Filename Value="D:\Lazarus\fpcsrc\fcl\inc\contnrs.pp"/>
<UnitName Value="contnrs"/>
<CursorPos X="23" Y="520"/>
<TopLine Value="517"/>
<UsageCount Value="10"/>
</Unit20>
<Unit21>
<Filename Value="D:\Lazarus\fpcsrc\rtl\objpas\classes\classesh.inc"/>
<CursorPos X="15" Y="204"/>
<TopLine Value="192"/>
<UsageCount Value="10"/>
</Unit21>
<Unit22>
<Filename Value="D:\Lazarus\fpcsrc\rtl\objpas\classes\lists.inc"/>
<CursorPos X="3" Y="417"/>
<TopLine Value="412"/>
<UsageCount Value="10"/>
</Unit22>
</Units>
<JumpHistory Count="5" HistoryIndex="4">
<Position1>
<Filename Value="umain.pas"/>
<Caret Line="31" Column="25" TopLine="26"/>
</Position1>
<Position2>
<Filename Value="umain.pas"/>
<Caret Line="149" Column="36" TopLine="138"/>
</Position2>
<Position3>
<Filename Value="umain.pas"/>
<Caret Line="46" Column="24" TopLine="33"/>
</Position3>
<Position4>
<Filename Value="ebay_proxy.pas"/>
<Caret Line="96" Column="26" TopLine="77"/>
</Position4>
<Position5>
<Filename Value="ebay.pas"/>
<Caret Line="524" Column="5" TopLine="515"/>
</Position5>
</JumpHistory>
</ProjectOptions>
<CompilerOptions>
<Version Value="5"/>
<PathDelim Value="\"/>
<SearchPaths>
<OtherUnitFiles Value="D:\lazarus\others_package\synapse\;..\..\"/>
<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>
<CustomOptions Value=""/>
<CompilerPath Value="$(CompPath)"/>
</Other>
</CompilerOptions>
<Debugging>
<BreakPoints Count="10">
<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_ebay.lpr"/>
<Line Value="67"/>
</Item8>
<Item9>
<Source Value="D:\lazarusClean\others_package\synapse\ssl_openssl.pas"/>
<Line Value="813"/>
</Item9>
<Item10>
<Source Value="umain.pas"/>
<Line Value="92"/>
</Item10>
</BreakPoints>
<Watches Count="1">
<Item1>
<Expression Value="ASource.Memory^"/>
</Item1>
</Watches>
</Debugging>
</CONFIG>

18
wst/tags/3.1/tests/ebay/test_ebay_gui.lpr Normal file
View File

@ -0,0 +1,18 @@
program test_ebay_gui;
{$mode objfpc}{$H+}
uses
{$IFDEF UNIX}{$IFDEF UseCThreads}
cthreads,
{$ENDIF}{$ENDIF}
Interfaces, // this includes the LCL widgetset
Forms
{ add your units here }, umain, synapse_http_protocol, ebay, ebay_proxy;
begin
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.

121
wst/tags/3.1/tests/ebay/umain.lfm Normal file
View File

@ -0,0 +1,121 @@
object Form1: TForm1
Left = 301
Height = 388
Top = 159
Width = 400
HorzScrollBar.Page = 399
VertScrollBar.Page = 387
ActiveControl = Button1
Caption = 'Form1'
OnCreate = FormCreate
object Panel1: TPanel
Height = 184
Width = 400
Align = alTop
TabOrder = 0
object Label1: TLabel
Left = 16
Height = 14
Top = 53
Width = 77
Caption = 'eBayAuthToken'
Color = clNone
ParentColor = False
end
object Label2: TLabel
Left = 16
Height = 14
Top = 79
Width = 30
Caption = 'AppId'
Color = clNone
ParentColor = False
end
object Label3: TLabel
Left = 16
Height = 14
Top = 111
Width = 30
Caption = 'DevId'
Color = clNone
ParentColor = False
end
object Label4: TLabel
Left = 16
Height = 14
Top = 144
Width = 45
Caption = 'AuthCert'
Color = clNone
ParentColor = False
end
object Bevel1: TBevel
Left = 10
Height = 170
Top = 4
Width = 380
Anchors = [akTop, akLeft, akRight]
end
object Button1: TButton
Left = 288
Height = 25
Top = 8
Width = 99
BorderSpacing.InnerBorder = 4
Caption = 'GetCategories'
OnClick = Button1Click
TabOrder = 0
Visible = False
end
object Button3: TButton
Left = 16
Height = 25
Top = 8
Width = 136
BorderSpacing.InnerBorder = 4
Caption = 'GetPopularKeywords'
OnClick = Button3Click
TabOrder = 1
end
object edteBayAuthToken: TEdit
Left = 96
Height = 23
Top = 48
Width = 288
Anchors = [akTop, akLeft, akRight]
TabOrder = 2
end
object edtAppId: TEdit
Left = 96
Height = 23
Top = 77
Width = 288
Anchors = [akTop, akLeft, akRight]
TabOrder = 3
end
object edtDevId: TEdit
Left = 96
Height = 23
Top = 108
Width = 288
Anchors = [akTop, akLeft, akRight]
TabOrder = 4
end
object edtAuthCert: TEdit
Left = 96
Height = 23
Top = 136
Width = 288
Anchors = [akTop, akLeft, akRight]
TabOrder = 5
end
end
object trvOut: TTreeView
Height = 204
Top = 184
Width = 400
Align = alClient
DefaultItemHeight = 15
TabOrder = 1
end
end

31
wst/tags/3.1/tests/ebay/umain.lrs Normal file
View File

@ -0,0 +1,31 @@
LazarusResources.Add('TForm1','FORMDATA',[
'TPF0'#6'TForm1'#5'Form1'#4'Left'#3'-'#1#6'Height'#3#132#1#3'Top'#3#159#0#5'W'
+'idth'#3#144#1#18'HorzScrollBar.Page'#3#143#1#18'VertScrollBar.Page'#3#131#1
+#13'ActiveControl'#7#7'Button1'#7'Caption'#6#5'Form1'#8'OnCreate'#7#10'FormC'
+'reate'#0#6'TPanel'#6'Panel1'#6'Height'#3#184#0#5'Width'#3#144#1#5'Align'#7#5
+'alTop'#8'TabOrder'#2#0#0#6'TLabel'#6'Label1'#4'Left'#2#16#6'Height'#2#14#3
+'Top'#2'5'#5'Width'#2'M'#7'Caption'#6#13'eBayAuthToken'#5'Color'#7#6'clNone'
+#11'ParentColor'#8#0#0#6'TLabel'#6'Label2'#4'Left'#2#16#6'Height'#2#14#3'Top'
+#2'O'#5'Width'#2#30#7'Caption'#6#5'AppId'#5'Color'#7#6'clNone'#11'ParentColo'
+'r'#8#0#0#6'TLabel'#6'Label3'#4'Left'#2#16#6'Height'#2#14#3'Top'#2'o'#5'Widt'
+'h'#2#30#7'Caption'#6#5'DevId'#5'Color'#7#6'clNone'#11'ParentColor'#8#0#0#6
+'TLabel'#6'Label4'#4'Left'#2#16#6'Height'#2#14#3'Top'#3#144#0#5'Width'#2'-'#7
+'Caption'#6#8'AuthCert'#5'Color'#7#6'clNone'#11'ParentColor'#8#0#0#6'TBevel'
+#6'Bevel1'#4'Left'#2#10#6'Height'#3#170#0#3'Top'#2#4#5'Width'#3'|'#1#7'Ancho'
+'rs'#11#5'akTop'#6'akLeft'#7'akRight'#0#0#0#7'TButton'#7'Button1'#4'Left'#3
+' '#1#6'Height'#2#25#3'Top'#2#8#5'Width'#2'c'#25'BorderSpacing.InnerBorder'#2
+#4#7'Caption'#6#13'GetCategories'#7'OnClick'#7#12'Button1Click'#8'TabOrder'#2
+#0#7'Visible'#8#0#0#7'TButton'#7'Button3'#4'Left'#2#16#6'Height'#2#25#3'Top'
+#2#8#5'Width'#3#136#0#25'BorderSpacing.InnerBorder'#2#4#7'Caption'#6#18'GetP'
+'opularKeywords'#7'OnClick'#7#12'Button3Click'#8'TabOrder'#2#1#0#0#5'TEdit'
+#16'edteBayAuthToken'#4'Left'#2'`'#6'Height'#2#23#3'Top'#2'0'#5'Width'#3' '#1
+#7'Anchors'#11#5'akTop'#6'akLeft'#7'akRight'#0#8'TabOrder'#2#2#0#0#5'TEdit'#8
+'edtAppId'#4'Left'#2'`'#6'Height'#2#23#3'Top'#2'M'#5'Width'#3' '#1#7'Anchors'
+#11#5'akTop'#6'akLeft'#7'akRight'#0#8'TabOrder'#2#3#0#0#5'TEdit'#8'edtDevId'
+#4'Left'#2'`'#6'Height'#2#23#3'Top'#2'l'#5'Width'#3' '#1#7'Anchors'#11#5'akT'
+'op'#6'akLeft'#7'akRight'#0#8'TabOrder'#2#4#0#0#5'TEdit'#11'edtAuthCert'#4'L'
+'eft'#2'`'#6'Height'#2#23#3'Top'#3#136#0#5'Width'#3' '#1#7'Anchors'#11#5'akT'
+'op'#6'akLeft'#7'akRight'#0#8'TabOrder'#2#5#0#0#0#9'TTreeView'#6'trvOut'#6'H'
+'eight'#3#204#0#3'Top'#3#184#0#5'Width'#3#144#1#5'Align'#7#8'alClient'#17'De'
+'faultItemHeight'#2#15#8'TabOrder'#2#1#0#0#0
]);

182
wst/tags/3.1/tests/ebay/umain.pas Normal file
View File

@ -0,0 +1,182 @@
unit umain;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, ExtCtrls,
Buttons, StdCtrls, ComCtrls;
type
{ TForm1 }
TForm1 = class(TForm)
Bevel1: TBevel;
Button1: TButton;
Button3: TButton;
edteBayAuthToken: TEdit;
edtAppId: TEdit;
edtDevId: TEdit;
edtAuthCert: TEdit;
Label1: TLabel;
Label2: TLabel;
Label3: TLabel;
Label4: TLabel;
Panel1: TPanel;
trvOut: TTreeView;
procedure Button1Click(Sender: TObject);
procedure Button3Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
{ private declarations }
public
{ public declarations }
end;
var
Form1: TForm1;
implementation
uses TypInfo, StrUtils,
httpsend, ssl_openssl,
service_intf, soap_formatter, base_service_intf, base_soap_formatter,
ebay, ebay_proxy,
synapse_http_protocol;
{ TForm1 }
procedure TForm1.Button1Click(Sender: TObject);
var
locService : IeBayAPIInterfaceService;
locHdr : TCustomSecurityHeaderType;
r : TGetCategoriesRequestType;
rsp : TGetCategoriesResponseType;
begin
try
r := nil;
rsp := nil;
locHdr := TCustomSecurityHeaderType.Create();
try
locHdr.eBayAuthToken := edteBayAuthToken.Text;
locHdr.Credentials.AppId := edtAppId.Text;
locHdr.Credentials.DevId := edtDevId.Text;
locHdr.Credentials.AuthCert := edtAuthCert.Text;
locService := TeBayAPIInterfaceService_Proxy.Create(
'eBayAPIInterfaceService',
'SOAP:Style=Document;EncodingStyle=Litteral;UniqueAddress=false',
'http:Address=https://api.sandbox.ebay.com/wsapi'
);
(locService as ICallContext).AddHeader(locHdr,True);
r := TGetCategoriesRequestType.Create();
r.Version := sEBAY_VERSION;
locService.GetCategories(r,rsp);
if Assigned(rsp) then
ShowMessageFmt('CategoryCount=%d; Message=%s; Version = %s',[rsp.CategoryCount,rsp.Message,rsp.Version])
else
ShowMessage('rsp = nil');
finally
r.Free();
rsp.Free();
end;
except
on e : ESOAPException do begin
ShowMessageFmt('SOAP EXCEPTION Code : "%s"; String = "%s"',[e.FaultCode,e.FaultString]);
end;
end;
end;
procedure TForm1.Button3Click(Sender: TObject);
procedure ShowResponse(ARsp : TGetPopularKeywordsResponseType);
var
nd, an, nn, pn : TTreeNode;
k : Integer;
ci : TCategoryType;
begin
trvOut.BeginUpdate();
try
trvOut.Items.Clear();
if not Assigned(ARsp) then
Exit;
nd := trvOut.Items.AddChild(nil,'Response');
trvOut.Items.AddChild(nd,'Ack = ' + GetEnumName(TypeInfo(TAckCodeType),Ord(ARsp.Ack)));
trvOut.Items.AddChild(nd,'Version = ' + ARsp.Version);
trvOut.Items.AddChild(nd,'HasMore = ' + IfThen(ARsp.HasMore,'True','False'));
pn := trvOut.Items.AddChild(nd,'PaginationResult');
trvOut.Items.AddChild(pn,'TotalNumberOfEntries = ' + IntToStr(ARsp.PaginationResult.TotalNumberOfEntries));
trvOut.Items.AddChild(pn,'TotalNumberOfPages = ' + IntToStr(ARsp.PaginationResult.TotalNumberOfPages));
an := trvOut.Items.AddChild(nd,'CategoryArray ( ' + IntToStr(ARsp.CategoryArray.Length) + ')');
for k := 0 to Pred(ARsp.CategoryArray.Length) do begin
ci := ARsp.CategoryArray[k];
nn := trvOut.Items.AddChild(an,'Category ( ' + IntToStr(k) + ' )');
trvOut.Items.AddChild(nn,'CategoryID = ' + ci.CategoryID);
trvOut.Items.AddChild(nn,'CategoryParentID = ' + ci.CategoryParentID);
trvOut.Items.AddChild(nn,'Keywords = ' + ci.Keywords);
end;
finally
trvOut.EndUpdate();
end;
end;
var
locService : IeBayAPIInterfaceService;
locHdr : TCustomSecurityHeaderType;
r : TGetPopularKeywordsRequestType;
rsp : TGetPopularKeywordsResponseType;
kpCrs : TCursor;
begin
try
r := nil;
rsp := nil;
kpCrs := Screen.Cursor;
locHdr := TCustomSecurityHeaderType.Create();
try
Screen.Cursor := crHourGlass;
locHdr.eBayAuthToken := edteBayAuthToken.Text;
locHdr.Credentials.AppId := edtAppId.Text;
locHdr.Credentials.DevId := edtDevId.Text;
locHdr.Credentials.AuthCert := edtAuthCert.Text;
locService := TeBayAPIInterfaceService_Proxy.Create(
'eBayAPIInterfaceService',
'SOAP:Style=Document;EncodingStyle=Litteral;UniqueAddress=false',
'http:Address=https://api.sandbox.ebay.com/wsapi'
);
(locService as ICallContext).AddHeader(locHdr,True);
r := TGetPopularKeywordsRequestType.Create();
r.Version := sEBAY_VERSION;
r.IncludeChildCategories := True;
locService.GetPopularKeywords(r,rsp);
if Assigned(rsp) then begin
ShowResponse(rsp);
end else begin
ShowMessage('rsp = nil');
end;
finally
Screen.Cursor := kpCrs;
r.Free();
rsp.Free();
end;
except
on e : ESOAPException do begin
ShowMessageFmt('SOAP EXCEPTION Code : "%s"; String = "%s"',[e.FaultCode,e.FaultString]);
end;
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
SYNAPSE_RegisterHTTP_Transport();
end;
initialization
{$I umain.lrs}
end.

13
wst/tags/3.1/tests/google_api/googlewebapi.lrs Normal file
View File

@ -0,0 +1,13 @@
LazarusResources.Add('GOOGLEWEBAPI','wst_meta',[
#0#0#0#20'WST_METADATA_0.2.2.0'#0#0#0#12'googlewebapi'#1#0#0#0#13'IGoogleSear'
+'ch'#2#0#0#0#20'doSpellingSuggestion'#3#0#0#0#3'key'#0#0#0#6'string'#0#0#0#0
+#0#0#0#1#0#0#0#6'phrase'#0#0#0#6'string'#0#0#0#0#0#0#0#1#0#0#0#6'result'#0#0
+#0#6'string'#0#0#0#0#0#0#0#3#0#0#0#14'doGoogleSearch'#11#0#0#0#3'key'#0#0#0#6
+'string'#0#0#0#0#0#0#0#1#0#0#0#1'q'#0#0#0#6'string'#0#0#0#0#0#0#0#1#0#0#0#5
+'start'#0#0#0#7'Integer'#0#0#0#0#0#0#0#1#0#0#0#10'maxResults'#0#0#0#7'Intege'
+'r'#0#0#0#0#0#0#0#1#0#0#0#6'filter'#0#0#0#7'Boolean'#0#0#0#0#0#0#0#1#0#0#0#8
+'restrict'#0#0#0#6'string'#0#0#0#0#0#0#0#1#0#0#0#10'safeSearch'#0#0#0#7'Bool'
+'ean'#0#0#0#0#0#0#0#1#0#0#0#2'lr'#0#0#0#6'string'#0#0#0#0#0#0#0#1#0#0#0#2'ie'
+#0#0#0#6'string'#0#0#0#0#0#0#0#1#0#0#0#2'oe'#0#0#0#6'string'#0#0#0#0#0#0#0#1
+#0#0#0#6'result'#0#0#0#19'TGoogleSearchResult'#0#0#0#0#0#0#0#3
]);

BIN
wst/tags/3.1/tests/google_api/googlewebapi.meta Normal file
View File

Binary file not shown.

157
wst/tags/3.1/tests/google_api/googlewebapi.pas Normal file
View File

@ -0,0 +1,157 @@
Unit googlewebapi;
{$mode objfpc}{$H+}
interface
uses SysUtils, Classes, base_service_intf;
Type
TResultElement = class(TBaseComplexRemotable)
private
FcachedSize: string;
FdirectoryTitle: string;
FhostName: string;
FrelatedInformationPresent: boolean;
Fsnippet: string;
Fsummary: string;
Ftitle: string;
FURL: string;
Published
property summary : string Read Fsummary Write Fsummary;
property URL : string Read FURL Write FURL;
property snippet: string Read Fsnippet Write Fsnippet;
property title : string Read Ftitle Write Ftitle;
property cachedSize : string Read FcachedSize Write FcachedSize;
property relatedInformationPresent : boolean Read FrelatedInformationPresent Write FrelatedInformationPresent;
property hostName : string Read FhostName Write FhostName;
property directoryTitle : string Read FdirectoryTitle Write FdirectoryTitle;
End;
TResultElementArray = class(TBaseObjectArrayRemotable)
private
function GetItem(AIndex: Integer): TResultElement;
Public
class function GetItemClass():TBaseRemotableClass;override;
property Item[AIndex:Integer] : TResultElement Read GetItem;Default;
End;
TDirectoryCategory = class(TBaseComplexRemotable)
private
FfullViewableName: string;
FspecialEncoding: string;
Published
property fullViewableName : string Read FfullViewableName Write FfullViewableName;
property specialEncoding : string Read FspecialEncoding Write FspecialEncoding;
End;
TDirectoryCategoryArray = class(TBaseObjectArrayRemotable)
private
function GetItem(AIndex: Integer): TDirectoryCategory;
Public
class function GetItemClass():TBaseRemotableClass;override;
property Item[AIndex:Integer] : TDirectoryCategory Read GetItem;Default;
End;
TGoogleSearchResult = class(TBaseComplexRemotable)
private
FdirectoryCategories: TDirectoryCategoryArray;
FdocumentFiltering: Boolean;
FendIndex: Integer;
FestimatedTotalResultsCount: Integer;
FestimateIsExact: Boolean;
FresultElements: TResultElementArray;
FsearchComments: string;
FsearchQuery: string;
FsearchTime: Double;
FsearchTips: string;
FstartIndex: Integer;
Public
constructor Create();override;
destructor Destroy();override;
Published
property documentFiltering : Boolean Read FdocumentFiltering Write FdocumentFiltering;
property searchComments :string Read FsearchComments Write FsearchComments;
property estimatedTotalResultsCount: Integer Read FestimatedTotalResultsCount Write FestimatedTotalResultsCount;
property estimateIsExact : Boolean Read FestimateIsExact Write FestimateIsExact;
property searchQuery : string Read FsearchQuery Write FsearchQuery;
property startIndex : Integer Read FstartIndex Write FstartIndex;
property endIndex : Integer Read FendIndex Write FendIndex;
property searchTips :string Read FsearchTips Write FsearchTips;
property searchTime : Double Read FsearchTime Write FsearchTime;
property resultElements : TResultElementArray Read FresultElements Write FresultElements;
property directoryCategories : TDirectoryCategoryArray Read FdirectoryCategories Write FdirectoryCategories;
End;
IGoogleSearch = Interface
['{17FCCC65-4A0B-4D19-93F6-F69EAA719CA3}']
function doSpellingSuggestion(
const key:string;
const phrase:string
):string;
function doGoogleSearch(
Const key : string;
Const q : string;
Const start : Integer;
Const maxResults : Integer;
Const filter : Boolean;
Const restrict : string;
Const safeSearch : Boolean;
Const lr : string;
Const ie : string;
Const oe : string
) : TGoogleSearchResult ;
End;
Implementation
uses base_soap_formatter;
Const
GOOGLE_NAMESPACE = 'urn:GoogleSearch';
{ TResultElementArray }
function TResultElementArray.GetItem(AIndex: Integer): TResultElement;
begin
Result := Inherited GetItem(AIndex) As TResultElement;
end;
class function TResultElementArray.GetItemClass(): TBaseRemotableClass;
begin
Result:= TResultElement;
end;
{ TGoogleSearchResult }
constructor TGoogleSearchResult.Create();
begin
inherited Create();
FresultElements := TResultElementArray.Create();
FdirectoryCategories := TDirectoryCategoryArray.Create();
end;
destructor TGoogleSearchResult.Destroy();
begin
FdirectoryCategories.Free();
FresultElements.Free();
inherited Destroy();
end;
{ TDirectoryCategoryArray }
function TDirectoryCategoryArray.GetItem(AIndex: Integer): TDirectoryCategory;
begin
Result := Inherited GetItem(AIndex) As TDirectoryCategory;
end;
class function TDirectoryCategoryArray.GetItemClass(): TBaseRemotableClass;
begin
Result:= TDirectoryCategory;
end;
Initialization
GetTypeRegistry().Register(GOOGLE_NAMESPACE,TypeInfo(TDirectoryCategory),'DirectoryCategory');
GetTypeRegistry().Register(GOOGLE_NAMESPACE,TypeInfo(TDirectoryCategoryArray),'DirectoryCategoryArray');
GetTypeRegistry().Register(GOOGLE_NAMESPACE,TypeInfo(TResultElement),'ResultElement');
GetTypeRegistry().Register(GOOGLE_NAMESPACE,TypeInfo(TResultElementArray),'ResultElementArray');
GetTypeRegistry().Register(GOOGLE_NAMESPACE,TypeInfo(TGoogleSearchResult),'GoogleSearchResult');
End.

BIN
wst/tags/3.1/tests/google_api/googlewebapi.wst_meta Normal file
View File

Binary file not shown.

138
wst/tags/3.1/tests/google_api/googlewebapi_binder.pas Normal file
View File

@ -0,0 +1,138 @@
{
This unit has been produced by ws_helper.
Input unit name : "googlewebapi".
This unit name : "googlewebapi_binder".
Date : "08/06/2006 23:28".
}
Unit googlewebapi_binder;
{$mode objfpc}{$H+}
Interface
Uses SysUtils, Classes, base_service_intf, server_service_intf, googlewebapi;
Type
TGoogleSearch_ServiceBinder=class(TBaseServiceBinder)
Protected
procedure doSpellingSuggestionHandler(AFormatter:IFormatterResponse);
procedure doGoogleSearchHandler(AFormatter:IFormatterResponse);
Public
constructor Create();
End;
TGoogleSearch_ServiceBinderFactory = class(TInterfacedObject,IItemFactory)
protected
function CreateInstance():IInterface;
End;
procedure Server_service_RegisterGoogleSearchService();
Implementation
uses TypInfo;
{ TGoogleSearch_ServiceBinder implementation }
procedure TGoogleSearch_ServiceBinder.doSpellingSuggestionHandler(AFormatter:IFormatterResponse);
Var
tmpObj : IGoogleSearch;
callCtx : ICallContext;
strPrmName : string;
procName,trgName : string;
key : string;
phrase : string;
returnVal : string;
locTypeInfo : PTypeInfo;
Begin
callCtx := CreateCallContext();
strPrmName := 'key'; AFormatter.Get(TypeInfo(string),strPrmName,key);
strPrmName := 'phrase'; AFormatter.Get(TypeInfo(string),strPrmName,phrase);
tmpObj := Self.GetFactory().CreateInstance() as IGoogleSearch;
returnVal := tmpObj.doSpellingSuggestion(key,phrase);
procName := AFormatter.GetCallProcedureName();
trgName := AFormatter.GetCallTarget();
AFormatter.Clear();
AFormatter.BeginCallResponse(procName,trgName);
AFormatter.Put('return',TypeInfo(string),returnVal);
AFormatter.EndCallResponse();
callCtx := Nil;
End;
procedure TGoogleSearch_ServiceBinder.doGoogleSearchHandler(AFormatter:IFormatterResponse);
Var
tmpObj : IGoogleSearch;
callCtx : ICallContext;
strPrmName : string;
procName,trgName : string;
key : string;
q : string;
start : Integer;
maxResults : Integer;
filter : Boolean;
restrict : string;
safeSearch : Boolean;
lr : string;
ie : string;
oe : string;
returnVal : TGoogleSearchResult;
locTypeInfo : PTypeInfo;
Begin
callCtx := CreateCallContext();
locTypeInfo := TypeInfo(TGoogleSearchResult);
If ( locTypeInfo^.Kind in [tkClass,tkInterface] ) Then
Pointer(returnVal) := Nil;
strPrmName := 'key'; AFormatter.Get(TypeInfo(string),strPrmName,key);
strPrmName := 'q'; AFormatter.Get(TypeInfo(string),strPrmName,q);
strPrmName := 'start'; AFormatter.Get(TypeInfo(Integer),strPrmName,start);
strPrmName := 'maxResults'; AFormatter.Get(TypeInfo(Integer),strPrmName,maxResults);
strPrmName := 'filter'; AFormatter.Get(TypeInfo(Boolean),strPrmName,filter);
strPrmName := 'restrict'; AFormatter.Get(TypeInfo(string),strPrmName,restrict);
strPrmName := 'safeSearch'; AFormatter.Get(TypeInfo(Boolean),strPrmName,safeSearch);
strPrmName := 'lr'; AFormatter.Get(TypeInfo(string),strPrmName,lr);
strPrmName := 'ie'; AFormatter.Get(TypeInfo(string),strPrmName,ie);
strPrmName := 'oe'; AFormatter.Get(TypeInfo(string),strPrmName,oe);
tmpObj := Self.GetFactory().CreateInstance() as IGoogleSearch;
returnVal := tmpObj.doGoogleSearch(key,q,start,maxResults,filter,restrict,safeSearch,lr,ie,oe);
locTypeInfo := TypeInfo(TGoogleSearchResult);
If ( locTypeInfo^.Kind = tkClass ) And Assigned(Pointer(returnVal)) Then
callCtx.AddObject(TObject(returnVal));
procName := AFormatter.GetCallProcedureName();
trgName := AFormatter.GetCallTarget();
AFormatter.Clear();
AFormatter.BeginCallResponse(procName,trgName);
AFormatter.Put('return',TypeInfo(TGoogleSearchResult),returnVal);
AFormatter.EndCallResponse();
callCtx := Nil;
End;
constructor TGoogleSearch_ServiceBinder.Create();
Begin
Inherited Create(GetServiceImplementationRegistry().FindFactory('GoogleSearch'));
RegisterVerbHandler('doSpellingSuggestion',@doSpellingSuggestionHandler);
RegisterVerbHandler('doGoogleSearch',@doGoogleSearchHandler);
End;
{ TGoogleSearch_ServiceBinderFactory }
function TGoogleSearch_ServiceBinderFactory.CreateInstance():IInterface;
Begin
Result := TGoogleSearch_ServiceBinder.Create() as IInterface;
End;
procedure Server_service_RegisterGoogleSearchService();
Begin
GetServerServiceRegistry().Register('GoogleSearch',TGoogleSearch_ServiceBinderFactory.Create() as IItemFactory);
End;
End.

123
wst/tags/3.1/tests/google_api/googlewebapi_proxy.pas Normal file
View File

@ -0,0 +1,123 @@
{
This unit has been produced by ws_helper.
Input unit name : "googlewebapi".
This unit name : "googlewebapi_proxy".
Date : "30/07/2006 21:44".
}
Unit googlewebapi_proxy;
{$mode objfpc}{$H+}
Interface
Uses SysUtils, Classes, TypInfo, base_service_intf, service_intf, googlewebapi;
Type
TGoogleSearch_Proxy=class(TBaseProxy,IGoogleSearch)
Protected
class function GetServiceType() : PTypeInfo;override;
function doSpellingSuggestion(
Const key : string;
Const phrase : string
):string;
function doGoogleSearch(
Const key : string;
Const q : string;
Const start : Integer;
Const maxResults : Integer;
Const filter : Boolean;
Const restrict : string;
Const safeSearch : Boolean;
Const lr : string;
Const ie : string;
Const oe : string
):TGoogleSearchResult;
End;
Implementation
uses LResources, metadata_repository;
{ TGoogleSearch_Proxy implementation }
class function TGoogleSearch_Proxy.GetServiceType() : PTypeInfo;
begin
result := TypeInfo(IGoogleSearch);
end;
function TGoogleSearch_Proxy.doSpellingSuggestion(
Const key : string;
Const phrase : string
):string;
Var
locSerializer : IFormatterClient;
strPrmName : string;
Begin
locSerializer := GetSerializer();
Try
locSerializer.BeginCall('doSpellingSuggestion', GetTarget(),(Self as ICallContext));
locSerializer.Put('key', TypeInfo(string), key);
locSerializer.Put('phrase', TypeInfo(string), phrase);
locSerializer.EndCall();
MakeCall();
locSerializer.BeginCallRead((Self as ICallContext));
strPrmName := 'return';
locSerializer.Get(TypeInfo(string), strPrmName, result);
Finally
locSerializer.Clear();
End;
End;
function TGoogleSearch_Proxy.doGoogleSearch(
Const key : string;
Const q : string;
Const start : Integer;
Const maxResults : Integer;
Const filter : Boolean;
Const restrict : string;
Const safeSearch : Boolean;
Const lr : string;
Const ie : string;
Const oe : string
):TGoogleSearchResult;
Var
locSerializer : IFormatterClient;
strPrmName : string;
Begin
locSerializer := GetSerializer();
Try
locSerializer.BeginCall('doGoogleSearch', GetTarget(),(Self as ICallContext));
locSerializer.Put('key', TypeInfo(string), key);
locSerializer.Put('q', TypeInfo(string), q);
locSerializer.Put('start', TypeInfo(Integer), start);
locSerializer.Put('maxResults', TypeInfo(Integer), maxResults);
locSerializer.Put('filter', TypeInfo(Boolean), filter);
locSerializer.Put('restrict', TypeInfo(string), restrict);
locSerializer.Put('safeSearch', TypeInfo(Boolean), safeSearch);
locSerializer.Put('lr', TypeInfo(string), lr);
locSerializer.Put('ie', TypeInfo(string), ie);
locSerializer.Put('oe', TypeInfo(string), oe);
locSerializer.EndCall();
MakeCall();
locSerializer.BeginCallRead((Self as ICallContext));
Pointer(Result) := Nil;
strPrmName := 'return';
locSerializer.Get(TypeInfo(TGoogleSearchResult), strPrmName, result);
Finally
locSerializer.Clear();
End;
End;
initialization
{$i googlewebapi.lrs}
{$IF DECLARED(Register_googlewebapi_ServiceMetadata)}
Register_googlewebapi_ServiceMetadata();
{$ENDIF}
End.

200
wst/tags/3.1/tests/google_api/googlewebapi_stub.pas Normal file
View File

@ -0,0 +1,200 @@
{
This unit has been produced by ws_helper.
Input unit name : "googlewebapi".
This unit name : "googlewebapi_stub".
Date : "17/05/2006 21:28".
}
Unit googlewebapi_stub;
{$mode objfpc}{$H+}
Interface
Uses SysUtils, Classes, server_service_intf, googlewebapi;
Type
TGoogleSearch_ServiceBinder=class(TBaseServiceBinder)
Protected
procedure doSpellingSuggestionHandler(AFormatter:IFormatterResponse);
procedure doGoogleSearchHandler(AFormatter:IFormatterResponse);
Public
constructor Create();
End;
TGoogleSearchServiceBinderFactory = class(TInterfacedObject,IItemFactory)
protected
function CreateInstance():IInterface;
End;
procedure Server_service_RegisterGoogleSearchService();
Implementation
uses TypInfo, server_service_imputils;
{ TGoogleSearch_ServiceBinder implementation }
procedure TGoogleSearch_ServiceBinder.doSpellingSuggestionHandler(AFormatter:IFormatterResponse);
Var
tmpObj : IGoogleSearch;
callCtx : ICallContext;
strPrmName : string;
procName,trgName : string;
key : string;
phrase : string;
returnVal : string;
locTypeInfo : PTypeInfo;
Begin
locTypeInfo := TypeInfo(string);
If ( locTypeInfo^.Kind in [tkClass,tkObject,tkInterface] ) Then
Pointer(returnVal) := Nil;
locTypeInfo := TypeInfo(string);
If ( locTypeInfo^.Kind in [tkClass,tkObject,tkInterface] ) Then
Pointer(key) := Nil;
locTypeInfo := TypeInfo(string);
If ( locTypeInfo^.Kind in [tkClass,tkObject,tkInterface] ) Then
Pointer(phrase) := Nil;
strPrmName := 'key'; AFormatter.Get(TypeInfo(string),strPrmName,key);
locTypeInfo := TypeInfo(string);
If ( locTypeInfo^.Kind = tkClass ) And Assigned(Pointer(key)) Then
callCtx.AddObject(TObject(key));
strPrmName := 'phrase'; AFormatter.Get(TypeInfo(string),strPrmName,phrase);
locTypeInfo := TypeInfo(string);
If ( locTypeInfo^.Kind = tkClass ) And Assigned(Pointer(phrase)) Then
callCtx.AddObject(TObject(phrase));
tmpObj := Self.GetFactory().CreateInstance() as IGoogleSearch;
returnVal := tmpObj.doSpellingSuggestion(key,phrase);
locTypeInfo := TypeInfo(string);
If ( locTypeInfo^.Kind = tkClass ) And Assigned(Pointer(returnVal)) Then
callCtx.AddObject(TObject(returnVal));
procName := AFormatter.GetCallProcedureName();
trgName := AFormatter.GetCallTarget();
AFormatter.Clear();
AFormatter.BeginCallResponse(procName,trgName);
AFormatter.Put('return',TypeInfo(string),returnVal);
AFormatter.EndCallResponse();
End;
procedure TGoogleSearch_ServiceBinder.doGoogleSearchHandler(AFormatter:IFormatterResponse);
Var
tmpObj : IGoogleSearch;
callCtx : ICallContext;
strPrmName : string;
procName,trgName : string;
key : string;
q : string;
start : Integer;
maxResults : Integer;
filter : Boolean;
restrict : string;
safeSearch : Boolean;
lr : string;
ie : string;
oe : string;
returnVal : TGoogleSearchResult;
locTypeInfo : PTypeInfo;
Begin
locTypeInfo := TypeInfo(TGoogleSearchResult);
If ( locTypeInfo^.Kind in [tkClass,tkObject,tkInterface] ) Then
Pointer(returnVal) := Nil;
locTypeInfo := TypeInfo(string);
If ( locTypeInfo^.Kind in [tkClass,tkObject,tkInterface] ) Then
Pointer(key) := Nil;
locTypeInfo := TypeInfo(string);
If ( locTypeInfo^.Kind in [tkClass,tkObject,tkInterface] ) Then
Pointer(q) := Nil;
locTypeInfo := TypeInfo(Integer);
If ( locTypeInfo^.Kind in [tkClass,tkObject,tkInterface] ) Then
Pointer(start) := Nil;
locTypeInfo := TypeInfo(Integer);
If ( locTypeInfo^.Kind in [tkClass,tkObject,tkInterface] ) Then
Pointer(maxResults) := Nil;
locTypeInfo := TypeInfo(Boolean);
If ( locTypeInfo^.Kind in [tkClass,tkObject,tkInterface] ) Then
Pointer(filter) := Nil;
locTypeInfo := TypeInfo(string);
If ( locTypeInfo^.Kind in [tkClass,tkObject,tkInterface] ) Then
Pointer(restrict) := Nil;
locTypeInfo := TypeInfo(Boolean);
If ( locTypeInfo^.Kind in [tkClass,tkObject,tkInterface] ) Then
Pointer(safeSearch) := Nil;
locTypeInfo := TypeInfo(string);
If ( locTypeInfo^.Kind in [tkClass,tkObject,tkInterface] ) Then
Pointer(lr) := Nil;
locTypeInfo := TypeInfo(string);
If ( locTypeInfo^.Kind in [tkClass,tkObject,tkInterface] ) Then
Pointer(ie) := Nil;
locTypeInfo := TypeInfo(string);
If ( locTypeInfo^.Kind in [tkClass,tkObject,tkInterface] ) Then
Pointer(oe) := Nil;
strPrmName := 'key'; AFormatter.Get(TypeInfo(string),strPrmName,key);
locTypeInfo := TypeInfo(string);
If ( locTypeInfo^.Kind = tkClass ) And Assigned(Pointer(key)) Then
callCtx.AddObject(TObject(key));
strPrmName := 'q'; AFormatter.Get(TypeInfo(string),strPrmName,q);
locTypeInfo := TypeInfo(string);
If ( locTypeInfo^.Kind = tkClass ) And Assigned(Pointer(q)) Then
callCtx.AddObject(TObject(q));
strPrmName := 'start'; AFormatter.Get(TypeInfo(Integer),strPrmName,start);
locTypeInfo := TypeInfo(Integer);
If ( locTypeInfo^.Kind = tkClass ) And Assigned(Pointer(start)) Then
callCtx.AddObject(TObject(start));
strPrmName := 'maxResults'; AFormatter.Get(TypeInfo(Integer),strPrmName,maxResults);
locTypeInfo := TypeInfo(Integer);
If ( locTypeInfo^.Kind = tkClass ) And Assigned(Pointer(maxResults)) Then
callCtx.AddObject(TObject(maxResults));
strPrmName := 'filter'; AFormatter.Get(TypeInfo(Boolean),strPrmName,filter);
locTypeInfo := TypeInfo(Boolean);
If ( locTypeInfo^.Kind = tkClass ) And Assigned(Pointer(filter)) Then
callCtx.AddObject(TObject(filter));
strPrmName := 'restrict'; AFormatter.Get(TypeInfo(string),strPrmName,restrict);
locTypeInfo := TypeInfo(string);
If ( locTypeInfo^.Kind = tkClass ) And Assigned(Pointer(restrict)) Then
callCtx.AddObject(TObject(restrict));
strPrmName := 'safeSearch'; AFormatter.Get(TypeInfo(Boolean),strPrmName,safeSearch);
locTypeInfo := TypeInfo(Boolean);
If ( locTypeInfo^.Kind = tkClass ) And Assigned(Pointer(safeSearch)) Then
callCtx.AddObject(TObject(safeSearch));
strPrmName := 'lr'; AFormatter.Get(TypeInfo(string),strPrmName,lr);
locTypeInfo := TypeInfo(string);
If ( locTypeInfo^.Kind = tkClass ) And Assigned(Pointer(lr)) Then
callCtx.AddObject(TObject(lr));
strPrmName := 'ie'; AFormatter.Get(TypeInfo(string),strPrmName,ie);
locTypeInfo := TypeInfo(string);
If ( locTypeInfo^.Kind = tkClass ) And Assigned(Pointer(ie)) Then
callCtx.AddObject(TObject(ie));
strPrmName := 'oe'; AFormatter.Get(TypeInfo(string),strPrmName,oe);
locTypeInfo := TypeInfo(string);
If ( locTypeInfo^.Kind = tkClass ) And Assigned(Pointer(oe)) Then
callCtx.AddObject(TObject(oe));
tmpObj := Self.GetFactory().CreateInstance() as IGoogleSearch;
returnVal := tmpObj.doGoogleSearch(key,q,start,maxResults,filter,restrict,safeSearch,lr,ie,oe);
locTypeInfo := TypeInfo(TGoogleSearchResult);
If ( locTypeInfo^.Kind = tkClass ) And Assigned(Pointer(returnVal)) Then
callCtx.AddObject(TObject(returnVal));
procName := AFormatter.GetCallProcedureName();
trgName := AFormatter.GetCallTarget();
AFormatter.Clear();
AFormatter.BeginCallResponse(procName,trgName);
AFormatter.Put('return',TypeInfo(TGoogleSearchResult),returnVal);
AFormatter.EndCallResponse();
End;
{ TGoogleSearchServiceBinderFactory }
function TGoogleSearchServiceBinderFactory.CreateInstance():IInterface;
Begin
Result := TGoogleSearch_ServiceBinder.Create() as IInterface;
End;
procedure Server_service_RegisterGoogleSearchService();
Begin
GetServerServiceRegistry().Register('GoogleSearch',TGoogleSearchServiceBinderFactory.Create() as IItemFactory);
End;

391
wst/tags/3.1/tests/google_api/test_google_api.lpi Normal file
View File

@ -0,0 +1,391 @@
<?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=""/>
<ActiveEditorIndexAtStart Value="1"/>
</General>
<PublishOptions>
<Version Value="2"/>
<DestinationDirectory Value="$(TestDir)\publishedproject\"/>
<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="41">
<Unit0>
<Filename Value="test_google_api.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="test_google_api"/>
<CursorPos X="22" Y="15"/>
<TopLine Value="1"/>
<EditorIndex Value="1"/>
<UsageCount Value="148"/>
<Loaded Value="True"/>
</Unit0>
<Unit1>
<Filename Value="googlewebapi.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="googlewebapi"/>
<CursorPos X="47" Y="85"/>
<TopLine Value="73"/>
<EditorIndex Value="0"/>
<UsageCount Value="148"/>
<Loaded Value="True"/>
</Unit1>
<Unit2>
<Filename Value="googlewebapiimpunit.pas"/>
<UnitName Value="googlewebapiimpunit"/>
<CursorPos X="1" Y="1"/>
<TopLine Value="1"/>
<UsageCount Value="98"/>
</Unit2>
<Unit3>
<Filename Value="home\inoussa\Projets\Laz\http_call_handler.pas"/>
<UnitName Value="http_call_handler"/>
<CursorPos X="22" Y="21"/>
<TopLine Value="75"/>
<UsageCount Value="18"/>
</Unit3>
<Unit4>
<Filename Value="home\inoussa\Projets\Laz\formaterintf.pas"/>
<UnitName Value="formaterintf"/>
<CursorPos X="69" Y="56"/>
<TopLine Value="44"/>
<UsageCount Value="18"/>
</Unit4>
<Unit5>
<Filename Value="home\inoussa\Projets\Laz\baseobject.pas"/>
<UnitName Value="baseobject"/>
<CursorPos X="37" Y="20"/>
<TopLine Value="1"/>
<UsageCount Value="8"/>
</Unit5>
<Unit6>
<Filename Value="home\inoussa\Projets\Laz\xml_formater.pas"/>
<UnitName Value="xml_formater"/>
<CursorPos X="53" Y="733"/>
<TopLine Value="719"/>
<UsageCount Value="8"/>
</Unit6>
<Unit7>
<Filename Value="home\inoussa\Projets\Laz\ws_helper\parserutils.pas"/>
<UsageCount Value="8"/>
<SyntaxHighlighter Value="Text"/>
</Unit7>
<Unit8>
<Filename Value="home\inoussa\Projets\Laz\type_registry.pas"/>
<UnitName Value="type_registry"/>
<CursorPos X="1" Y="1"/>
<TopLine Value="45"/>
<UsageCount Value="8"/>
</Unit8>
<Unit9>
<Filename Value="home\inoussa\Projets\Laz\basestubimp.pas"/>
<UnitName Value="basestubimp"/>
<CursorPos X="1" Y="1"/>
<TopLine Value="107"/>
<UsageCount Value="8"/>
</Unit9>
<Unit10>
<Filename Value="usr\share\fpcsrc\rtl\objpas\typinfo.pp"/>
<UnitName Value="typinfo"/>
<CursorPos X="11" Y="220"/>
<TopLine Value="201"/>
<UsageCount Value="9"/>
</Unit10>
<Unit11>
<Filename Value="home\inoussa\Projets\Laz\v0.2\service_intf.pas"/>
<UnitName Value="service_intf"/>
<CursorPos X="1" Y="579"/>
<TopLine Value="567"/>
<UsageCount Value="1"/>
</Unit11>
<Unit12>
<Filename Value="home\inoussa\Projets\Laz\v0.2\soap_imp.pas"/>
<UnitName Value="soap_imp"/>
<CursorPos X="1" Y="701"/>
<TopLine Value="689"/>
<UsageCount Value="1"/>
</Unit12>
<Unit13>
<Filename Value="home\inoussa\Projets\Laz\v0.2\imp_utils.pas"/>
<UnitName Value="imp_utils"/>
<CursorPos X="1" Y="83"/>
<TopLine Value="71"/>
<UsageCount Value="1"/>
</Unit13>
<Unit14>
<Filename Value="home\inoussa\Projets\Laz\v0.2\indy_http_protocol.pas"/>
<UnitName Value="indy_http_protocol"/>
<CursorPos X="1" Y="50"/>
<TopLine Value="38"/>
<UsageCount Value="1"/>
</Unit14>
<Unit15>
<Filename Value="home\inoussa\Progs\indy-10.2.0.1\fpc\Protocols\IdHTTP.pas"/>
<UnitName Value="IdHTTP"/>
<CursorPos X="45" Y="1517"/>
<TopLine Value="1509"/>
<UsageCount Value="10"/>
</Unit15>
<Unit16>
<Filename Value="..\..\indy_http_protocol.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="indy_http_protocol"/>
<CursorPos X="45" Y="166"/>
<TopLine Value="156"/>
<UsageCount Value="63"/>
</Unit16>
<Unit17>
<Filename Value="..\..\ics_http_protocol.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="ics_http_protocol"/>
<CursorPos X="3" Y="17"/>
<TopLine Value="1"/>
<EditorIndex Value="2"/>
<UsageCount Value="125"/>
<Loaded Value="True"/>
</Unit17>
<Unit18>
<Filename Value="D:\Lazarus\others_package\ics\latest_distr\Delphi\Vc32\HttpProt.pas"/>
<UnitName Value="HttpProt"/>
<CursorPos X="65" Y="468"/>
<TopLine Value="454"/>
<UsageCount Value="9"/>
</Unit18>
<Unit19>
<Filename Value="..\..\soap_imp.pas"/>
<UnitName Value="soap_imp"/>
<CursorPos X="46" Y="42"/>
<TopLine Value="27"/>
<UsageCount Value="30"/>
</Unit19>
<Unit20>
<Filename Value="..\..\service_intf.pas"/>
<UnitName Value="service_intf"/>
<CursorPos X="3" Y="225"/>
<TopLine Value="212"/>
<UsageCount Value="55"/>
</Unit20>
<Unit21>
<Filename Value="D:\Lazarus\fpcsrc\fcl\xml\dom.pp"/>
<UnitName Value="DOM"/>
<CursorPos X="14" Y="278"/>
<TopLine Value="261"/>
<UsageCount Value="6"/>
</Unit21>
<Unit22>
<Filename Value="D:\Lazarus\fpcsrc\fcl\inc\contnrs.pp"/>
<UnitName Value="contnrs"/>
<CursorPos X="3" Y="745"/>
<TopLine Value="743"/>
<UsageCount Value="3"/>
</Unit22>
<Unit23>
<Filename Value="D:\Lazarus\fpcsrc\rtl\objpas\typinfo.pp"/>
<UnitName Value="typinfo"/>
<CursorPos X="20" Y="40"/>
<TopLine Value="87"/>
<UsageCount Value="3"/>
</Unit23>
<Unit24>
<Filename Value="D:\Lazarus\fpcsrc\rtl\win32\system.pp"/>
<UnitName Value="System"/>
<CursorPos X="6" Y="16"/>
<TopLine Value="1"/>
<UsageCount Value="2"/>
</Unit24>
<Unit25>
<Filename Value="xml_serializer.pas"/>
<UnitName Value="xml_serializer"/>
<CursorPos X="1" Y="80"/>
<TopLine Value="36"/>
<UsageCount Value="31"/>
</Unit25>
<Unit26>
<Filename Value="D:\Lazarus\fpcsrc\rtl\inc\systemh.inc"/>
<CursorPos X="3" Y="215"/>
<TopLine Value="201"/>
<UsageCount Value="5"/>
</Unit26>
<Unit27>
<Filename Value="..\..\soap_formatter.pas"/>
<UnitName Value="soap_formatter"/>
<CursorPos X="3" Y="248"/>
<TopLine Value="227"/>
<UsageCount Value="47"/>
</Unit27>
<Unit28>
<Filename Value="..\..\base_soap_formatter.pas"/>
<UnitName Value="base_soap_formatter"/>
<CursorPos X="31" Y="1268"/>
<TopLine Value="1253"/>
<UsageCount Value="47"/>
</Unit28>
<Unit29>
<Filename Value="..\..\base_service_intf.pas"/>
<UnitName Value="base_service_intf"/>
<CursorPos X="32" Y="1595"/>
<TopLine Value="1593"/>
<UsageCount Value="31"/>
</Unit29>
<Unit30>
<Filename Value="D:\lazarusClean\fpcsrc\rtl\objpas\objpas.pp"/>
<UnitName Value="objpas"/>
<CursorPos X="8" Y="28"/>
<TopLine Value="1"/>
<UsageCount Value="6"/>
</Unit30>
<Unit31>
<Filename Value="D:\lazarusClean\fpcsrc\rtl\inc\objpash.inc"/>
<CursorPos X="30" Y="206"/>
<TopLine Value="190"/>
<UsageCount Value="6"/>
</Unit31>
<Unit32>
<Filename Value="D:\lazarusClean\fpcsrc\rtl\win32\system.pp"/>
<UnitName Value="System"/>
<CursorPos X="4" Y="506"/>
<TopLine Value="231"/>
<UsageCount Value="6"/>
</Unit32>
<Unit33>
<Filename Value="googlewebapi_proxy.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="googlewebapi_proxy"/>
<CursorPos X="10" Y="104"/>
<TopLine Value="90"/>
<UsageCount Value="66"/>
</Unit33>
<Unit34>
<Filename Value="..\..\..\v0.2\base_service_intf.pas"/>
<UnitName Value="base_service_intf"/>
<CursorPos X="33" Y="291"/>
<TopLine Value="277"/>
<UsageCount Value="6"/>
</Unit34>
<Unit35>
<Filename Value="D:\lazarusClean\fpcsrc\fcl\xml\dom.pp"/>
<UnitName Value="DOM"/>
<CursorPos X="3" Y="1174"/>
<TopLine Value="1170"/>
<UsageCount Value="8"/>
</Unit35>
<Unit36>
<Filename Value="..\..\synapse_http_protocol.pas"/>
<UnitName Value="synapse_http_protocol"/>
<CursorPos X="3" Y="154"/>
<TopLine Value="145"/>
<UsageCount Value="11"/>
</Unit36>
<Unit37>
<Filename Value="D:\Lazarus\others_package\synapse\httpsend.pas"/>
<UnitName Value="httpsend"/>
<CursorPos X="15" Y="108"/>
<TopLine Value="96"/>
<UsageCount Value="9"/>
</Unit37>
<Unit38>
<Filename Value="D:\Lazarus\others_package\indy\indy-10.2.0.1\fpc\Protocols\IdHTTP.pas"/>
<UnitName Value="IdHTTP"/>
<CursorPos X="49" Y="343"/>
<TopLine Value="331"/>
<UsageCount Value="10"/>
</Unit38>
<Unit39>
<Filename Value="D:\Lazarus\others_package\indy\indy-10.2.0.1\fpc\Protocols\IdHTTPHeaderInfo.pas"/>
<UnitName Value="IdHTTPHeaderInfo"/>
<CursorPos X="70" Y="13"/>
<TopLine Value="1"/>
<UsageCount Value="9"/>
</Unit39>
<Unit40>
<Filename Value="D:\Lazarus\others_package\indy\indy-10.2.0.1\fpc\Protocols\IdHeaderList.pas"/>
<UnitName Value="IdHeaderList"/>
<CursorPos X="22" Y="157"/>
<TopLine Value="145"/>
<UsageCount Value="10"/>
</Unit40>
</Units>
<JumpHistory Count="0" HistoryIndex="-1"/>
</ProjectOptions>
<CompilerOptions>
<Version Value="5"/>
<PathDelim Value="\"/>
<SearchPaths>
<OtherUnitFiles Value="D:\LazarusClean\others_package\ics\latest_distr\Delphi\Vc32\;..\..\;D:\LazarusClean\others_package\synapse\"/>
<UnitOutputDirectory Value="obj"/>
<SrcPath Value="..\..\"/>
</SearchPaths>
<Parsing>
<SyntaxOptions>
<IncludeAssertionCode Value="True"/>
</SyntaxOptions>
</Parsing>
<CodeGeneration>
<Generate Value="Faster"/>
</CodeGeneration>
<Other>
<CustomOptions Value="-Xi"/>
<CompilerPath Value="$(CompPath)"/>
</Other>
</CompilerOptions>
<Debugging>
<BreakPoints Count="7">
<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="home\inoussa\Projets\Laz\v0.2\indy_http_protocol.pas"/>
<Line Value="69"/>
</Item5>
<Item6>
<Source Value="home\inoussa\Projets\Laz\v0.2\service_intf.pas"/>
<Line Value="567"/>
</Item6>
<Item7>
<Source Value="home\inoussa\Projets\Laz\v0.2\imp_utils.pas"/>
<Line Value="83"/>
</Item7>
</BreakPoints>
<Watches Count="1">
<Item1>
<Expression Value="ASource.Memory^"/>
</Item1>
</Watches>
</Debugging>
</CONFIG>

98
wst/tags/3.1/tests/google_api/test_google_api.pas Normal file
View File

@ -0,0 +1,98 @@
program test_google_api;
{$mode objfpc}{$H+}
uses
{$IFDEF UNIX}{$IFDEF UseCThreads}
cthreads,
{$ENDIF}{$ENDIF}
Classes, SysUtils,
base_service_intf, service_intf, soap_formatter,
//indy_http_protocol,
ics_http_protocol,
synapse_http_protocol,
googlewebapi, googlewebapi_proxy;
Const
sADRESS = 'http:Address=http://api.google.com/search/beta2';
sTARGET = 'urn:GoogleSearch';
sKEY = '0w9pU3tQFHJyjRUP/bKgv2qwCoXf5pop';
sSERVICE_PROTOCOL = 'SOAP';
Var
tmpObj : IGoogleSearch;
qryRes : TGoogleSearchResult;
strBuffer : string;
i , c: Integer;
resElt : TResultElement;
resDir : TDirectoryCategory;
begin
//ICS_RegisterHTTP_Transport();
SYNAPSE_RegisterHTTP_Transport();
//INDY_RegisterHTTP_Transport();
WriteLn();
WriteLn('Enter phrase to spell :');
ReadLn(strBuffer);
tmpObj := TGoogleSearch_Proxy.Create(sTARGET,sSERVICE_PROTOCOL,sADRESS);
Try
strBuffer := tmpObj.doSpellingSuggestion(sKEY,strBuffer);
WriteLn('google spell >>> ',strBuffer);
Except
On E : Exception Do
WriteLn(E.Message);
End;
WriteLn();
WriteLn('Enter phrase to search :');
ReadLn(strBuffer);
Try
qryRes := tmpObj.doGoogleSearch(sKEY,strBuffer,0,10,True,'',False,'','latin1','latin1');
Try
WriteLn('---------------------------------------');
WriteLn('google Search >>');
WriteLn('documentFiltering = ',qryRes.documentFiltering);
WriteLn('startIndex = ',qryRes.startIndex);
WriteLn('endIndex = ',qryRes.endIndex);
WriteLn('estimatedTotalResultsCount = ',qryRes.estimatedTotalResultsCount);
WriteLn('estimateIsExact = ',qryRes.estimateIsExact);
WriteLn('searchComments = ',qryRes.searchComments);
WriteLn('searchQuery = ',qryRes.searchQuery);
WriteLn('searchTime = ',qryRes.searchTime);
WriteLn('searchTips = ',qryRes.searchTips);
WriteLn('-------------------------------------------');
WriteLn('directoryCategories >>');
WriteLn(' Length = ',qryRes.directoryCategories.Length);
c := qryRes.directoryCategories.Length;
For i := 0 To Pred(c) Do Begin
resDir := qryRes.directoryCategories[i];
WriteLn('');
WriteLn('Item[',i,'] >>');
WriteLn(' fullViewableName = ',resDir.fullViewableName);
WriteLn(' specialEncoding = ',resDir.specialEncoding);
End;
WriteLn('-------------------------------------------');
WriteLn('resultElements >>');
WriteLn(' Length = ',qryRes.resultElements.Length);
c := qryRes.resultElements.Length;
For i := 0 To Pred(c) Do Begin
resElt := qryRes.resultElements[i];
WriteLn('');
WriteLn('Item[',i,'] >>');
WriteLn(' cachedSize = ',resElt.cachedSize);
WriteLn(' directoryTitle = ',resElt.directoryTitle);
WriteLn(' hostName = ',resElt.hostName);
WriteLn(' relatedInformationPresent = ',resElt.relatedInformationPresent);
WriteLn(' snippet = ',resElt.snippet);
WriteLn(' summary = ',resElt.summary);
WriteLn(' title = ',resElt.title);
WriteLn(' URL = ',resElt.URL);
End;
Finally
qryRes.Free();
End;
Except
On E : Exception Do
WriteLn(E.Message);
End;
ReadLn();
end.

301
wst/tags/3.1/tests/http_server/app_object.pas Normal file
View File

@ -0,0 +1,301 @@
{
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,
calculator, calculator_binder, calculator_imp,
metadata_service, metadata_service_binder, metadata_service_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;
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();
RegisterCalculatorImplementationFactory();
Server_service_RegisterCalculatorService();
Server_service_RegisterWSTMetadataServiceService();
RegisterWSTMetadataServiceImplementationFactory();
end.

709
wst/tags/3.1/tests/http_server/wst_http_server.lpi Normal file
View File

@ -0,0 +1,709 @@
<?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="5"/>
</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="indylaz"/>
</Item1>
</RequiredPackages>
<Units Count="73">
<Unit0>
<Filename Value="wst_http_server.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="wst_http_server"/>
<CursorPos X="30" Y="29"/>
<TopLine Value="19"/>
<EditorIndex Value="4"/>
<UsageCount Value="202"/>
<Loaded Value="True"/>
</Unit0>
<Unit1>
<Filename Value="app_object.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="app_object"/>
<CursorPos X="1" Y="258"/>
<TopLine Value="237"/>
<EditorIndex Value="5"/>
<UsageCount Value="202"/>
<Loaded Value="True"/>
</Unit1>
<Unit2>
<Filename Value="D:\Lazarus\others_package\indy\indy-10.2.0.1\fpc\Core\IdSocketHandle.pas"/>
<UnitName Value="IdSocketHandle"/>
<CursorPos X="9" Y="126"/>
<TopLine Value="118"/>
<UsageCount Value="7"/>
</Unit2>
<Unit3>
<Filename Value="D:\Lazarus\others_package\indy\indy-10.2.0.1\fpc\System\IdComponent.pas"/>
<UnitName Value="IdComponent"/>
<CursorPos X="27" Y="64"/>
<TopLine Value="50"/>
<UsageCount Value="7"/>
</Unit3>
<Unit4>
<Filename Value="D:\Lazarus\others_package\indy\indy-10.2.0.1\fpc\System\IdCompilerDefines.inc"/>
<CursorPos X="1" Y="1"/>
<TopLine Value="1"/>
<UsageCount Value="7"/>
</Unit4>
<Unit5>
<Filename Value="D:\Lazarus\others_package\indy\indy-10.2.0.1\fpc\Core\IdContext.pas"/>
<UnitName Value="IdContext"/>
<CursorPos X="3" Y="81"/>
<TopLine Value="70"/>
<UsageCount Value="5"/>
</Unit5>
<Unit6>
<Filename Value="D:\Lazarus\others_package\indy\indy-10.2.0.1\fpc\Protocols\IdCustomHTTPServer.pas"/>
<UnitName Value="IdCustomHTTPServer"/>
<CursorPos X="16" Y="167"/>
<TopLine Value="148"/>
<UsageCount Value="1"/>
</Unit6>
<Unit7>
<Filename Value="D:\Lazarus\others_package\indy\indy-10.2.0.1\fpc\Protocols\IdHTTPHeaderInfo.pas"/>
<UnitName Value="IdHTTPHeaderInfo"/>
<CursorPos X="25" Y="127"/>
<TopLine Value="99"/>
<UsageCount Value="1"/>
</Unit7>
<Unit8>
<Filename Value="D:\Lazarus\others_package\indy\indy-10.2.0.1\fpc\System\IdGlobal.pas"/>
<UnitName Value="IdGlobal"/>
<CursorPos X="1" Y="1"/>
<TopLine Value="1"/>
<UsageCount Value="7"/>
</Unit8>
<Unit9>
<Filename Value="D:\Lazarus\others_package\indy\indy-10.2.0.1\fpc\System\IdBaseComponent.pas"/>
<UnitName Value="IdBaseComponent"/>
<CursorPos X="1" Y="1"/>
<TopLine Value="69"/>
<UsageCount Value="7"/>
</Unit9>
<Unit10>
<Filename Value="D:\Lazarus\fpcsrc\rtl\win32\classes.pp"/>
<UnitName Value="Classes"/>
<CursorPos X="14" Y="35"/>
<TopLine Value="19"/>
<UsageCount Value="5"/>
</Unit10>
<Unit11>
<Filename Value="D:\Lazarus\fpcsrc\rtl\objpas\classes\classesh.inc"/>
<CursorPos X="14" Y="566"/>
<TopLine Value="554"/>
<UsageCount Value="5"/>
</Unit11>
<Unit12>
<Filename Value="D:\Lazarus\fpcsrc\rtl\objpas\classes\streams.inc"/>
<CursorPos X="7" Y="143"/>
<TopLine Value="118"/>
<UsageCount Value="5"/>
</Unit12>
<Unit13>
<Filename Value="D:\Lazarus\others_package\indy\indy-10.2.0.1\fpc\Protocols\IdResourceStringsProtocols.pas"/>
<UnitName Value="IdResourceStringsProtocols"/>
<CursorPos X="3" Y="900"/>
<TopLine Value="889"/>
<UsageCount Value="5"/>
</Unit13>
<Unit14>
<Filename Value="D:\Lazarus\others_package\indy\indy-10.2.0.1\fpc\Protocols\IdURI.pas"/>
<UnitName Value="IdURI"/>
<CursorPos X="1" Y="1"/>
<TopLine Value="37"/>
<UsageCount Value="5"/>
</Unit14>
<Unit15>
<Filename Value="D:\Lazarus\fpcsrc\rtl\inc\wstringh.inc"/>
<CursorPos X="11" Y="30"/>
<TopLine Value="19"/>
<UsageCount Value="5"/>
</Unit15>
<Unit16>
<Filename Value="D:\Lazarus\fpcsrc\rtl\inc\wstrings.inc"/>
<CursorPos X="3" Y="938"/>
<TopLine Value="934"/>
<UsageCount Value="5"/>
</Unit16>
<Unit17>
<Filename Value="..\..\server_service_intf.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="server_service_intf"/>
<CursorPos X="56" Y="332"/>
<TopLine Value="319"/>
<EditorIndex Value="1"/>
<UsageCount Value="200"/>
<Bookmarks Count="2">
<Item0 X="28" Y="60" ID="0"/>
<Item1 X="21" Y="169" ID="2"/>
</Bookmarks>
<Loaded Value="True"/>
</Unit17>
<Unit18>
<Filename Value="..\..\base_service_intf.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="base_service_intf"/>
<CursorPos X="75" Y="817"/>
<TopLine Value="811"/>
<EditorIndex Value="2"/>
<UsageCount Value="201"/>
<Bookmarks Count="1">
<Item0 X="52" Y="707" ID="1"/>
</Bookmarks>
<Loaded Value="True"/>
</Unit18>
<Unit19>
<Filename Value="..\..\server_service_imputils.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="server_service_imputils"/>
<CursorPos X="1" Y="50"/>
<TopLine Value="61"/>
<UsageCount Value="201"/>
</Unit19>
<Unit20>
<Filename Value="..\..\server_binary_formatter.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="server_binary_formatter"/>
<CursorPos X="44" Y="97"/>
<TopLine Value="85"/>
<UsageCount Value="200"/>
</Unit20>
<Unit21>
<Filename Value="..\..\server_service_soap.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="server_service_soap"/>
<CursorPos X="3" Y="160"/>
<TopLine Value="113"/>
<UsageCount Value="200"/>
</Unit21>
<Unit22>
<Filename Value="..\tcp_server\calculator\calculator.pas"/>
<UnitName Value="calculator"/>
<CursorPos X="5" Y="84"/>
<TopLine Value="65"/>
<UsageCount Value="165"/>
</Unit22>
<Unit23>
<Filename Value="..\tcp_server\calculator\srv\calculator_imp.pas"/>
<UnitName Value="calculator_imp"/>
<CursorPos X="24" Y="18"/>
<TopLine Value="14"/>
<UsageCount Value="126"/>
</Unit23>
<Unit24>
<Filename Value="..\tcp_server\calculator\srv\calculator_binder.pas"/>
<UnitName Value="calculator_binder"/>
<CursorPos X="1" Y="1"/>
<TopLine Value="1"/>
<UsageCount Value="165"/>
</Unit24>
<Unit25>
<Filename Value="..\..\base_binary_formatter.pas"/>
<UnitName Value="base_binary_formatter"/>
<CursorPos X="1" Y="925"/>
<TopLine Value="913"/>
<UsageCount Value="13"/>
</Unit25>
<Unit26>
<Filename Value="D:\Lazarus\lcl\lresources.pp"/>
<UnitName Value="LResources"/>
<CursorPos X="25" Y="272"/>
<TopLine Value="258"/>
<UsageCount Value="5"/>
</Unit26>
<Unit27>
<Filename Value="..\..\metadata_wsdl.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="metadata_wsdl"/>
<CursorPos X="39" Y="549"/>
<TopLine Value="537"/>
<EditorIndex Value="7"/>
<UsageCount Value="201"/>
<Bookmarks Count="1">
<Item0 X="23" Y="440" ID="3"/>
</Bookmarks>
<Loaded Value="True"/>
</Unit27>
<Unit28>
<Filename Value="..\..\metadata_repository.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="metadata_repository"/>
<CursorPos X="31" Y="629"/>
<TopLine Value="72"/>
<UsageCount Value="201"/>
</Unit28>
<Unit29>
<Filename Value="D:\Lazarus\fpcsrc\fcl\xml\dom.pp"/>
<UnitName Value="DOM"/>
<CursorPos X="15" Y="475"/>
<TopLine Value="472"/>
<UsageCount Value="7"/>
</Unit29>
<Unit30>
<Filename Value="D:\Lazarus\fpcsrc\fcl\xml\xmlwrite.pp"/>
<UnitName Value="XMLWrite"/>
<CursorPos X="15" Y="74"/>
<TopLine Value="50"/>
<UsageCount Value="6"/>
</Unit30>
<Unit31>
<Filename Value="D:\Lazarus\fpcsrc\rtl\objpas\typinfo.pp"/>
<UnitName Value="typinfo"/>
<CursorPos X="7" Y="73"/>
<TopLine Value="96"/>
<UsageCount Value="12"/>
</Unit31>
<Unit32>
<Filename Value="..\..\base_soap_formatter.pas"/>
<UnitName Value="base_soap_formatter"/>
<CursorPos X="1" Y="249"/>
<TopLine Value="235"/>
<EditorIndex Value="0"/>
<UsageCount Value="59"/>
<Loaded Value="True"/>
</Unit32>
<Unit33>
<Filename Value="D:\Lazarus\fpcsrc\rtl\inc\objpash.inc"/>
<CursorPos X="40" Y="165"/>
<TopLine Value="279"/>
<UsageCount Value="5"/>
</Unit33>
<Unit34>
<Filename Value="D:\Lazarus\fpcsrc\rtl\inc\objpas.inc"/>
<CursorPos X="11" Y="351"/>
<TopLine Value="345"/>
<UsageCount Value="3"/>
</Unit34>
<Unit35>
<Filename Value="D:\Lazarus\others_package\indy\indy-10.2.0.1\fpc\Protocols\IdHTTPServer.pas"/>
<UnitName Value="IdHTTPServer"/>
<CursorPos X="1" Y="1"/>
<TopLine Value="1"/>
<UsageCount Value="9"/>
</Unit35>
<Unit36>
<Filename Value="D:\lazarusClean\lcl\lresources.pp"/>
<UnitName Value="LResources"/>
<CursorPos X="3" Y="934"/>
<TopLine Value="931"/>
<UsageCount Value="5"/>
</Unit36>
<Unit37>
<Filename Value="D:\Lazarus\others_package\indy\indy-10.2.0.1\fpc\System\IdSysVCL.pas"/>
<UnitName Value="IdSysVCL"/>
<CursorPos X="1" Y="176"/>
<TopLine Value="165"/>
<UsageCount Value="2"/>
</Unit37>
<Unit38>
<Filename Value="D:\Lazarus\others_package\indy\indy-10.2.0.1\fpc\System\IdStackBSDBase.pas"/>
<UnitName Value="IdStackBSDBase"/>
<CursorPos X="35" Y="456"/>
<TopLine Value="446"/>
<UsageCount Value="2"/>
</Unit38>
<Unit39>
<Filename Value="..\tcp_server\calculator\srv\calculator.lrs"/>
<CursorPos X="1" Y="1"/>
<TopLine Value="1"/>
<UsageCount Value="1"/>
</Unit39>
<Unit40>
<Filename Value="D:\lazarusClean\fpcsrc\fcl\xml\xmlwrite.pp"/>
<UnitName Value="XMLWrite"/>
<CursorPos X="11" Y="28"/>
<TopLine Value="16"/>
<UsageCount Value="9"/>
</Unit40>
<Unit41>
<Filename Value="D:\lazarusClean\fpcsrc\rtl\objpas\classes\classesh.inc"/>
<CursorPos X="52" Y="298"/>
<TopLine Value="278"/>
<UsageCount Value="6"/>
</Unit41>
<Unit42>
<Filename Value="D:\lazarusClean\fpcsrc\rtl\objpas\classes\stringl.inc"/>
<CursorPos X="19" Y="636"/>
<TopLine Value="634"/>
<UsageCount Value="0"/>
</Unit42>
<Unit43>
<Filename Value="D:\lazarusClean\fpcsrc\rtl\objpas\sysutils\sysstrh.inc"/>
<CursorPos X="10" Y="80"/>
<TopLine Value="69"/>
<UsageCount Value="0"/>
</Unit43>
<Unit44>
<Filename Value="D:\lazarusClean\fpcsrc\rtl\objpas\sysutils\sysstr.inc"/>
<CursorPos X="37" Y="453"/>
<TopLine Value="451"/>
<UsageCount Value="0"/>
</Unit44>
<Unit45>
<Filename Value="D:\lazarusClean\fpcsrc\rtl\objpas\classes\lists.inc"/>
<CursorPos X="3" Y="370"/>
<TopLine Value="368"/>
<UsageCount Value="0"/>
</Unit45>
<Unit46>
<Filename Value="D:\lazarusClean\fpcsrc\rtl\objpas\objpas.pp"/>
<UnitName Value="objpas"/>
<CursorPos X="8" Y="26"/>
<TopLine Value="14"/>
<UsageCount Value="0"/>
</Unit46>
<Unit47>
<Filename Value="D:\lazarusClean\fpcsrc\rtl\objpas\typinfo.pp"/>
<UnitName Value="typinfo"/>
<CursorPos X="3" Y="741"/>
<TopLine Value="705"/>
<UsageCount Value="6"/>
</Unit47>
<Unit48>
<Filename Value="D:\lazarusClean\fpcsrc\rtl\inc\wstringh.inc"/>
<CursorPos X="5" Y="67"/>
<TopLine Value="42"/>
<UsageCount Value="0"/>
</Unit48>
<Unit49>
<Filename Value="D:\lazarusClean\fpcsrc\rtl\inc\wstrings.inc"/>
<CursorPos X="3" Y="825"/>
<TopLine Value="820"/>
<UsageCount Value="0"/>
</Unit49>
<Unit50>
<Filename Value="D:\lazarusClean\fpcsrc\rtl\win32\classes.pp"/>
<UnitName Value="Classes"/>
<CursorPos X="38" Y="2"/>
<TopLine Value="1"/>
<UsageCount Value="3"/>
</Unit50>
<Unit51>
<Filename Value="D:\lazarusClean\fpcsrc\rtl\objpas\classes\writer.inc"/>
<CursorPos X="3" Y="585"/>
<TopLine Value="579"/>
<UsageCount Value="1"/>
</Unit51>
<Unit52>
<Filename Value="D:\lazarusClean\fpcsrc\rtl\objpas\classes\compon.inc"/>
<CursorPos X="25" Y="367"/>
<TopLine Value="364"/>
<UsageCount Value="1"/>
</Unit52>
<Unit53>
<Filename Value="D:\lazarusClean\fpcsrc\fcl\xml\dom.pp"/>
<UnitName Value="DOM"/>
<CursorPos X="15" Y="269"/>
<TopLine Value="258"/>
<UsageCount Value="2"/>
</Unit53>
<Unit54>
<Filename Value="..\..\metadata_service.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="metadata_service"/>
<CursorPos X="25" Y="147"/>
<TopLine Value="145"/>
<UsageCount Value="187"/>
</Unit54>
<Unit55>
<Filename Value="..\..\metadata_service_imp.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="metadata_service_imp"/>
<CursorPos X="63" Y="107"/>
<TopLine Value="86"/>
<UsageCount Value="186"/>
</Unit55>
<Unit56>
<Filename Value="..\..\metadata_service_binder.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="metadata_service_binder"/>
<CursorPos X="53" Y="11"/>
<TopLine Value="1"/>
<UsageCount Value="186"/>
</Unit56>
<Unit57>
<Filename Value="..\..\metadata_service.lrs"/>
<CursorPos X="1" Y="1"/>
<TopLine Value="1"/>
<UsageCount Value="4"/>
</Unit57>
<Unit58>
<Filename Value="D:\lazarusClean\fpcsrc\rtl\objpas\classes\persist.inc"/>
<CursorPos X="3" Y="37"/>
<TopLine Value="117"/>
<UsageCount Value="6"/>
</Unit58>
<Unit59>
<Filename Value="D:\lazarusClean\fpcsrc\rtl\objpas\rtlconsts.pp"/>
<UnitName Value="RtlConsts"/>
<CursorPos X="7" Y="1"/>
<TopLine Value="1"/>
<UsageCount Value="6"/>
</Unit59>
<Unit60>
<Filename Value="D:\lazarusClean\fpcsrc\rtl\objpas\rtlconst.inc"/>
<CursorPos X="1" Y="1"/>
<TopLine Value="1"/>
<UsageCount Value="6"/>
</Unit60>
<Unit61>
<Filename Value="..\calculator\srv\calculator_imp.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="calculator_imp"/>
<CursorPos X="65" Y="3"/>
<TopLine Value="1"/>
<EditorIndex Value="6"/>
<UsageCount Value="123"/>
<Loaded Value="True"/>
</Unit61>
<Unit62>
<Filename Value="..\calculator\srv\calculator_binder.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="calculator_binder"/>
<CursorPos X="69" Y="51"/>
<TopLine Value="39"/>
<UsageCount Value="123"/>
</Unit62>
<Unit63>
<Filename Value="..\calculator\calculator.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="calculator"/>
<CursorPos X="31" Y="98"/>
<TopLine Value="51"/>
<UsageCount Value="123"/>
</Unit63>
<Unit64>
<Filename Value="D:\lazarusClean\fpcsrc\rtl\inc\heaph.inc"/>
<CursorPos X="10" Y="96"/>
<TopLine Value="83"/>
<UsageCount Value="0"/>
</Unit64>
<Unit65>
<Filename Value="..\..\imp_utils.pas"/>
<UnitName Value="imp_utils"/>
<CursorPos X="1" Y="55"/>
<TopLine Value="43"/>
<UsageCount Value="10"/>
</Unit65>
<Unit66>
<Filename Value="D:\Lazarus\fpcsrc\rtl\objpas\sysutils\intfh.inc"/>
<CursorPos X="10" Y="27"/>
<TopLine Value="9"/>
<UsageCount Value="4"/>
</Unit66>
<Unit67>
<Filename Value="D:\Lazarus\fpcsrc\rtl\win\sysutils.pp"/>
<UnitName Value="sysutils"/>
<CursorPos X="8" Y="33"/>
<TopLine Value="34"/>
<UsageCount Value="5"/>
</Unit67>
<Unit68>
<Filename Value="D:\Lazarus\fpcsrc\rtl\objpas\sysutils\sysutilh.inc"/>
<CursorPos X="1" Y="1"/>
<TopLine Value="214"/>
<UsageCount Value="5"/>
</Unit68>
<Unit69>
<Filename Value="D:\Lazarus\fpcsrc\rtl\objpas\classes\stringl.inc"/>
<CursorPos X="3" Y="1063"/>
<TopLine Value="1060"/>
<UsageCount Value="5"/>
</Unit69>
<Unit70>
<Filename Value="..\calculator\srv\logger_extension.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="logger_extension"/>
<CursorPos X="32" Y="11"/>
<TopLine Value="1"/>
<EditorIndex Value="3"/>
<UsageCount Value="36"/>
<Loaded Value="True"/>
</Unit70>
<Unit71>
<Filename Value="..\..\soap_formatter.pas"/>
<UnitName Value="soap_formatter"/>
<CursorPos X="1" Y="1"/>
<TopLine Value="1"/>
<UsageCount Value="13"/>
</Unit71>
<Unit72>
<Filename Value="..\..\service_intf.pas"/>
<UnitName Value="service_intf"/>
<CursorPos X="58" Y="47"/>
<TopLine Value="34"/>
<UsageCount Value="13"/>
</Unit72>
</Units>
<JumpHistory Count="21" HistoryIndex="20">
<Position1>
<Filename Value="wst_http_server.pas"/>
<Caret Line="29" Column="30" TopLine="19"/>
</Position1>
<Position2>
<Filename Value="app_object.pas"/>
<Caret Line="260" Column="21" TopLine="242"/>
</Position2>
<Position3>
<Filename Value="app_object.pas"/>
<Caret Line="1" Column="1" TopLine="1"/>
</Position3>
<Position4>
<Filename Value="app_object.pas"/>
<Caret Line="189" Column="1" TopLine="168"/>
</Position4>
<Position5>
<Filename Value="app_object.pas"/>
<Caret Line="1" Column="1" TopLine="1"/>
</Position5>
<Position6>
<Filename Value="app_object.pas"/>
<Caret Line="93" Column="1" TopLine="72"/>
</Position6>
<Position7>
<Filename Value="app_object.pas"/>
<Caret Line="1" Column="1" TopLine="1"/>
</Position7>
<Position8>
<Filename Value="app_object.pas"/>
<Caret Line="72" Column="18" TopLine="59"/>
</Position8>
<Position9>
<Filename Value="app_object.pas"/>
<Caret Line="123" Column="39" TopLine="108"/>
</Position9>
<Position10>
<Filename Value="app_object.pas"/>
<Caret Line="68" Column="1" TopLine="47"/>
</Position10>
<Position11>
<Filename Value="app_object.pas"/>
<Caret Line="1" Column="1" TopLine="1"/>
</Position11>
<Position12>
<Filename Value="app_object.pas"/>
<Caret Line="34" Column="31" TopLine="23"/>
</Position12>
<Position13>
<Filename Value="app_object.pas"/>
<Caret Line="163" Column="1" TopLine="143"/>
</Position13>
<Position14>
<Filename Value="app_object.pas"/>
<Caret Line="1" Column="1" TopLine="1"/>
</Position14>
<Position15>
<Filename Value="app_object.pas"/>
<Caret Line="164" Column="48" TopLine="163"/>
</Position15>
<Position16>
<Filename Value="app_object.pas"/>
<Caret Line="1" Column="1" TopLine="1"/>
</Position16>
<Position17>
<Filename Value="app_object.pas"/>
<Caret Line="36" Column="33" TopLine="25"/>
</Position17>
<Position18>
<Filename Value="app_object.pas"/>
<Caret Line="164" Column="48" TopLine="153"/>
</Position18>
<Position19>
<Filename Value="app_object.pas"/>
<Caret Line="269" Column="3" TopLine="263"/>
</Position19>
<Position20>
<Filename Value="app_object.pas"/>
<Caret Line="248" Column="5" TopLine="239"/>
</Position20>
<Position21>
<Filename Value="app_object.pas"/>
<Caret Line="1" Column="1" TopLine="1"/>
</Position21>
</JumpHistory>
</ProjectOptions>
<CompilerOptions>
<Version Value="5"/>
<PathDelim Value="\"/>
<SearchPaths>
<OtherUnitFiles Value="..\..\;..\calculator\;..\calculator\srv\"/>
<UnitOutputDirectory Value="obj"/>
<SrcPath Value="..\..\"/>
</SearchPaths>
<CodeGeneration>
<Generate Value="Faster"/>
</CodeGeneration>
<Linking>
<Debugging>
<GenerateDebugInfo Value="True"/>
</Debugging>
</Linking>
<Other>
<CustomOptions Value="-Xi"/>
<CompilerPath Value="$(CompPath)"/>
</Other>
</CompilerOptions>
<Debugging>
<BreakPoints Count="6">
<Item1>
<Source Value="..\..\metadata_repository.pas"/>
<Line Value="309"/>
</Item1>
<Item2>
<Source Value="..\..\metadata_wsdl.pas"/>
<Line Value="459"/>
</Item2>
<Item3>
<Source Value="..\..\metadata_wsdl.pas"/>
<Line Value="468"/>
</Item3>
<Item4>
<Source Value="..\..\metadata_wsdl.pas"/>
<Line Value="431"/>
</Item4>
<Item5>
<Source Value="..\..\metadata_wsdl.pas"/>
<Line Value="181"/>
</Item5>
<Item6>
<Source Value="..\..\server_service_intf.pas"/>
<Line Value="630"/>
</Item6>
</BreakPoints>
<Exceptions Count="2">
<Item1>
<Name Value="ECodetoolError"/>
</Item1>
<Item2>
<Name Value="EFOpenError"/>
</Item2>
</Exceptions>
</Debugging>
</CONFIG>

40
wst/tags/3.1/tests/http_server/wst_http_server.pas Normal file
View File

@ -0,0 +1,40 @@
{
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 wst_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" WebServer listening at:');
WriteLn('');
WriteLn('http://127.0.0.1:8000/');
WriteLn('');
WriteLn('Press enter to quit.');
ReadLn();
finally
FreeAndNil(AppObject);
end;
end.

326
wst/tags/3.1/tests/metadata_browser/metadata_browser.lpi Normal file
View File

@ -0,0 +1,326 @@
<?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="2">
<Item1>
<PackageName Value="LCL"/>
</Item1>
<Item2>
<PackageName Value="indylaz"/>
</Item2>
</RequiredPackages>
<Units Count="16">
<Unit0>
<Filename Value="metadata_browser.lpr"/>
<IsPartOfProject Value="True"/>
<UnitName Value="metadata_browser"/>
<CursorPos X="25" Y="1"/>
<TopLine Value="1"/>
<UsageCount Value="68"/>
</Unit0>
<Unit1>
<Filename Value="umain.pas"/>
<ComponentName Value="fMain"/>
<IsPartOfProject Value="True"/>
<ResourceFilename Value="umain.lrs"/>
<UnitName Value="umain"/>
<CursorPos X="15" Y="49"/>
<TopLine Value="34"/>
<EditorIndex Value="0"/>
<UsageCount Value="68"/>
<Loaded Value="True"/>
</Unit1>
<Unit2>
<Filename Value="..\..\metadata_service_proxy.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="metadata_service_proxy"/>
<CursorPos X="61" Y="35"/>
<TopLine Value="23"/>
<UsageCount Value="68"/>
</Unit2>
<Unit3>
<Filename Value="..\..\base_service_intf.pas"/>
<UnitName Value="base_service_intf"/>
<CursorPos X="1" Y="1196"/>
<TopLine Value="1185"/>
<UsageCount Value="5"/>
</Unit3>
<Unit4>
<Filename Value="..\..\indy_http_protocol.pas"/>
<UnitName Value="indy_http_protocol"/>
<CursorPos X="27" Y="155"/>
<TopLine Value="144"/>
<EditorIndex Value="6"/>
<UsageCount Value="18"/>
<Loaded Value="True"/>
</Unit4>
<Unit5>
<Filename Value="..\..\service_intf.pas"/>
<UnitName Value="service_intf"/>
<CursorPos X="34" Y="86"/>
<TopLine Value="117"/>
<UsageCount Value="5"/>
</Unit5>
<Unit6>
<Filename Value="..\..\soap_formatter.pas"/>
<UnitName Value="soap_formatter"/>
<CursorPos X="1" Y="216"/>
<TopLine Value="189"/>
<UsageCount Value="5"/>
</Unit6>
<Unit7>
<Filename Value="..\..\base_soap_formatter.pas"/>
<UnitName Value="base_soap_formatter"/>
<CursorPos X="30" Y="134"/>
<TopLine Value="134"/>
<UsageCount Value="5"/>
</Unit7>
<Unit8>
<Filename Value="..\..\binary_formatter.pas"/>
<UnitName Value="binary_formatter"/>
<CursorPos X="38" Y="35"/>
<TopLine Value="32"/>
<EditorIndex Value="3"/>
<UsageCount Value="17"/>
<Loaded Value="True"/>
</Unit8>
<Unit9>
<Filename Value="..\..\ics_http_protocol.pas"/>
<UnitName Value="ics_http_protocol"/>
<CursorPos X="3" Y="24"/>
<TopLine Value="13"/>
<EditorIndex Value="2"/>
<UsageCount Value="13"/>
<Loaded Value="True"/>
</Unit9>
<Unit10>
<Filename Value="..\..\metadata_service.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="metadata_service"/>
<CursorPos X="35" Y="106"/>
<TopLine Value="99"/>
<UsageCount Value="63"/>
</Unit10>
<Unit11>
<Filename Value="D:\lazarusClean\fpcsrc\rtl\inc\objpash.inc"/>
<CursorPos X="23" Y="118"/>
<TopLine Value="107"/>
<UsageCount Value="5"/>
</Unit11>
<Unit12>
<Filename Value="..\..\base_binary_formatter.pas"/>
<UnitName Value="base_binary_formatter"/>
<CursorPos X="49" Y="650"/>
<TopLine Value="639"/>
<EditorIndex Value="4"/>
<UsageCount Value="17"/>
<Loaded Value="True"/>
</Unit12>
<Unit13>
<Filename Value="..\..\synapse_http_protocol.pas"/>
<UnitName Value="synapse_http_protocol"/>
<CursorPos X="34" Y="102"/>
<TopLine Value="92"/>
<EditorIndex Value="5"/>
<UsageCount Value="17"/>
<Loaded Value="True"/>
</Unit13>
<Unit14>
<Filename Value="D:\lazarusClean\others_package\ics\latest_distr\Delphi\Vc32\WSockBuf.pas"/>
<UnitName Value="WSockBuf"/>
<CursorPos X="1" Y="1"/>
<TopLine Value="1"/>
<UsageCount Value="10"/>
</Unit14>
<Unit15>
<Filename Value="..\..\ics_tcp_protocol.pas"/>
<UnitName Value="ics_tcp_protocol"/>
<CursorPos X="35" Y="83"/>
<TopLine Value="31"/>
<EditorIndex Value="1"/>
<UsageCount Value="12"/>
<Loaded Value="True"/>
</Unit15>
</Units>
<JumpHistory Count="22" HistoryIndex="21">
<Position1>
<Filename Value="umain.pas"/>
<Caret Line="46" Column="23" TopLine="40"/>
</Position1>
<Position2>
<Filename Value="..\..\synapse_http_protocol.pas"/>
<Caret Line="155" Column="3" TopLine="147"/>
</Position2>
<Position3>
<Filename Value="..\..\synapse_http_protocol.pas"/>
<Caret Line="153" Column="71" TopLine="147"/>
</Position3>
<Position4>
<Filename Value="..\..\synapse_http_protocol.pas"/>
<Caret Line="167" Column="35" TopLine="149"/>
</Position4>
<Position5>
<Filename Value="umain.pas"/>
<Caret Line="46" Column="22" TopLine="40"/>
</Position5>
<Position6>
<Filename Value="..\..\synapse_http_protocol.pas"/>
<Caret Line="58" Column="16" TopLine="49"/>
</Position6>
<Position7>
<Filename Value="..\..\synapse_http_protocol.pas"/>
<Caret Line="39" Column="23" TopLine="33"/>
</Position7>
<Position8>
<Filename Value="..\..\synapse_http_protocol.pas"/>
<Caret Line="1" Column="1" TopLine="1"/>
</Position8>
<Position9>
<Filename Value="umain.pas"/>
<Caret Line="46" Column="41" TopLine="40"/>
</Position9>
<Position10>
<Filename Value="..\..\indy_http_protocol.pas"/>
<Caret Line="1" Column="1" TopLine="1"/>
</Position10>
<Position11>
<Filename Value="umain.pas"/>
<Caret Line="46" Column="53" TopLine="40"/>
</Position11>
<Position12>
<Filename Value="..\..\ics_http_protocol.pas"/>
<Caret Line="1" Column="1" TopLine="1"/>
</Position12>
<Position13>
<Filename Value="umain.pas"/>
<Caret Line="46" Column="53" TopLine="40"/>
</Position13>
<Position14>
<Filename Value="umain.pas"/>
<Caret Line="1" Column="1" TopLine="1"/>
</Position14>
<Position15>
<Filename Value="..\..\ics_http_protocol.pas"/>
<Caret Line="108" Column="36" TopLine="97"/>
</Position15>
<Position16>
<Filename Value="..\..\ics_http_protocol.pas"/>
<Caret Line="24" Column="3" TopLine="13"/>
</Position16>
<Position17>
<Filename Value="umain.pas"/>
<Caret Line="22" Column="15" TopLine="22"/>
</Position17>
<Position18>
<Filename Value="umain.pas"/>
<Caret Line="46" Column="67" TopLine="36"/>
</Position18>
<Position19>
<Filename Value="umain.pas"/>
<Caret Line="47" Column="17" TopLine="36"/>
</Position19>
<Position20>
<Filename Value="umain.pas"/>
<Caret Line="47" Column="16" TopLine="36"/>
</Position20>
<Position21>
<Filename Value="..\..\ics_tcp_protocol.pas"/>
<Caret Line="1" Column="1" TopLine="1"/>
</Position21>
<Position22>
<Filename Value="umain.pas"/>
<Caret Line="162" Column="5" TopLine="143"/>
</Position22>
</JumpHistory>
</ProjectOptions>
<CompilerOptions>
<Version Value="5"/>
<PathDelim Value="\"/>
<Target>
<Filename Value="metadata_browser.exe"/>
</Target>
<SearchPaths>
<OtherUnitFiles Value="..\..\;D:\lazarusClean\others_package\synapse\;D:\lazarusClean\others_package\ics\latest_distr\Delphi\Vc32\"/>
<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>
<CustomOptions Value="-Xi"/>
<CompilerPath Value="$(CompPath)"/>
</Other>
</CompilerOptions>
<Debugging>
<BreakPoints Count="8">
<Item1>
<Source Value="..\..\server_service_soap.pas"/>
<Line Value="112"/>
</Item1>
<Item2>
<Source Value="..\..\metadata_repository.pas"/>
<Line Value="309"/>
</Item2>
<Item3>
<Source Value="..\..\metadata_wsdl.pas"/>
<Line Value="459"/>
</Item3>
<Item4>
<Source Value="..\..\metadata_wsdl.pas"/>
<Line Value="468"/>
</Item4>
<Item5>
<Source Value="..\..\metadata_wsdl.pas"/>
<Line Value="431"/>
</Item5>
<Item6>
<Source Value="..\..\metadata_wsdl.pas"/>
<Line Value="298"/>
</Item6>
<Item7>
<Source Value="..\..\metadata_wsdl.pas"/>
<Line Value="181"/>
</Item7>
<Item8>
<Source Value="..\..\metadata_service_proxy.pas"/>
<Line Value="43"/>
</Item8>
</BreakPoints>
<Exceptions Count="2">
<Item1>
<Name Value="ECodetoolError"/>
</Item1>
<Item2>
<Name Value="EFOpenError"/>
</Item2>
</Exceptions>
</Debugging>
</CONFIG>

19
wst/tags/3.1/tests/metadata_browser/metadata_browser.lpr Normal file
View File

@ -0,0 +1,19 @@
program metadata_browser;
{$mode objfpc}{$H+}
uses
{$IFDEF UNIX}{$IFDEF UseCThreads}
cthreads,
{$ENDIF}{$ENDIF}
Interfaces, // this includes the LCL widgetset
Forms
{ add your units here }, umain, metadata_service_proxy, indylaz,
metadata_service;
begin
Application.Initialize;
Application.CreateForm(TfMain, fMain);
Application.Run;
end.

150
wst/tags/3.1/tests/metadata_browser/umain.lfm Normal file
View File

@ -0,0 +1,150 @@
object fMain: TfMain
Left = 175
Height = 311
Top = 233
Width = 574
HorzScrollBar.Page = 573
VertScrollBar.Page = 310
ActiveControl = edtAddress
Caption = 'WST Metadata Browser'
object pnlHead: TPanel
Height = 82
Width = 574
Align = alTop
TabOrder = 0
object Label1: TLabel
Left = 14
Height = 14
Top = 12
Width = 20
Caption = 'URL'
Color = clNone
ParentColor = False
end
object Label3: TLabel
Left = 11
Height = 14
Top = 46
Width = 35
Caption = 'Format'
Color = clNone
ParentColor = False
end
object edtAddress: TEdit
Left = 88
Height = 23
Top = 12
Width = 480
Anchors = [akTop, akLeft, akRight]
Font.CharSet = ANSI_CHARSET
Font.Color = clBlack
Font.Height = -13
Font.Name = 'Arial'
Font.Pitch = fpVariable
TabOrder = 0
Text = 'http://127.0.0.1:8000/wst/services/IWSTMetadataService'
end
object btnGetRepList: TButton
Left = 477
Height = 25
Top = 40
Width = 91
Action = actGetRepositoryList
Anchors = [akTop, akRight]
BorderSpacing.InnerBorder = 4
TabOrder = 2
end
object edtFormat: TRadioGroup
Left = 88
Height = 37
Top = 35
Width = 238
AutoFill = True
Caption = ' &Format '
ChildSizing.LeftRightSpacing = 6
ChildSizing.TopBottomSpacing = 6
ChildSizing.EnlargeHorizontal = crsHomogenousChildResize
ChildSizing.EnlargeVertical = crsHomogenousChildResize
ChildSizing.ShrinkHorizontal = crsScaleChilds
ChildSizing.ShrinkVertical = crsScaleChilds
ChildSizing.Layout = cclLeftToRightThenTopToBottom
ChildSizing.ControlsPerLine = 2
Columns = 2
ItemIndex = 0
Items.Strings = (
'&SOAP'
'&binary'
)
TabOrder = 1
end
end
object pnlClient: TPanel
Height = 229
Top = 82
Width = 574
Align = alClient
BevelInner = bvRaised
BevelOuter = bvLowered
TabOrder = 1
object Label2: TLabel
Left = 14
Height = 14
Top = 14
Width = 53
Caption = 'Repository'
Color = clNone
ParentColor = False
end
object edtRepositoryList: TComboBox
Left = 112
Height = 21
Top = 7
Width = 344
Anchors = [akTop, akLeft, akRight]
AutoCompleteText = [cbactEndOfLineComplete, cbactSearchAscending]
MaxLength = 0
TabOrder = 0
Text = 'edtRepositoryList'
end
object tvwMetadata: TTreeView
Left = 11
Height = 176
Top = 38
Width = 555
Anchors = [akTop, akLeft, akRight, akBottom]
DefaultItemHeight = 18
Font.CharSet = ANSI_CHARSET
Font.Color = clBlack
Font.Height = -13
Font.Name = 'Courier New'
Font.Pitch = fpFixed
ReadOnly = True
TabOrder = 1
Options = [tvoAutoItemHeight, tvoHideSelection, tvoKeepCollapsedNodes, tvoReadOnly, tvoShowButtons, tvoShowLines, tvoShowRoot, tvoShowSeparators, tvoToolTips]
TreeLineColor = clNavy
end
object Button1: TButton
Left = 477
Height = 25
Top = 6
Width = 91
Action = actGetRepository
Anchors = [akTop, akRight]
BorderSpacing.InnerBorder = 4
TabOrder = 2
end
end
object AL: TActionList
left = 48
top = 384
object actGetRepositoryList: TAction
Caption = 'Get Rep. List'
OnExecute = actGetRepositoryListExecute
end
object actGetRepository: TAction
Caption = 'Get Repository'
OnExecute = actGetRepositoryExecute
OnUpdate = actGetRepositoryUpdate
end
end
end

51
wst/tags/3.1/tests/metadata_browser/umain.lrs Normal file
View File

@ -0,0 +1,51 @@
{ Ceci est un fichier ressource g�n�r� automatiquement par Lazarus }
LazarusResources.Add('TfMain','FORMDATA',[
'TPF0'#6'TfMain'#5'fMain'#4'Left'#3#175#0#6'Height'#3'7'#1#3'Top'#3#233#0#5'W'
+'idth'#3'>'#2#18'HorzScrollBar.Page'#3'='#2#18'VertScrollBar.Page'#3'6'#1#13
+'ActiveControl'#7#10'edtAddress'#7'Caption'#6#20'WST Metadata Browser'#0#6'T'
+'Panel'#7'pnlHead'#6'Height'#2'R'#5'Width'#3'>'#2#5'Align'#7#5'alTop'#8'TabO'
+'rder'#2#0#0#6'TLabel'#6'Label1'#4'Left'#2#14#6'Height'#2#14#3'Top'#2#12#5'W'
+'idth'#2#20#7'Caption'#6#3'URL'#5'Color'#7#6'clNone'#11'ParentColor'#8#0#0#6
+'TLabel'#6'Label3'#4'Left'#2#11#6'Height'#2#14#3'Top'#2'.'#5'Width'#2'#'#7'C'
+'aption'#6#6'Format'#5'Color'#7#6'clNone'#11'ParentColor'#8#0#0#5'TEdit'#10
+'edtAddress'#4'Left'#2'X'#6'Height'#2#23#3'Top'#2#12#5'Width'#3#224#1#7'Anch'
+'ors'#11#5'akTop'#6'akLeft'#7'akRight'#0#12'Font.CharSet'#7#12'ANSI_CHARSET'
+#10'Font.Color'#7#7'clBlack'#11'Font.Height'#2#243#9'Font.Name'#6#5'Arial'#10
+'Font.Pitch'#7#10'fpVariable'#8'TabOrder'#2#0#4'Text'#6'6http://127.0.0.1:80'
+'00/wst/services/IWSTMetadataService'#0#0#7'TButton'#13'btnGetRepList'#4'Lef'
+'t'#3#221#1#6'Height'#2#25#3'Top'#2'('#5'Width'#2'['#6'Action'#7#20'actGetRe'
+'positoryList'#7'Anchors'#11#5'akTop'#7'akRight'#0#25'BorderSpacing.InnerBor'
+'der'#2#4#8'TabOrder'#2#2#0#0#11'TRadioGroup'#9'edtFormat'#4'Left'#2'X'#6'He'
+'ight'#2'%'#3'Top'#2'#'#5'Width'#3#238#0#8'AutoFill'#9#7'Caption'#6#9' &Form'
+'at '#28'ChildSizing.LeftRightSpacing'#2#6#28'ChildSizing.TopBottomSpacing'#2
+#6#29'ChildSizing.EnlargeHorizontal'#7#24'crsHomogenousChildResize'#27'Child'
+'Sizing.EnlargeVertical'#7#24'crsHomogenousChildResize'#28'ChildSizing.Shrin'
+'kHorizontal'#7#14'crsScaleChilds'#26'ChildSizing.ShrinkVertical'#7#14'crsSc'
+'aleChilds'#18'ChildSizing.Layout'#7#29'cclLeftToRightThenTopToBottom'#27'Ch'
+'ildSizing.ControlsPerLine'#2#2#7'Columns'#2#2#9'ItemIndex'#2#0#13'Items.Str'
+'ings'#1#6#5'&SOAP'#6#7'&binary'#0#8'TabOrder'#2#1#0#0#0#6'TPanel'#9'pnlClie'
+'nt'#6'Height'#3#229#0#3'Top'#2'R'#5'Width'#3'>'#2#5'Align'#7#8'alClient'#10
+'BevelInner'#7#8'bvRaised'#10'BevelOuter'#7#9'bvLowered'#8'TabOrder'#2#1#0#6
+'TLabel'#6'Label2'#4'Left'#2#14#6'Height'#2#14#3'Top'#2#14#5'Width'#2'5'#7'C'
+'aption'#6#10'Repository'#5'Color'#7#6'clNone'#11'ParentColor'#8#0#0#9'TComb'
+'oBox'#17'edtRepositoryList'#4'Left'#2'p'#6'Height'#2#21#3'Top'#2#7#5'Width'
+#3'X'#1#7'Anchors'#11#5'akTop'#6'akLeft'#7'akRight'#0#16'AutoCompleteText'#11
+#22'cbactEndOfLineComplete'#20'cbactSearchAscending'#0#9'MaxLength'#2#0#8'Ta'
+'bOrder'#2#0#4'Text'#6#17'edtRepositoryList'#0#0#9'TTreeView'#11'tvwMetadata'
+#4'Left'#2#11#6'Height'#3#176#0#3'Top'#2'&'#5'Width'#3'+'#2#7'Anchors'#11#5
+'akTop'#6'akLeft'#7'akRight'#8'akBottom'#0#17'DefaultItemHeight'#2#18#12'Fon'
+'t.CharSet'#7#12'ANSI_CHARSET'#10'Font.Color'#7#7'clBlack'#11'Font.Height'#2
+#243#9'Font.Name'#6#11'Courier New'#10'Font.Pitch'#7#7'fpFixed'#8'ReadOnly'#9
+#8'TabOrder'#2#1#7'Options'#11#17'tvoAutoItemHeight'#16'tvoHideSelection'#21
+'tvoKeepCollapsedNodes'#11'tvoReadOnly'#14'tvoShowButtons'#12'tvoShowLines'
+#11'tvoShowRoot'#17'tvoShowSeparators'#11'tvoToolTips'#0#13'TreeLineColor'#7
+#6'clNavy'#0#0#7'TButton'#7'Button1'#4'Left'#3#221#1#6'Height'#2#25#3'Top'#2
+#6#5'Width'#2'['#6'Action'#7#16'actGetRepository'#7'Anchors'#11#5'akTop'#7'a'
+'kRight'#0#25'BorderSpacing.InnerBorder'#2#4#8'TabOrder'#2#2#0#0#0#11'TActio'
+'nList'#2'AL'#4'left'#2'0'#3'top'#3#128#1#0#7'TAction'#20'actGetRepositoryLi'
+'st'#7'Caption'#6#13'Get Rep. List'#9'OnExecute'#7#27'actGetRepositoryListEx'
+'ecute'#0#0#7'TAction'#16'actGetRepository'#7'Caption'#6#14'Get Repository'#9
+'OnExecute'#7#23'actGetRepositoryExecute'#8'OnUpdate'#7#22'actGetRepositoryU'
+'pdate'#0#0#0#0
]);

164
wst/tags/3.1/tests/metadata_browser/umain.pas Normal file
View File

@ -0,0 +1,164 @@
unit umain;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, ExtCtrls,
StdCtrls, Buttons, ActnList, metadata_service, ComCtrls;
type
{ TfMain }
TfMain = class(TForm)
actGetRepositoryList: TAction;
actGetRepository: TAction;
AL: TActionList;
btnGetRepList: TButton;
Button1: TButton;
edtRepositoryList: TComboBox;
edtAddress: TEdit;
Label1: TLabel;
Label2: TLabel;
Label3: TLabel;
pnlClient: TPanel;
pnlHead: TPanel;
edtFormat: TRadioGroup;
tvwMetadata: TTreeView;
procedure actGetRepositoryExecute(Sender: TObject);
procedure actGetRepositoryListExecute(Sender: TObject);
procedure actGetRepositoryUpdate(Sender: TObject);
private
function CreateMetadataObject():IWSTMetadataService;
procedure LoadRepository(ARep : TWSTMtdRepository);
public
{ public declarations }
end;
var
fMain: TfMain;
implementation
uses base_service_intf, service_intf,
soap_formatter, binary_formatter,
synapse_http_protocol, //indy_http_protocol, ics_http_protocol,
//ics_tcp_protocol,
metadata_service_proxy;
{ TfMain }
procedure TfMain.actGetRepositoryListExecute(Sender: TObject);
var
tmpObj : IWSTMetadataService;
locList : TArrayOfStringRemotable;
i : Integer;
begin
tmpObj := CreateMetadataObject();
locList := tmpObj.GetRepositoryList();
edtRepositoryList.Items.Clear();
for i := 0 to Pred(locList.Length) do begin
edtRepositoryList.Items.Add(locList.Item[i]);
end;
end;
procedure TfMain.actGetRepositoryExecute(Sender: TObject);
var
rd : TWSTMtdRepository;
begin
rd := CreateMetadataObject().GetRepositoryInfo(edtRepositoryList.Items[edtRepositoryList.ItemIndex]);
try
LoadRepository(rd);
finally
rd.Free();
end;
end;
procedure TfMain.actGetRepositoryUpdate(Sender: TObject);
begin
TAction(Sender).Enabled := ( edtRepositoryList.ItemIndex > -1 );
end;
function TfMain.CreateMetadataObject(): IWSTMetadataService;
const FORMAT_MAP : Array[0..1] of string = ( 'SOAP', 'binary' );
var
i : Integer;
s : string;
begin
i := edtFormat.ItemIndex;
if not ( i in [0..1] ) then
i := 0;
s := FORMAT_MAP[i];
Result := TWSTMetadataService_Proxy.Create(
'WSTMetadataService',
s,
Format('http:Address=%s',[edtAddress.Text])// 'http:Address=http://127.0.0.1:8000/services/IWSTMetadataService'
) as IWSTMetadataService;//'TCP:Address=127.0.0.1;Port=1234;target=Calculator'
end;
procedure TfMain.LoadRepository(ARep: TWSTMtdRepository);
procedure LoadService(ASrvsNd : TTreeNode; AService : TWSTMtdService);
procedure LoadOperation(AOprsNd : TTreeNode; AOper : TWSTMtdServiceOperation);
procedure LoadParam(APrmsNd : TTreeNode; APrm : TWSTMtdOperationParam);
var
prmNd : TTreeNode;
begin
prmNd := tvwMetadata.Items.AddChild(APrmsNd,APrm.Name);
tvwMetadata.Items.AddChild(prmNd,Format('Name = %s',[APrm.Name]));
tvwMetadata.Items.AddChild(prmNd,Format('Type = %s',[APrm.TypeName]));
end;
var
opNd, prmsNd : TTreeNode;
ii, cc : Integer;
begin
opNd := tvwMetadata.Items.AddChild(AOprsNd,AOper.Name);
tvwMetadata.Items.AddChild(opNd,Format('Name = %s',[AOper.Name]));
cc := AOper.Params.Length;
prmsNd := tvwMetadata.Items.AddChild(opNd,Format('Parameters = %d',[cc]));
for ii := 0 to Pred(cc) do
LoadParam(prmsNd,AOper.Params[ii]);
end;
var
svNd, oprsNd : TTreeNode;
j, k : Integer;
begin
svNd := tvwMetadata.Items.AddChild(ASrvsNd,AService.Name);
tvwMetadata.Items.AddChild(svNd,Format('Name = %s',[AService.Name]));
k := AService.Operations.Length;
oprsNd := tvwMetadata.Items.AddChild(svNd,Format('Operations = %d',[k]));
for j := 0 to Pred(k) do
LoadOperation(oprsNd,AService.Operations[j]);
end;
var
rtNd, srvsNd : TTreeNode;
i, c : Integer;
begin
tvwMetadata.Items.Clear();
if not Assigned(ARep) then
Exit;
rtNd := tvwMetadata.Items.AddChild(Nil,ARep.Name);
tvwMetadata.Items.AddChild(rtNd,Format('Name = %s',[ARep.Name]));
tvwMetadata.Items.AddChild(rtNd,Format('Name Space = %s',[ARep.Name]));
c := ARep.Services.Length;
srvsNd := tvwMetadata.Items.AddChild(rtNd,Format('Services Count = %d',[c]));
for i := 0 to Pred(c) do begin
LoadService(srvsNd,ARep.Services[i]);
end;
end;
initialization
{$I umain.lrs}
RegisterStdTypes();
SYNAPSE_RegisterHTTP_Transport();
//ICS_RegisterHTTP_Transport();
//INDY_RegisterHTTP_Transport();
end.

270
wst/tags/3.1/tests/tcp_server/server_unit.pas Normal file
View File

@ -0,0 +1,270 @@
unit server_unit;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, Windows, Dialogs,
WSocket, WSocketS;
Type
{ TTcpSrvClient }
TTcpSrvClient = class(TWSocketClient)
Private
FConnectTime: TDateTime;
FDataLentgh: LongInt;
FRequestStream : TStream;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy();override;
function TryRead():Boolean;
property ConnectTime : TDateTime Read FConnectTime Write FConnectTime;
property RequestStream : TStream Read FRequestStream;
property DataLentgh : LongInt Read FDataLentgh;
end;
{ TTcpSrvApp }
TTcpSrvApp = class
Private
procedure HandleClientConnect(Sender: TObject;Client: TWSocketClient; Error: Word);
procedure HandleClientDisconnect(Sender: TObject;
Client: TWSocketClient; Error: Word);
procedure HandleBgException(Sender: TObject; E: Exception;
var CanClose: Boolean);
private
FWSocketServer: TWSocketServer;
procedure ClientDataAvailable(Sender: TObject; Error: Word);
procedure ProcessData(Client : TTcpSrvClient);
procedure ClientBgException(Sender : TObject;
E : Exception;
var CanClose : Boolean);
procedure ClientLineLimitExceeded(Sender : TObject;
Cnt : LongInt;
var ClearData : Boolean);
Public
constructor Create();
destructor Destroy();override;
procedure Display(Msg : String);
procedure Start();
procedure Stop();
function IsActive():Boolean;
End;
Implementation
uses umain, server_service_intf, server_service_imputils, binary_streamer;
procedure LogMsg(const Msg : String);
Begin
fMain.LogMessage(Msg);
End;
procedure TTcpSrvApp.Display(Msg : String);
begin
LogMsg(Msg);
end;
procedure TTcpSrvApp.Start();
begin
Display('Starting...');
FWSocketServer.Proto := 'tcp'; { Use TCP protocol }
FWSocketServer.Port := '1234';
FWSocketServer.Addr := '0.0.0.0'; { Use any interface }
FWSocketServer.ClientClass := TTcpSrvClient;
FWSocketServer.Listen; { Start litening }
Display('Waiting for clients...');
end;
procedure TTcpSrvApp.Stop();
begin
FWSocketServer.CloseDelayed();
end;
function TTcpSrvApp.IsActive(): Boolean;
begin
Result := ( FWSocketServer.State < wsClosed );
end;
procedure TTcpSrvApp.HandleClientConnect(
Sender : TObject;
Client : TWSocketClient;
Error : Word);
begin
with Client as TTcpSrvClient do begin
Display('Client connected.' +
' Remote: ' + PeerAddr + '/' + PeerPort +
' Local: ' + GetXAddr + '/' + GetXPort);
Display('There is now ' +
IntToStr(TWSocketServer(Sender).ClientCount) +
' clients connected.');
LineMode := False;
LineEdit := False;
OnDataAvailable := @ClientDataAvailable;
OnLineLimitExceeded := @ClientLineLimitExceeded;
OnBgException := @ClientBgException;
ConnectTime := Now;
end;
end;
procedure TTcpSrvApp.HandleClientDisconnect(
Sender : TObject;
Client : TWSocketClient;
Error : Word);
begin
with Client as TTcpSrvClient do begin
Display('Client disconnecting : ' + PeerAddr + ' ' +
'Duration: ' + FormatDateTime('hh:nn:ss',
Now - ConnectTime));
Display('There is now ' +
IntToStr(TWSocketServer(Sender).ClientCount - 1) +
' clients connected.');
end;
end;
procedure TTcpSrvApp.ClientLineLimitExceeded(
Sender : TObject;
Cnt : LongInt;
var ClearData : Boolean);
begin
with Sender as TTcpSrvClient do begin
Display('Line limit exceeded from ' + GetPeerAddr + '. Closing.');
ClearData := TRUE;
Close;
end;
end;
constructor TTcpSrvApp.Create();
begin
FWSocketServer := TWSocketServer.Create(Nil);
FWSocketServer.Banner := '';
FWSocketServer.OnClientConnect := @HandleClientConnect;
FWSocketServer.OnBgException := @HandleBgException;
FWSocketServer.OnClientDisconnect := @HandleClientDisconnect;
end;
destructor TTcpSrvApp.Destroy();
begin
FWSocketServer.Free();
end;
procedure TTcpSrvApp.ClientDataAvailable(Sender : TObject;Error : Word);
Var
cliTCP : TTcpSrvClient;
begin
cliTCP := Sender as TTcpSrvClient;
//Display('ClientDataAvailable()');
If cliTCP.TryRead() And ( cliTCP.DataLentgh > 0 ) Then
ProcessData(cliTCP)
end;
procedure TTcpSrvApp.ProcessData(Client : TTcpSrvClient);
Var
buff, trgt,ctntyp : string;
rqst : IRequestBuffer;
wrtr : IDataStore;
rdr : IDataStoreReader;
inStream, outStream, bufStream : TMemoryStream;
i : Integer;
begin
inStream := Nil;
outStream := Nil;
bufStream := Nil;
Try
Client.RequestStream.Position := 0;
Try
inStream := TMemoryStream.Create();
outStream := TMemoryStream.Create();
bufStream := TMemoryStream.Create();
rdr := CreateBinaryReader(Client.RequestStream);
trgt := rdr.ReadStr();
ctntyp := rdr.ReadStr();
buff := rdr.ReadStr();
inStream.Write(buff[1],Length(buff));
inStream.Position := 0;
rqst := TRequestBuffer.Create(trgt,ctntyp,inStream,bufStream);
HandleServiceRequest(rqst);
i := bufStream.Size;
SetLength(buff,i);
bufStream.Position := 0;
bufStream.Read(buff[1],i);
wrtr := CreateBinaryWriter(outStream);
wrtr.WriteStr(buff);
//Display('ProcessData() resp Ln =' + IntToStr(i) + '; resp = ' + buff);
Client.Send(outStream.Memory,outStream.Size);
Finally
//Display('ProcessData()>> END');
bufStream.Free();
outStream.Free();
inStream.Free();
Client.FDataLentgh := -1;
Client.RequestStream.Size := 0;
End;
Except
On e : Exception Do
Display('ProcessData()>> Exception = '+e.Message);
End;
end;
procedure TTcpSrvApp.HandleBgException(
Sender : TObject;
E : Exception;
var CanClose : Boolean);
begin
Display('Server exception occured: ' + E.ClassName + ': ' + E.Message);
CanClose := FALSE; { Hoping that server will still work ! }
end;
procedure TTcpSrvApp.ClientBgException(
Sender : TObject;
E : Exception;
var CanClose : Boolean);
begin
Display('Client exception occured: ' + E.ClassName + ': ' + E.Message);
CanClose := TRUE; { Goodbye client ! }
end;
{ TTcpSrvClient }
constructor TTcpSrvClient.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FDataLentgh := -1;
FRequestStream := TMemoryStream.Create();
end;
destructor TTcpSrvClient.Destroy();
begin
FRequestStream.Free();
inherited Destroy();
end;
function TTcpSrvClient.TryRead(): Boolean;
Var
i,j : PtrInt;
buff : string;
begin
If ( FDataLentgh < 0 ) Then Begin
i := 4;
If ( Receive(@FDataLentgh,i) < 4 ) Then Begin
FDataLentgh := -1;
Result := False;
Exit;
End;
FDataLentgh := Reverse_32(FDataLentgh);
End;
If ( FDataLentgh > FRequestStream.Size ) Then Begin
i := Min((FDataLentgh-FRequestStream.Size),1024);
SetLength(buff,i);
j := Receive(@(buff[1]),i);
FRequestStream.Write(buff[1],j);
//LogMsg(Format('Read %d bytes; buff=%s',[j,buff]));
End;
Result := ( FDataLentgh <= FRequestStream.Size );
//LogMsg(Format('TryRead() >> FDataLentgh=%d; Size=%d',[FDataLentgh,FRequestStream.Size]));
end;
end.

381
wst/tags/3.1/tests/tcp_server/tcp_gui_server.lpi Normal file
View File

@ -0,0 +1,381 @@
<?xml version="1.0"?>
<CONFIG>
<ProjectOptions>
<PathDelim Value="\"/>
<Version Value="5"/>
<General>
<MainUnit Value="0"/>
<IconPath Value="./"/>
<TargetFileExt Value=".exe"/>
<ActiveEditorIndexAtStart Value="5"/>
</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="38">
<Unit0>
<Filename Value="tcp_gui_server.lpr"/>
<IsPartOfProject Value="True"/>
<UnitName Value="tcp_gui_server"/>
<CursorPos X="25" Y="3"/>
<TopLine Value="1"/>
<EditorIndex Value="5"/>
<UsageCount Value="127"/>
<Loaded Value="True"/>
</Unit0>
<Unit1>
<Filename Value="umain.pas"/>
<ComponentName Value="fMain"/>
<IsPartOfProject Value="True"/>
<ResourceFilename Value="umain.lrs"/>
<UnitName Value="umain"/>
<CursorPos X="41" Y="88"/>
<TopLine Value="1"/>
<EditorIndex Value="0"/>
<UsageCount Value="127"/>
<Loaded Value="True"/>
</Unit1>
<Unit2>
<Filename Value="server_unit.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="server_unit"/>
<CursorPos X="4" Y="245"/>
<TopLine Value="144"/>
<EditorIndex Value="1"/>
<UsageCount Value="127"/>
<Loaded Value="True"/>
</Unit2>
<Unit3>
<Filename Value="D:\Lazarus\others_package\ics\latest_distr\Delphi\Vc32\WSocket.pas"/>
<UnitName Value="WSocket"/>
<CursorPos X="27" Y="982"/>
<TopLine Value="968"/>
<UsageCount Value="9"/>
</Unit3>
<Unit4>
<Filename Value="D:\Lazarus\others_package\ics\latest_distr\Delphi\Vc32\WSocketS.pas"/>
<UnitName Value="WSocketS"/>
<CursorPos X="32" Y="140"/>
<TopLine Value="136"/>
<UsageCount Value="9"/>
</Unit4>
<Unit5>
<Filename Value="..\..\..\..\binary_streamer.pas"/>
<UnitName Value="binary_streamer"/>
<CursorPos X="1" Y="1"/>
<TopLine Value="1"/>
<UsageCount Value="50"/>
</Unit5>
<Unit6>
<Filename Value="..\..\..\..\server_service_intf.pas"/>
<UnitName Value="server_service_intf"/>
<CursorPos X="17" Y="203"/>
<TopLine Value="70"/>
<UsageCount Value="41"/>
</Unit6>
<Unit7>
<Filename Value="..\..\..\..\server_service_imputils.pas"/>
<UnitName Value="server_service_imputils"/>
<CursorPos X="29" Y="1"/>
<TopLine Value="1"/>
<UsageCount Value="41"/>
</Unit7>
<Unit8>
<Filename Value="D:\Lazarus\others_package\ics\latest_distr\Delphi\Vc32\WSockBuf.pas"/>
<UnitName Value="WSockBuf"/>
<CursorPos X="3" Y="163"/>
<TopLine Value="157"/>
<UsageCount Value="10"/>
</Unit8>
<Unit9>
<Filename Value="..\..\basic_stub.pas"/>
<UnitName Value="basic_stub"/>
<CursorPos X="39" Y="16"/>
<TopLine Value="8"/>
<UsageCount Value="32"/>
</Unit9>
<Unit10>
<Filename Value="..\..\basic.pas"/>
<UnitName Value="basic"/>
<CursorPos X="5" Y="3"/>
<TopLine Value="1"/>
<UsageCount Value="38"/>
</Unit10>
<Unit11>
<Filename Value="..\..\basic_intfimpunit.pas"/>
<UnitName Value="basic_intfimpunit"/>
<CursorPos X="1" Y="1"/>
<TopLine Value="7"/>
<UsageCount Value="10"/>
</Unit11>
<Unit12>
<Filename Value="..\..\basic_service_implementation.pas"/>
<UnitName Value="basic_service_implementation"/>
<CursorPos X="56" Y="33"/>
<TopLine Value="1"/>
<UsageCount Value="32"/>
</Unit12>
<Unit13>
<Filename Value="..\..\..\..\server_service_soap.pas"/>
<UnitName Value="server_service_soap"/>
<CursorPos X="45" Y="811"/>
<TopLine Value="807"/>
<UsageCount Value="30"/>
</Unit13>
<Unit14>
<Filename Value="..\..\..\..\server_binary_formatter.pas"/>
<UnitName Value="server_binary_formatter"/>
<CursorPos X="37" Y="23"/>
<TopLine Value="1"/>
<UsageCount Value="30"/>
</Unit14>
<Unit15>
<Filename Value="..\..\..\..\binary_util_imp.inc"/>
<CursorPos X="3" Y="426"/>
<TopLine Value="424"/>
<UsageCount Value="5"/>
</Unit15>
<Unit16>
<Filename Value="..\..\..\..\binary_util_h.inc"/>
<CursorPos X="6" Y="180"/>
<TopLine Value="166"/>
<UsageCount Value="3"/>
</Unit16>
<Unit17>
<Filename Value="..\..\basic_imp.pas"/>
<UnitName Value="basic_imp"/>
<CursorPos X="3" Y="39"/>
<TopLine Value="9"/>
<UsageCount Value="4"/>
</Unit17>
<Unit18>
<Filename Value="..\..\basic_binder.pas"/>
<UnitName Value="basic_binder"/>
<CursorPos X="13" Y="67"/>
<TopLine Value="44"/>
<UsageCount Value="4"/>
</Unit18>
<Unit19>
<Filename Value="D:\lazarusClean\fpcsrc\rtl\objpas\classes\classesh.inc"/>
<CursorPos X="15" Y="190"/>
<TopLine Value="178"/>
<UsageCount Value="3"/>
</Unit19>
<Unit20>
<Filename Value="D:\lazarusClean\fpcsrc\rtl\objpas\classes\lists.inc"/>
<CursorPos X="26" Y="419"/>
<TopLine Value="412"/>
<UsageCount Value="3"/>
</Unit20>
<Unit21>
<Filename Value="D:\lazarusClean\fpcsrc\fcl\inc\contnrs.pp"/>
<UnitName Value="contnrs"/>
<CursorPos X="3" Y="745"/>
<TopLine Value="743"/>
<UsageCount Value="4"/>
</Unit21>
<Unit22>
<Filename Value="..\..\..\..\service_intf.pas"/>
<UnitName Value="service_intf"/>
<CursorPos X="3" Y="814"/>
<TopLine Value="796"/>
<UsageCount Value="3"/>
</Unit22>
<Unit23>
<Filename Value="calculator\calculator.pas"/>
<UnitName Value="calculator"/>
<CursorPos X="47" Y="58"/>
<TopLine Value="28"/>
<UsageCount Value="87"/>
</Unit23>
<Unit24>
<Filename Value="calculator\srv\calculator_imp.pas"/>
<UnitName Value="calculator_imp"/>
<CursorPos X="55" Y="95"/>
<TopLine Value="77"/>
<UsageCount Value="87"/>
</Unit24>
<Unit25>
<Filename Value="calculator\srv\calculator_binder.pas"/>
<UnitName Value="calculator_binder"/>
<CursorPos X="40" Y="126"/>
<TopLine Value="101"/>
<UsageCount Value="87"/>
</Unit25>
<Unit26>
<Filename Value="..\..\server_service_soap.pas"/>
<UnitName Value="server_service_soap"/>
<CursorPos X="15" Y="43"/>
<TopLine Value="29"/>
<UsageCount Value="26"/>
</Unit26>
<Unit27>
<Filename Value="..\..\server_binary_formatter.pas"/>
<UnitName Value="server_binary_formatter"/>
<CursorPos X="13" Y="83"/>
<TopLine Value="73"/>
<UsageCount Value="28"/>
</Unit27>
<Unit28>
<Filename Value="..\..\server_service_intf.pas"/>
<UnitName Value="server_service_intf"/>
<CursorPos X="9" Y="429"/>
<TopLine Value="417"/>
<EditorIndex Value="2"/>
<UsageCount Value="44"/>
<Loaded Value="True"/>
</Unit28>
<Unit29>
<Filename Value="..\..\base_service_intf.pas"/>
<UnitName Value="base_service_intf"/>
<CursorPos X="1" Y="22"/>
<TopLine Value="17"/>
<UsageCount Value="38"/>
</Unit29>
<Unit30>
<Filename Value="D:\lazarusClean\fpcsrc\rtl\objpas\typinfo.pp"/>
<UnitName Value="typinfo"/>
<CursorPos X="1" Y="1"/>
<TopLine Value="31"/>
<UsageCount Value="9"/>
</Unit30>
<Unit31>
<Filename Value="..\..\base_soap_formatter.pas"/>
<UnitName Value="base_soap_formatter"/>
<CursorPos X="3" Y="328"/>
<TopLine Value="317"/>
<UsageCount Value="26"/>
<Bookmarks Count="1">
<Item0 X="24" Y="642" ID="1"/>
</Bookmarks>
</Unit31>
<Unit32>
<Filename Value="..\..\base_binary_formatter.pas"/>
<UnitName Value="base_binary_formatter"/>
<CursorPos X="3" Y="872"/>
<TopLine Value="874"/>
<UsageCount Value="20"/>
<Bookmarks Count="1">
<Item0 X="16" Y="387" ID="2"/>
</Bookmarks>
</Unit32>
<Unit33>
<Filename Value="..\..\binary_streamer.pas"/>
<UnitName Value="binary_streamer"/>
<CursorPos X="67" Y="167"/>
<TopLine Value="149"/>
<UsageCount Value="12"/>
</Unit33>
<Unit34>
<Filename Value="D:\lazarusClean\fpcsrc\rtl\win\sysutils.pp"/>
<UnitName Value="sysutils"/>
<CursorPos X="1" Y="1"/>
<TopLine Value="78"/>
<UsageCount Value="8"/>
</Unit34>
<Unit35>
<Filename Value="..\calculator\calculator.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="calculator"/>
<CursorPos X="1" Y="1"/>
<TopLine Value="1"/>
<EditorIndex Value="3"/>
<UsageCount Value="20"/>
<Loaded Value="True"/>
</Unit35>
<Unit36>
<Filename Value="..\calculator\srv\calculator_imp.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="calculator_imp"/>
<CursorPos X="48" Y="117"/>
<TopLine Value="110"/>
<EditorIndex Value="4"/>
<UsageCount Value="20"/>
<Loaded Value="True"/>
</Unit36>
<Unit37>
<Filename Value="..\calculator\srv\calculator_binder.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="calculator_binder"/>
<CursorPos X="80" Y="174"/>
<TopLine Value="170"/>
<UsageCount Value="20"/>
</Unit37>
</Units>
<JumpHistory Count="0" HistoryIndex="-1"/>
</ProjectOptions>
<CompilerOptions>
<Version Value="5"/>
<PathDelim Value="\"/>
<SearchPaths>
<OtherUnitFiles Value="D:\Lazarus\others_package\ics\latest_distr\Delphi\Vc32\;..\calculator\;..\calculator\srv\;..\..\"/>
<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>
<Debugging>
<GenerateDebugInfo Value="True"/>
</Debugging>
<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>

17
wst/tags/3.1/tests/tcp_server/tcp_gui_server.lpr Normal file
View File

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

77
wst/tags/3.1/tests/tcp_server/umain.lfm Normal file
View File

@ -0,0 +1,77 @@
object fMain: TfMain
Left = 290
Height = 300
Top = 180
Width = 400
HorzScrollBar.Page = 399
VertScrollBar.Page = 299
ActiveControl = Button1
Caption = 'Simple TCP App Server'
ClientHeight = 300
ClientWidth = 400
OnCreate = FormCreate
PixelsPerInch = 96
object Label1: TLabel
Left = 16
Height = 14
Top = 72
Width = 18
Caption = 'Log'
Color = clNone
ParentColor = False
end
object Button1: TButton
Left = 16
Height = 25
Top = 8
Width = 104
Action = actStart
BorderSpacing.InnerBorder = 2
TabOrder = 0
end
object mmoLog: TMemo
Left = 8
Height = 192
Top = 96
Width = 384
Anchors = [akTop, akLeft, akRight, akBottom]
ReadOnly = True
ScrollBars = ssAutoBoth
TabOrder = 1
end
object Button2: TButton
Left = 16
Height = 25
Top = 40
Width = 104
Action = actStop
BorderSpacing.InnerBorder = 2
TabOrder = 2
end
object edtPort: TEdit
Left = 128
Height = 23
Top = 10
Width = 80
TabOrder = 3
Text = '1234'
end
object AL: TActionList
left = 152
top = 32
object actStart: TAction
Caption = 'Start( Port=)'
OnExecute = actStartExecute
OnUpdate = actStartUpdate
end
object actStop: TAction
Caption = 'Stop'
OnExecute = actStopExecute
OnUpdate = actStopUpdate
end
object actClearLog: TAction
Caption = 'Clear Log'
OnExecute = actClearLogExecute
end
end
end

24
wst/tags/3.1/tests/tcp_server/umain.lrs Normal file
View File

@ -0,0 +1,24 @@
{ 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#180#0#5'Wi'
+'dth'#3#144#1#18'HorzScrollBar.Page'#3#143#1#18'VertScrollBar.Page'#3'+'#1#13
+'ActiveControl'#7#7'Button1'#7'Caption'#6#21'Simple TCP App Server'#12'Clien'
+'tHeight'#3','#1#11'ClientWidth'#3#144#1#8'OnCreate'#7#10'FormCreate'#13'Pix'
+'elsPerInch'#2'`'#0#6'TLabel'#6'Label1'#4'Left'#2#16#6'Height'#2#14#3'Top'#2
+'H'#5'Width'#2#18#7'Caption'#6#3'Log'#5'Color'#7#6'clNone'#11'ParentColor'#8
+#0#0#7'TButton'#7'Button1'#4'Left'#2#16#6'Height'#2#25#3'Top'#2#8#5'Width'#2
+'h'#6'Action'#7#8'actStart'#25'BorderSpacing.InnerBorder'#2#2#8'TabOrder'#2#0
+#0#0#5'TMemo'#6'mmoLog'#4'Left'#2#8#6'Height'#3#192#0#3'Top'#2'`'#5'Width'#3
+#128#1#7'Anchors'#11#5'akTop'#6'akLeft'#7'akRight'#8'akBottom'#0#8'ReadOnly'
+#9#10'ScrollBars'#7#10'ssAutoBoth'#8'TabOrder'#2#1#0#0#7'TButton'#7'Button2'
+#4'Left'#2#16#6'Height'#2#25#3'Top'#2'('#5'Width'#2'h'#6'Action'#7#7'actStop'
+#25'BorderSpacing.InnerBorder'#2#2#8'TabOrder'#2#2#0#0#5'TEdit'#7'edtPort'#4
+'Left'#3#128#0#6'Height'#2#23#3'Top'#2#10#5'Width'#2'P'#8'TabOrder'#2#3#4'Te'
+'xt'#6#4'1234'#0#0#11'TActionList'#2'AL'#4'left'#3#152#0#3'top'#2' '#0#7'TAc'
+'tion'#8'actStart'#7'Caption'#6#13'Start( Port=)'#9'OnExecute'#7#15'actStart'
+'Execute'#8'OnUpdate'#7#14'actStartUpdate'#0#0#7'TAction'#7'actStop'#7'Capti'
+'on'#6#4'Stop'#9'OnExecute'#7#14'actStopExecute'#8'OnUpdate'#7#13'actStopUpd'
+'ate'#0#0#7'TAction'#11'actClearLog'#7'Caption'#6#9'Clear Log'#9'OnExecute'#7
+#18'actClearLogExecute'#0#0#0#0
]);

98
wst/tags/3.1/tests/tcp_server/umain.pas Normal file
View File

@ -0,0 +1,98 @@
unit umain;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, Buttons,
StdCtrls, ActnList, ExtCtrls;
type
{ TfMain }
TfMain = class(TForm)
actClearLog: TAction;
actStop: TAction;
actStart: TAction;
AL: TActionList;
Button1: TButton;
Button2: TButton;
edtPort: TEdit;
Label1: TLabel;
mmoLog: TMemo;
procedure actClearLogExecute(Sender: TObject);
procedure actStartExecute(Sender: TObject);
procedure actStartUpdate(Sender: TObject);
procedure actStopExecute(Sender: TObject);
procedure actStopUpdate(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
public
procedure LogMessage(const AMsg : string);
end;
var
fMain: TfMain;
implementation
uses server_unit,
server_service_soap, server_binary_formatter,
calculator, calculator_imp, calculator_binder;
Var
scktServer : TTcpSrvApp;
{ TfMain }
procedure TfMain.actStartUpdate(Sender: TObject);
begin
TAction(Sender).Enabled := Not ( Assigned(scktServer) And scktServer.IsActive() );
end;
procedure TfMain.actStopExecute(Sender: TObject);
begin
If Assigned(scktServer) Then Begin
scktServer.Stop();
End;
end;
procedure TfMain.actStopUpdate(Sender: TObject);
begin
TAction(Sender).Enabled := Assigned(scktServer) And scktServer.IsActive();
end;
procedure TfMain.actStartExecute(Sender: TObject);
begin
mmoLog.Clear();
If Not Assigned(scktServer) Then
scktServer := TTcpSrvApp.Create();
If Not scktServer.IsActive() Then
scktServer.Start();
end;
procedure TfMain.actClearLogExecute(Sender: TObject);
begin
mmoLog.Clear();
end;
procedure TfMain.FormCreate(Sender: TObject);
begin
Server_service_RegisterCalculatorService();
Server_service_RegisterCalculatorService();
RegisterCalculatorImplementationFactory();
Server_service_RegisterSoapFormat();
Server_service_RegisterBinaryFormat();
end;
procedure TfMain.LogMessage(const AMsg: string);
begin
mmoLog.Lines.Add(AMsg);
end;
initialization
{$I umain.lrs}
end.

171
wst/tags/3.1/tests/test_float_to_str/project1.lpi Normal file
View File

@ -0,0 +1,171 @@
<?xml version="1.0"?>
<CONFIG>
<ProjectOptions>
<PathDelim Value="\"/>
<Version Value="5"/>
<General>
<MainUnit Value="0"/>
<IconPath Value="./"/>
<TargetFileExt Value=".exe"/>
<ActiveEditorIndexAtStart Value="0"/>
</General>
<LazDoc Paths=""/>
<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="5">
<Unit0>
<Filename Value="project1.lpr"/>
<IsPartOfProject Value="True"/>
<UnitName Value="project1"/>
<UsageCount Value="20"/>
</Unit0>
<Unit1>
<Filename Value="unit1.pas"/>
<ComponentName Value="Form1"/>
<IsPartOfProject Value="True"/>
<ResourceFilename Value="unit1.lrs"/>
<UnitName Value="Unit1"/>
<CursorPos X="75" Y="45"/>
<TopLine Value="34"/>
<EditorIndex Value="0"/>
<UsageCount Value="20"/>
<Loaded Value="True"/>
</Unit1>
<Unit2>
<Filename Value="D:\lazarusClean\fpcsrc\rtl\objpas\sysutils\sysstrh.inc"/>
<CursorPos X="10" Y="164"/>
<TopLine Value="100"/>
<EditorIndex Value="1"/>
<UsageCount Value="10"/>
<Loaded Value="True"/>
</Unit2>
<Unit3>
<Filename Value="D:\lazarusClean\fpcsrc\rtl\objpas\sysutils\sysstr.inc"/>
<CursorPos X="42" Y="1764"/>
<TopLine Value="1797"/>
<EditorIndex Value="2"/>
<UsageCount Value="10"/>
<Loaded Value="True"/>
</Unit3>
<Unit4>
<Filename Value="D:\lazarusClean\fpcsrc\rtl\objpas\sysutils\sysinth.inc"/>
<CursorPos X="3" Y="95"/>
<TopLine Value="76"/>
<EditorIndex Value="3"/>
<UsageCount Value="10"/>
<Loaded Value="True"/>
</Unit4>
</Units>
<JumpHistory Count="7" HistoryIndex="6">
<Position1>
<Filename Value="D:\lazarusClean\fpcsrc\rtl\objpas\sysutils\sysstrh.inc"/>
<Caret Line="130" Column="49" TopLine="120"/>
</Position1>
<Position2>
<Filename Value="D:\lazarusClean\fpcsrc\rtl\objpas\sysutils\sysstrh.inc"/>
<Caret Line="107" Column="10" TopLine="107"/>
</Position2>
<Position3>
<Filename Value="D:\lazarusClean\fpcsrc\rtl\objpas\sysutils\sysstrh.inc"/>
<Caret Line="1" Column="1" TopLine="1"/>
</Position3>
<Position4>
<Filename Value="D:\lazarusClean\fpcsrc\rtl\objpas\sysutils\sysstr.inc"/>
<Caret Line="1923" Column="13" TopLine="1917"/>
</Position4>
<Position5>
<Filename Value="D:\lazarusClean\fpcsrc\rtl\objpas\sysutils\sysstr.inc"/>
<Caret Line="1923" Column="16" TopLine="1917"/>
</Position5>
<Position6>
<Filename Value="D:\lazarusClean\fpcsrc\rtl\objpas\sysutils\sysstr.inc"/>
<Caret Line="1770" Column="42" TopLine="1737"/>
</Position6>
<Position7>
<Filename Value="D:\lazarusClean\fpcsrc\rtl\objpas\sysutils\sysstr.inc"/>
<Caret Line="1764" Column="42" TopLine="1737"/>
</Position7>
</JumpHistory>
</ProjectOptions>
<CompilerOptions>
<Version Value="5"/>
<PathDelim Value="\"/>
<SearchPaths>
<SrcPath Value="$(LazarusDir)\lcl\;$(LazarusDir)\lcl\interfaces\$(LCLWidgetType)\"/>
</SearchPaths>
<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="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>

18
wst/tags/3.1/tests/test_float_to_str/project1.lpr Normal file
View File

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

58
wst/tags/3.1/tests/test_float_to_str/unit1.lfm Normal file
View File

@ -0,0 +1,58 @@
object Form1: TForm1
Left = 295
Height = 300
Top = 234
Width = 400
HorzScrollBar.Page = 399
VertScrollBar.Page = 299
Caption = 'Form1'
ClientHeight = 300
ClientWidth = 400
PixelsPerInch = 96
object Button1: TButton
Left = 72
Height = 25
Top = 56
Width = 75
BorderSpacing.InnerBorder = 2
Caption = 'Button1'
OnClick = Button1Click
TabOrder = 0
end
object Edit1: TEdit
Left = 176
Height = 23
Top = 58
Width = 80
TabOrder = 1
Text = '124656.32145'
end
object Memo1: TMemo
Left = 24
Height = 184
Top = 104
Width = 352
Lines.Strings = (
'Memo1'
)
TabOrder = 2
end
object Edit2: TEdit
Left = 103
Height = 23
Top = 26
Width = 80
TabOrder = 3
Text = '#.#######E-0'
end
object Button2: TButton
Left = 264
Height = 25
Top = 24
Width = 75
BorderSpacing.InnerBorder = 2
Caption = 'Button2'
OnClick = Button2Click
TabOrder = 4
end
end

17
wst/tags/3.1/tests/test_float_to_str/unit1.lrs Normal file
View File

@ -0,0 +1,17 @@
{ Ceci est un fichier ressource g�n�r� automatiquement par Lazarus }
LazarusResources.Add('TForm1','FORMDATA',[
'TPF0'#6'TForm1'#5'Form1'#4'Left'#3''''#1#6'Height'#3','#1#3'Top'#3#234#0#5'W'
+'idth'#3#144#1#18'HorzScrollBar.Page'#3#143#1#18'VertScrollBar.Page'#3'+'#1#7
+'Caption'#6#5'Form1'#12'ClientHeight'#3','#1#11'ClientWidth'#3#144#1#13'Pixe'
+'lsPerInch'#2'`'#0#7'TButton'#7'Button1'#4'Left'#2'H'#6'Height'#2#25#3'Top'#2
+'8'#5'Width'#2'K'#25'BorderSpacing.InnerBorder'#2#2#7'Caption'#6#7'Button1'#7
+'OnClick'#7#12'Button1Click'#8'TabOrder'#2#0#0#0#5'TEdit'#5'Edit1'#4'Left'#3
+#176#0#6'Height'#2#23#3'Top'#2':'#5'Width'#2'P'#8'TabOrder'#2#1#4'Text'#6#12
+'124656.32145'#0#0#5'TMemo'#5'Memo1'#4'Left'#2#24#6'Height'#3#184#0#3'Top'#2
+'h'#5'Width'#3'`'#1#13'Lines.Strings'#1#6#5'Memo1'#0#8'TabOrder'#2#2#0#0#5'T'
+'Edit'#5'Edit2'#4'Left'#2'g'#6'Height'#2#23#3'Top'#2#26#5'Width'#2'P'#8'TabO'
+'rder'#2#3#4'Text'#6#12'#.#######E-0'#0#0#7'TButton'#7'Button2'#4'Left'#3#8#1
+#6'Height'#2#25#3'Top'#2#24#5'Width'#2'K'#25'BorderSpacing.InnerBorder'#2#2#7
+'Caption'#6#7'Button2'#7'OnClick'#7#12'Button2Click'#8'TabOrder'#2#4#0#0#0
]);

69
wst/tags/3.1/tests/test_float_to_str/unit1.pas Normal file
View File

@ -0,0 +1,69 @@
unit Unit1;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, Buttons,
StdCtrls;
type
{ TForm1 }
TForm1 = class(TForm)
Button1: TButton;
Button2: TButton;
Edit1: TEdit;
Edit2: TEdit;
Memo1: TMemo;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
{ private declarations }
public
{ public declarations }
end;
var
Form1: TForm1;
implementation
{ TForm1 }
procedure TForm1.Button1Click(Sender: TObject);
Var
s : single;
begin
If TryStrToFloat(Edit1.Text,s) then begin
Memo1.Clear();
Memo1.Lines.Add(FloatToStrF(s,ffExponent,8,5));
Memo1.Lines.Add(FloatToStrF(s,ffGeneral,8,5));
Memo1.Lines.Add(FloatToStrF(s,ffFixed,8,5));
Memo1.Lines.Add(FloatToStrF(s,ffNumber,8,5));
Memo1.Lines.Add(FloatToStrF(s,ffCurrency,8,5)) ;
Memo1.Lines.Add(FormatFloat(Edit2.Text,s));
end;
end;
procedure TForm1.Button2Click(Sender: TObject);
Var
v : TFloatRec;
s : single;
b : string;
begin
If TryStrToFloat(Edit1.Text,s) then begin
FillChar(v,SizeOf(v),0);
FloatToDecimal(v,s,7,1);
Memo1.Clear();
Memo1.Lines.Add(Format('%d',[v.Exponent]));
end;
end;
initialization
{$I unit1.lrs}
end.

2142
wst/tags/3.1/tests/test_suite/testformatter_unit.pas Normal file
View File

File diff suppressed because it is too large Load Diff

153
wst/tags/3.1/tests/test_suite/testmetadata_unit.pas Normal file
View File

@ -0,0 +1,153 @@
{
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 testmetadata_unit;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, DOM, XMLWrite,
fpcunit, testutils, testregistry,
metadata_generator, binary_streamer, metadata_repository, parserdefs,
metadata_wsdl;
type
{ TTestMetadata }
TTestMetadata= class(TTestCase)
protected
function CreateSymbolTable():TSymbolTable;
published
procedure test_Metadata();
end;
implementation
{ TTestMetadata }
function TTestMetadata.CreateSymbolTable(): TSymbolTable;
Var
inft : TInterfaceDefinition;
begin
Result := TSymbolTable.Create('test_unit_name');
Result.Add(TTypeDefinition.Create('integer'));
Result.Add(TTypeDefinition.Create('string'));
Result.Add(TTypeDefinition.Create('double'));
inft := TInterfaceDefinition.Create('service_1');
Result.Add(inft);
inft.AddMethod('void_operation_proc',mtProcedure);
inft.AddMethod('void_operation_func',mtProcedure).AddParameter('result',pmOut,Result.ByName('integer') as TTypeDefinition);
inft := TInterfaceDefinition.Create('service_2');
Result.Add(inft);
with inft.AddMethod('dis_proc',mtProcedure) do begin
AddParameter('d',pmNone,Result.ByName('double') as TTypeDefinition);
AddParameter('i',pmConst,Result.ByName('integer') as TTypeDefinition);
AddParameter('s',pmOut,Result.ByName('string') as TTypeDefinition);
end;
with inft.AddMethod('sid_func',mtFunction) do begin
AddParameter('s',pmConst,Result.ByName('string') as TTypeDefinition);
AddParameter('i',pmVar,Result.ByName('integer') as TTypeDefinition);
AddParameter('d',pmOut,Result.ByName('double') as TTypeDefinition);
end;
end;
procedure PrintWSDL(ARep : PServiceRepository);
var
locDoc : TXMLDocument;
strm : TMemoryStream;
s : string;
begin
strm := nil;;
locDoc := TXMLDocument.Create();
try
GenerateWSDL(ARep,locDoc);
strm := TMemoryStream.Create();
WriteXMLFile(locDoc,strm);
SetLength(s,strm.Size);
Move(strm.Memory^,s[1],strm.Size);
WriteLn('*******************************************************');
WriteLn(s);
WriteLn('*******************************************************');
finally
locDoc.Free();
strm.Free();
end;
end;
procedure TTestMetadata.test_Metadata();
var
st : TSymbolTable;
mg : TMetadataGenerator;
wtr : IDataStore;
strm : TMemoryStream;
rp : PServiceRepository;
ps : PService;
po : PServiceOperation;
pop : POperationParam;
begin
strm := nil;
mg := nil;
rp := nil;
st := CreateSymbolTable();
try
strm := TMemoryStream.Create();
wtr := CreateBinaryWriter(strm);
mg := TMetadataGenerator.Create(st,wtr);
mg.Execute();
wtr := nil;
strm.Position := 0;
AssertTrue(strm.Size>10);
AssertEquals('symbol count',2,LoadRepositoryData(strm,rp));
AssertEquals('unit name','test_unit_name',rp^.Name);
AssertEquals('services count',2,rp^.ServicesCount);
AssertNotNull('services pointer',rp^.Services);
ps := rp^.Services;
AssertEquals('service name','service_1',ps^.Name);
AssertEquals('operations count',2,ps^.OperationsCount);
AssertNotNull('operations pointer',ps^.Operations);
po := ps^.Operations;
AssertEquals('operation name','void_operation_proc',po^.Name);
AssertEquals('params count',0,po^.ParamsCount);
AssertNull('params pointer',po^.Params);
Inc(po);
AssertEquals('operation name','void_operation_func',po^.Name);
AssertEquals('params count',1,po^.ParamsCount);
AssertNotNull('params pointer',po^.Params);
pop := po^.Params;
AssertEquals('param name','result',pop^.Name);
AssertEquals('param type name','integer',pop^.TypeName);
AssertEquals('param modifier',ord(pmOut),ord(pop^.Modifier));
rp^.NameSpace := 'http://test_name_space/';
//PrintWSDL(rp);
finally
mg.Free();
st.Free();
strm.Free();
ClearRepositoryData(rp);
end;
end;
initialization
RegisterTest(TTestMetadata);
end.

501
wst/tags/3.1/tests/test_suite/wst_test_suite.lpi Normal file
View File

@ -0,0 +1,501 @@
<?xml version="1.0"?>
<CONFIG>
<ProjectOptions>
<PathDelim Value="\"/>
<Version Value="5"/>
<General>
<MainUnit Value="0"/>
<IconPath Value="./"/>
<TargetFileExt Value=".exe"/>
<ActiveEditorIndexAtStart Value="6"/>
</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"/>
<CommandLineParams Value="-a >E:\Inoussa\Sources\lazarus\wst\v0.3\tests\test_suite\obj\res.xml"/>
<LaunchingApplication PathPlusParams="/usr/X11R6/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/>
</local>
</RunParams>
<RequiredPackages Count="1">
<Item1>
<PackageName Value="FPCUnitTestRunner"/>
</Item1>
</RequiredPackages>
<Units Count="46">
<Unit0>
<Filename Value="wst_test_suite.lpr"/>
<IsPartOfProject Value="True"/>
<UnitName Value="wst_test_suite"/>
<CursorPos X="69" Y="11"/>
<TopLine Value="9"/>
<UsageCount Value="148"/>
</Unit0>
<Unit1>
<Filename Value="testformatter_unit.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="testformatter_unit"/>
<CursorPos X="55" Y="66"/>
<TopLine Value="150"/>
<EditorIndex Value="9"/>
<UsageCount Value="148"/>
<Loaded Value="True"/>
</Unit1>
<Unit2>
<Filename Value="..\..\server_service_soap.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="server_service_soap"/>
<CursorPos X="20" Y="205"/>
<TopLine Value="171"/>
<EditorIndex Value="2"/>
<UsageCount Value="148"/>
<Loaded Value="True"/>
</Unit2>
<Unit3>
<Filename Value="..\..\soap_formatter.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="soap_formatter"/>
<CursorPos X="8" Y="97"/>
<TopLine Value="86"/>
<EditorIndex Value="1"/>
<UsageCount Value="148"/>
<Loaded Value="True"/>
</Unit3>
<Unit4>
<Filename Value="..\..\base_binary_formatter.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="base_binary_formatter"/>
<CursorPos X="39" Y="180"/>
<TopLine Value="171"/>
<EditorIndex Value="6"/>
<UsageCount Value="148"/>
<Loaded Value="True"/>
</Unit4>
<Unit5>
<Filename Value="..\..\base_service_intf.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="base_service_intf"/>
<CursorPos X="3" Y="106"/>
<TopLine Value="121"/>
<EditorIndex Value="0"/>
<UsageCount Value="148"/>
<Loaded Value="True"/>
</Unit5>
<Unit6>
<Filename Value="..\..\base_soap_formatter.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="base_soap_formatter"/>
<CursorPos X="1" Y="1082"/>
<TopLine Value="1061"/>
<EditorIndex Value="7"/>
<UsageCount Value="148"/>
<Loaded Value="True"/>
</Unit6>
<Unit7>
<Filename Value="..\..\binary_formatter.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="binary_formatter"/>
<CursorPos X="15" Y="44"/>
<TopLine Value="33"/>
<EditorIndex Value="4"/>
<UsageCount Value="148"/>
<Loaded Value="True"/>
</Unit7>
<Unit8>
<Filename Value="..\..\binary_streamer.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="binary_streamer"/>
<CursorPos X="32" Y="38"/>
<TopLine Value="22"/>
<UsageCount Value="148"/>
</Unit8>
<Unit9>
<Filename Value="..\..\server_binary_formatter.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="server_binary_formatter"/>
<CursorPos X="5" Y="136"/>
<TopLine Value="92"/>
<UsageCount Value="148"/>
</Unit9>
<Unit10>
<Filename Value="D:\lazarusClean\fpcsrc\fcl\fpcunit\fpcunit.pp"/>
<UnitName Value="fpcunit"/>
<CursorPos X="39" Y="66"/>
<TopLine Value="66"/>
<UsageCount Value="6"/>
</Unit10>
<Unit11>
<Filename Value="D:\lazarusClean\fpcsrc\fcl\fpcunit\testregistry.pp"/>
<UnitName Value="testregistry"/>
<CursorPos X="11" Y="29"/>
<TopLine Value="35"/>
<UsageCount Value="9"/>
</Unit11>
<Unit12>
<Filename Value="D:\lazarusClean\fpcsrc\rtl\objpas\typinfo.pp"/>
<UnitName Value="typinfo"/>
<CursorPos X="11" Y="216"/>
<TopLine Value="230"/>
<UsageCount Value="3"/>
</Unit12>
<Unit13>
<Filename Value="D:\lazarusClean\fpcsrc\rtl\objpas\sysutils\sysstrh.inc"/>
<CursorPos X="10" Y="137"/>
<TopLine Value="127"/>
<UsageCount Value="1"/>
</Unit13>
<Unit14>
<Filename Value="D:\lazarusClean\fpcsrc\rtl\objpas\sysutils\sysstr.inc"/>
<CursorPos X="23" Y="1007"/>
<TopLine Value="1005"/>
<UsageCount Value="1"/>
</Unit14>
<Unit15>
<Filename Value="D:\lazarusClean\fpcsrc\rtl\inc\systemh.inc"/>
<CursorPos X="65" Y="452"/>
<TopLine Value="441"/>
<UsageCount Value="6"/>
</Unit15>
<Unit16>
<Filename Value="D:\lazarusClean\fpcsrc\rtl\win32\system.pp"/>
<UnitName Value="System"/>
<CursorPos X="20" Y="1012"/>
<TopLine Value="1011"/>
<UsageCount Value="6"/>
</Unit16>
<Unit17>
<Filename Value="D:\lazarusClean\fpcsrc\fcl\inc\contnrs.pp"/>
<UnitName Value="contnrs"/>
<CursorPos X="3" Y="625"/>
<TopLine Value="623"/>
<UsageCount Value="1"/>
</Unit17>
<Unit18>
<Filename Value="..\..\metadata_repository.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="metadata_repository"/>
<CursorPos X="3" Y="79"/>
<TopLine Value="70"/>
<UsageCount Value="123"/>
</Unit18>
<Unit19>
<Filename Value="D:\Lazarus\fpcsrc\rtl\objpas\typinfo.pp"/>
<UnitName Value="typinfo"/>
<CursorPos X="15" Y="579"/>
<TopLine Value="565"/>
<UsageCount Value="5"/>
</Unit19>
<Unit20>
<Filename Value="testmetadata_unit.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="testmetadata_unit"/>
<CursorPos X="83" Y="119"/>
<TopLine Value="1"/>
<EditorIndex Value="8"/>
<UsageCount Value="116"/>
<Loaded Value="True"/>
</Unit20>
<Unit21>
<Filename Value="..\..\ws_helper\metadata_generator.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="metadata_generator"/>
<CursorPos X="1" Y="1"/>
<TopLine Value="31"/>
<UsageCount Value="116"/>
</Unit21>
<Unit22>
<Filename Value="..\..\ws_helper\parserdefs.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="parserdefs"/>
<CursorPos X="1" Y="1"/>
<TopLine Value="1"/>
<UsageCount Value="116"/>
</Unit22>
<Unit23>
<Filename Value="D:\Lazarus\fpcsrc\fcl\fpcunit\fpcunit.pp"/>
<UnitName Value="fpcunit"/>
<CursorPos X="21" Y="81"/>
<TopLine Value="71"/>
<UsageCount Value="2"/>
</Unit23>
<Unit24>
<Filename Value="D:\Lazarus\fpcsrc\fcl\fpcunit\testregistry.pp"/>
<UnitName Value="testregistry"/>
<CursorPos X="11" Y="29"/>
<TopLine Value="1"/>
<UsageCount Value="3"/>
</Unit24>
<Unit25>
<Filename Value="D:\Lazarus\fpcsrc\rtl\inc\heaph.inc"/>
<CursorPos X="10" Y="87"/>
<TopLine Value="61"/>
<UsageCount Value="2"/>
</Unit25>
<Unit26>
<Filename Value="D:\Lazarus\fpcsrc\rtl\inc\heap.inc"/>
<CursorPos X="3" Y="235"/>
<TopLine Value="223"/>
<UsageCount Value="2"/>
</Unit26>
<Unit27>
<Filename Value="D:\Lazarus\fpcsrc\rtl\objpas\classes\classesh.inc"/>
<CursorPos X="3" Y="1248"/>
<TopLine Value="1238"/>
<UsageCount Value="2"/>
</Unit27>
<Unit28>
<Filename Value="..\..\metadata_wsdl.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="metadata_wsdl"/>
<CursorPos X="38" Y="148"/>
<TopLine Value="142"/>
<UsageCount Value="108"/>
</Unit28>
<Unit29>
<Filename Value="D:\Lazarus\fpcsrc\fcl\xml\dom.pp"/>
<UnitName Value="DOM"/>
<CursorPos X="15" Y="429"/>
<TopLine Value="413"/>
<UsageCount Value="4"/>
</Unit29>
<Unit30>
<Filename Value="D:\lazarusClean\fpcsrc\rtl\win32\classes.pp"/>
<UnitName Value="Classes"/>
<CursorPos X="14" Y="32"/>
<TopLine Value="13"/>
<UsageCount Value="6"/>
</Unit30>
<Unit31>
<Filename Value="D:\lazarusClean\fpcsrc\rtl\objpas\classes\classesh.inc"/>
<CursorPos X="14" Y="149"/>
<TopLine Value="138"/>
<UsageCount Value="6"/>
</Unit31>
<Unit32>
<Filename Value="D:\lazarusClean\fpcsrc\rtl\objpas\classes\lists.inc"/>
<CursorPos X="3" Y="29"/>
<TopLine Value="27"/>
<UsageCount Value="6"/>
</Unit32>
<Unit33>
<Filename Value="D:\lazarusClean\fpc\2.0.4\source\rtl\objpas\sysutils\sysutilh.inc"/>
<CursorPos X="13" Y="235"/>
<TopLine Value="215"/>
<UsageCount Value="8"/>
</Unit33>
<Unit34>
<Filename Value="D:\lazarusClean\fpc\2.0.4\source\rtl\objpas\sysutils\sysutils.inc"/>
<CursorPos X="9" Y="110"/>
<TopLine Value="106"/>
<UsageCount Value="7"/>
</Unit34>
<Unit35>
<Filename Value="D:\lazarusClean\fpc\2.0.4\source\rtl\inc\heaptrc.pp"/>
<UnitName Value="heaptrc"/>
<CursorPos X="40" Y="1168"/>
<TopLine Value="1190"/>
<UsageCount Value="7"/>
</Unit35>
<Unit36>
<Filename Value="D:\lazarusClean\fpc\2.0.4\source\fcl\xml\dom.pp"/>
<UnitName Value="DOM"/>
<CursorPos X="3" Y="187"/>
<TopLine Value="175"/>
<UsageCount Value="9"/>
</Unit36>
<Unit37>
<Filename Value="..\..\server_service_intf.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="server_service_intf"/>
<CursorPos X="35" Y="379"/>
<TopLine Value="376"/>
<EditorIndex Value="3"/>
<UsageCount Value="42"/>
<Loaded Value="True"/>
</Unit37>
<Unit38>
<Filename Value="..\..\service_intf.pas"/>
<UnitName Value="service_intf"/>
<CursorPos X="1" Y="1"/>
<TopLine Value="23"/>
<EditorIndex Value="5"/>
<UsageCount Value="19"/>
<Loaded Value="True"/>
</Unit38>
<Unit39>
<Filename Value="D:\lazarusClean\fpc\2.0.4\source\rtl\objpas\classes\classesh.inc"/>
<CursorPos X="3" Y="316"/>
<TopLine Value="304"/>
<UsageCount Value="8"/>
</Unit39>
<Unit40>
<Filename Value="D:\lazarusClean\fpc\2.0.4\source\rtl\objpas\classes\lists.inc"/>
<CursorPos X="3" Y="407"/>
<TopLine Value="404"/>
<UsageCount Value="8"/>
</Unit40>
<Unit41>
<Filename Value="D:\lazarusClean\fpc\2.0.4\source\fcl\inc\contnrs.pp"/>
<UnitName Value="contnrs"/>
<CursorPos X="3" Y="474"/>
<TopLine Value="471"/>
<UsageCount Value="8"/>
</Unit41>
<Unit42>
<Filename Value="D:\lazarusClean\fpc\2.0.4\source\rtl\inc\objpash.inc"/>
<CursorPos X="27" Y="121"/>
<TopLine Value="104"/>
<UsageCount Value="8"/>
</Unit42>
<Unit43>
<Filename Value="D:\lazarusClean\fpc\2.0.4\source\rtl\inc\objpas.inc"/>
<CursorPos X="9" Y="166"/>
<TopLine Value="142"/>
<UsageCount Value="8"/>
</Unit43>
<Unit44>
<Filename Value="D:\Lazarus\components\fpcunit\guitestrunner.pas"/>
<ComponentName Value="GUITestRunner"/>
<HasResources Value="True"/>
<UnitName Value="GuiTestRunner"/>
<CursorPos X="34" Y="32"/>
<TopLine Value="25"/>
<UsageCount Value="8"/>
</Unit44>
<Unit45>
<Filename Value="D:\lazarusClean\fpc\2.0.4\source\fcl\fpcunit\fpcunit.pp"/>
<UnitName Value="fpcunit"/>
<CursorPos X="26" Y="231"/>
<TopLine Value="193"/>
<UsageCount Value="9"/>
</Unit45>
</Units>
<JumpHistory Count="0" HistoryIndex="-1"/>
</ProjectOptions>
<CompilerOptions>
<Version Value="5"/>
<PathDelim Value="\"/>
<SearchPaths>
<OtherUnitFiles Value="..\..\;..\..\ws_helper\"/>
<UnitOutputDirectory Value="obj"/>
</SearchPaths>
<Parsing>
<SyntaxOptions>
<IncludeAssertionCode Value="True"/>
</SyntaxOptions>
</Parsing>
<CodeGeneration>
<Generate Value="Faster"/>
</CodeGeneration>
<Linking>
<Debugging>
<GenerateDebugInfo Value="True"/>
</Debugging>
</Linking>
<Other>
<CustomOptions Value="-Xi"/>
<CompilerPath Value="$(CompPath)"/>
</Other>
</CompilerOptions>
<Debugging>
<BreakPoints Count="21">
<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="testformatter_unit.pas"/>
<Line Value="572"/>
</Item8>
<Item9>
<Source Value="testformatter_unit.pas"/>
<Line Value="587"/>
</Item9>
<Item10>
<Source Value="testformatter_unit.pas"/>
<Line Value="588"/>
</Item10>
<Item11>
<Source Value="testformatter_unit.pas"/>
<Line Value="571"/>
</Item11>
<Item12>
<Source Value="testformatter_unit.pas"/>
<Line Value="570"/>
</Item12>
<Item13>
<Source Value="testformatter_unit.pas"/>
<Line Value="568"/>
</Item13>
<Item14>
<Source Value="testformatter_unit.pas"/>
<Line Value="366"/>
</Item14>
<Item15>
<Source Value="testformatter_unit.pas"/>
<Line Value="337"/>
</Item15>
<Item16>
<Source Value="testformatter_unit.pas"/>
<Line Value="194"/>
</Item16>
<Item17>
<Source Value="testformatter_unit.pas"/>
<Line Value="349"/>
</Item17>
<Item18>
<Source Value="testformatter_unit.pas"/>
<Line Value="363"/>
</Item18>
<Item19>
<Source Value="testformatter_unit.pas"/>
<Line Value="821"/>
</Item19>
<Item20>
<Source Value="testformatter_unit.pas"/>
<Line Value="809"/>
</Item20>
<Item21>
<Source Value="testformatter_unit.pas"/>
<Line Value="909"/>
</Item21>
</BreakPoints>
<Watches Count="2">
<Item1>
<Expression Value="FScopeObject^.Name"/>
</Item1>
<Item2>
<Expression Value="AOwner^.DataType"/>
</Item2>
</Watches>
</Debugging>
</CONFIG>

121
wst/tags/3.1/tests/test_suite/wst_test_suite.lpr Normal file
View File

@ -0,0 +1,121 @@
program wst_test_suite;
{$mode objfpc}{$H+}
uses
custapp, classes, sysutils, fpcunit, testreport, testregistry,
TestFormatter_unit, testmetadata_unit,
server_service_soap, soap_formatter, base_binary_formatter,
base_service_intf, base_soap_formatter, binary_formatter, binary_streamer,
server_binary_formatter, metadata_repository,
metadata_generator, parserdefs, server_service_intf, metadata_wsdl;
Const
ShortOpts = 'alh';
Longopts : Array[1..5] of String = (
'all','list','format:','suite:','help');
Version = 'Version 0.1';
Type
TTestRunner = Class(TCustomApplication)
private
FXMLResultsWriter: TXMLResultsWriter;
protected
procedure DoRun ; Override;
procedure doTestRun(aTest: TTest); virtual;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
end;
constructor TTestRunner.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FXMLResultsWriter := TXMLResultsWriter.Create;
end;
destructor TTestRunner.Destroy;
begin
FXMLResultsWriter.Free;
end;
procedure TTestRunner.doTestRun(aTest: TTest);
var
testResult: TTestResult;
begin
testResult := TTestResult.Create;
try
testResult.AddListener(FXMLResultsWriter);
FXMLResultsWriter.WriteHeader;
aTest.Run(testResult);
FXMLResultsWriter.WriteResult(testResult);
finally
testResult.Free;
end;
end;
procedure TTestRunner.DoRun;
var
I : Integer;
S : String;
begin
S:=CheckOptions(ShortOpts,LongOpts);
If (S<>'') then
Writeln(S);
if HasOption('h', 'help') or (ParamCount = 0) then
begin
writeln(Title);
writeln(Version);
writeln('Usage: ');
writeln('-l or --list to show a list of registered tests');
writeln('default format is xml, add --format=latex to output the list as latex source');
writeln('-a or --all to run all the tests and show the results in xml format');
writeln('The results can be redirected to an xml file,');
writeln('for example: ./testrunner --all > results.xml');
writeln('use --suite=MyTestSuiteName to run only the tests in a single test suite class');
end;
if HasOption('l', 'list') then
begin
if HasOption('format') then
begin
if GetOptionValue('format') = 'latex' then
writeln(GetSuiteAsLatex(GetTestRegistry))
else
writeln(GetSuiteAsXML(GetTestRegistry));
end
else
writeln(GetSuiteAsXML(GetTestRegistry));
end;
if HasOption('a', 'all') then
begin
doTestRun(GetTestRegistry)
end
else
if HasOption('suite') then
begin
S := '';
S:=GetOptionValue('suite');
if S = '' then
for I := 0 to GetTestRegistry.Tests.count - 1 do
writeln(GetTestRegistry[i].TestName)
else
for I := 0 to GetTestRegistry.Tests.count - 1 do
if GetTestRegistry[i].TestName = S then
begin
doTestRun(GetTestRegistry[i]);
end;
end;
Terminate;
end;
Var
App : TTestRunner;
begin
App:=TTestRunner.Create(Nil);
App.Initialize;
App.Title := 'FPCUnit Console Test Case runner.';
App.Run;
App.Free;
end.

340
wst/tags/3.1/ws_helper/COPYING.GPL Normal file
View File

@ -0,0 +1,340 @@
GNU GENERAL PUBLIC LICENSE
Version 2, June 1991
Copyright (C) 1989, 1991 Free Software Foundation, Inc.
675 Mass Ave, Cambridge, MA 02139, USA
Everyone is permitted to copy and distribute verbatim copies
of this license document, but changing it is not allowed.
Preamble
The licenses for most software are designed to take away your
freedom to share and change it. By contrast, the GNU General Public
License is intended to guarantee your freedom to share and change free
software--to make sure the software is free for all its users. This
General Public License applies to most of the Free Software
Foundation's software and to any other program whose authors commit to
using it. (Some other Free Software Foundation software is covered by
the GNU Library General Public License instead.) You can apply it to
your programs, 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 software, or if you modify it.
For example, if you distribute copies of such a program, whether
gratis or for a fee, you must give the recipients all the rights that
you have. You must make sure that they, too, receive or can get the
source code. And you must show them these terms so they know their
rights.
We protect your rights with two steps: (1) copyright the software, and
(2) offer you this license which gives you legal permission to copy,
distribute and/or modify the software.
Also, for each author's protection and ours, we want to make certain
that everyone understands that there is no warranty for this free
software. If the software is modified by someone else and passed on, we
want its recipients to know that what they have is not the original, 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 redistributors of a free
program will individually obtain patent licenses, in effect making the
program proprietary. To prevent this, we have made it clear that any
patent must be licensed for everyone's free use or not licensed at all.
The precise terms and conditions for copying, distribution and
modification follow.
GNU GENERAL PUBLIC LICENSE
TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
0. This License applies to any program or other work which contains
a notice placed by the copyright holder saying it may be distributed
under the terms of this General Public License. The "Program", below,
refers to any such program or work, and a "work based on the Program"
means either the Program or any derivative work under copyright law:
that is to say, a work containing the Program or a portion of it,
either verbatim or with modifications and/or translated into another
language. (Hereinafter, translation is included without limitation in
the term "modification".) Each licensee is addressed as "you".
Activities other than copying, distribution and modification are not
covered by this License; they are outside its scope. The act of
running the Program is not restricted, and the output from the Program
is covered only if its contents constitute a work based on the
Program (independent of having been made by running the Program).
Whether that is true depends on what the Program does.
1. You may copy and distribute verbatim copies of the Program's
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 give any other recipients of the Program a copy of this License
along with the Program.
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 Program or any portion
of it, thus forming a work based on the Program, 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) You must cause the modified files to carry prominent notices
stating that you changed the files and the date of any change.
b) You must cause any work that you distribute or publish, that in
whole or in part contains or is derived from the Program or any
part thereof, to be licensed as a whole at no charge to all third
parties under the terms of this License.
c) If the modified program normally reads commands interactively
when run, you must cause it, when started running for such
interactive use in the most ordinary way, to print or display an
announcement including an appropriate copyright notice and a
notice that there is no warranty (or else, saying that you provide
a warranty) and that users may redistribute the program under
these conditions, and telling the user how to view a copy of this
License. (Exception: if the Program itself is interactive but
does not normally print such an announcement, your work based on
the Program is not required to print an announcement.)
These requirements apply to the modified work as a whole. If
identifiable sections of that work are not derived from the Program,
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 Program, 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 Program.
In addition, mere aggregation of another work not based on the Program
with the Program (or with a work based on the Program) on a volume of
a storage or distribution medium does not bring the other work under
the scope of this License.
3. You may copy and distribute the Program (or a work based on it,
under Section 2) in object code or executable form under the terms of
Sections 1 and 2 above provided that you also do one of the following:
a) 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; or,
b) Accompany it with a written offer, valid for at least three
years, to give any third party, for a charge no more than your
cost of physically performing source distribution, a complete
machine-readable copy of the corresponding source code, to be
distributed under the terms of Sections 1 and 2 above on a medium
customarily used for software interchange; or,
c) Accompany it with the information you received as to the offer
to distribute corresponding source code. (This alternative is
allowed only for noncommercial distribution and only if you
received the program in object code or executable form with such
an offer, in accord with Subsection b above.)
The source code for a work means the preferred form of the work for
making modifications to it. For an executable work, 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 executable. 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.
If distribution of executable or 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 counts as
distribution of the source code, even though third parties are not
compelled to copy the source along with the object code.
4. You may not copy, modify, sublicense, or distribute the Program
except as expressly provided under this License. Any attempt
otherwise to copy, modify, sublicense or distribute the Program 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.
5. 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 Program or its derivative works. These actions are
prohibited by law if you do not accept this License. Therefore, by
modifying or distributing the Program (or any work based on the
Program), you indicate your acceptance of this License to do so, and
all its terms and conditions for copying, distributing or modifying
the Program or works based on it.
6. Each time you redistribute the Program (or any work based on the
Program), the recipient automatically receives a license from the
original licensor to copy, distribute or modify the Program 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.
7. 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 Program at all. For example, if a patent
license would not permit royalty-free redistribution of the Program 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 Program.
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.
8. If the distribution and/or use of the Program is restricted in
certain countries either by patents or by copyrighted interfaces, the
original copyright holder who places the Program 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.
9. The Free Software Foundation may publish revised and/or new versions
of the 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 Program
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 Program does not specify a version number of
this License, you may choose any version ever published by the Free Software
Foundation.
10. If you wish to incorporate parts of the Program into other free
programs whose distribution conditions are different, 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
11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
PROVIDE THE PROGRAM "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 PROGRAM IS WITH YOU. SHOULD THE
PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,
REPAIR OR CORRECTION.
12. 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 PROGRAM 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 PROGRAM (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 PROGRAM TO OPERATE WITH ANY OTHER
PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE
POSSIBILITY OF SUCH DAMAGES.
END OF TERMS AND CONDITIONS
Appendix: How to Apply These Terms to Your New Programs
If you develop a new program, and you want it to be of the greatest
possible use to the public, the best way to achieve this is to make it
free software which everyone can redistribute and change under these terms.
To do so, attach the following notices to the program. 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 program's name and a brief idea of what it does.>
Copyright (C) 19yy <name of author>
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
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. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
Also add information on how to contact you by electronic and paper mail.
If the program is interactive, make it output a short notice like this
when it starts in an interactive mode:
Gnomovision version 69, Copyright (C) 19yy name of author
Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
This is free software, and you are welcome to redistribute it
under certain conditions; type `show c' for details.
The hypothetical commands `show w' and `show c' should show the appropriate
parts of the General Public License. Of course, the commands you use may
be called something other than `show w' and `show c'; they could even be
mouse-clicks or menu items--whatever suits your program.
You should also get your employer (if you work as a programmer) or your
school, if any, to sign a "copyright disclaimer" for the program, if
necessary. Here is a sample; alter the names:
Yoyodyne, Inc., hereby disclaims all copyright interest in the program
`Gnomovision' (which makes passes at compilers) written by James Hacker.
<signature of Ty Coon>, 1 April 1989
Ty Coon, President of Vice
This General Public License does not permit incorporating your program into
proprietary programs. If your program is a subroutine library, you may
consider it more useful to permit linking proprietary applications with the
library. If this is what you want to do, use the GNU Library General
Public License instead of this License.

72
wst/tags/3.1/ws_helper/command_line_parser.pas Normal file
View File

@ -0,0 +1,72 @@
{
This unit is part of the Web Service Toolkit
Copyright (c) 2006 by Inoussa OUEDRAOGO
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
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. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
}
unit command_line_parser;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils;
Type
TComandLineOption = ( cloProxy, cloImp, cloBinder, cloOutPutDir );
TComandLineOptions = set of TComandLineOption;
function ParseCmdLineOptions(out AAppOptions : TComandLineOptions):Integer;
function GetOptionArg(const AOption : TComandLineOption):string;
implementation
uses getopts;
Var
OptionsArgsMAP : Array[TComandLineOption] of string;
function GetOptionArg(const AOption : TComandLineOption):string;
begin
Result := OptionsArgsMAP[AOption];
end;
function ParseCmdLineOptions(out AAppOptions : TComandLineOptions):Integer;
Var
c : Char;
begin
AAppOptions := [];
c := #0;
Repeat
c := GetOpt('pibo:');
case c of
'p' : Include(AAppOptions,cloProxy);
'i' : Include(AAppOptions,cloImp);
'b' : Include(AAppOptions,cloBinder);
'o' :
Begin
Include(AAppOptions,cloOutPutDir);
OptionsArgsMAP[cloOutPutDir] := OptArg;
End;
end;
Until ( c = EndOfOptions );
Result := OptInd;
end;
end.

1206
wst/tags/3.1/ws_helper/generator.pas Normal file
View File

File diff suppressed because it is too large Load Diff

108
wst/tags/3.1/ws_helper/metadata_generator.pas Normal file
View File

@ -0,0 +1,108 @@
unit metadata_generator;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils,
parserdefs, binary_streamer;
const
sWST_META = 'WST_METADATA_0.2.2.0';
type
{ TMetadataGenerator }
TMetadataGenerator = class
private
FStream : IDataStore;
FSymbolTable: TSymbolTable;
procedure GenerateHeader();
procedure GenerateIntfMetadata(AIntf : TInterfaceDefinition);
public
constructor Create(
ASymTable : TSymbolTable;
ADstStream : IDataStore
);
procedure Execute();
end;
implementation
{ TMetadataGenerator }
procedure TMetadataGenerator.GenerateHeader();
var
c, i, k : LongInt;
begin
FStream.WriteStr(sWST_META);
FStream.WriteStr(FSymbolTable.Name);
k := 0;
c := FSymbolTable.Count;
for i := 0 to pred(c) do begin
if FSymbolTable.Item[i] is TInterfaceDefinition then
inc(k);
end;
FStream.WriteInt8U(k);
end;
procedure TMetadataGenerator.GenerateIntfMetadata(AIntf: TInterfaceDefinition);
procedure WriteMethod(AMeth:TMethodDefinition);
procedure WriteParam(APrm : TParameterDefinition);
begin
FStream.WriteStr(APrm.Name);
FStream.WriteStr(APrm.DataType.Name);
FStream.WriteEnum(Ord(APrm.Modifier));
end;
var
j, k : LongInt;
begin
k := AMeth.ParameterCount;
FStream.WriteStr(AMeth.Name);
FStream.WriteInt8U(k);
for j := 0 to pred(k) do
WriteParam(AMeth.Parameter[j]);
end;
var
i, c : LongInt;
begin
FStream.WriteStr(AIntf.Name);
c := AIntf.MethodCount;
FStream.WriteInt8U(c);
for i := 0 to pred(c) do
WriteMethod(AIntf.Method[i]);
end;
constructor TMetadataGenerator.Create(ASymTable: TSymbolTable;ADstStream: IDataStore);
begin
Assert(Assigned(ASymTable));
Assert(Assigned(ADstStream));
FSymbolTable := ASymTable;
FStream := ADstStream;
end;
procedure TMetadataGenerator.Execute();
Var
i,c : Integer;
intf : TInterfaceDefinition;
begin
GenerateHeader();
c := Pred(FSymbolTable.Count);
for i := 0 to c do begin
if FSymbolTable.Item[i] is TInterfaceDefinition then begin
intf := FSymbolTable.Item[i] as TInterfaceDefinition;
GenerateIntfMetadata(intf);
end;
end;
end;
end.

481
wst/tags/3.1/ws_helper/parserdefs.pas Normal file
View File

@ -0,0 +1,481 @@
{
This unit is part of the Web Service Toolkit
Copyright (c) 2006 by Inoussa OUEDRAOGO
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
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. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
}
unit parserdefs;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, Contnrs;
Type
ESymbolException = class(Exception)
End;
{ TAbstractSymbolDefinition }
TAbstractSymbolDefinition = class
private
FName: String;
Public
constructor Create(Const AName : String);
Property Name : String Read FName;
End;
{ TTypeDefinition }
TTypeDefinition = class(TAbstractSymbolDefinition)
public
function NeedFinalization():Boolean;virtual;
end;
{ TEnumItemDefinition }
TEnumItemDefinition = class(TAbstractSymbolDefinition)
private
FOrder: Integer;
Public
constructor Create(Const AName : String; Const AOrder : Integer);
Property Order : Integer Read FOrder;
End;
{ TEnumTypeDefinition }
TEnumTypeDefinition = class(TTypeDefinition)
Private
FItemList : TObjectList;
private
function GetItem(Index: Integer): TEnumItemDefinition;
function GetItemCount: Integer;
Public
constructor Create(Const AName : String);
destructor Destroy();override;
function NeedFinalization():Boolean;override;
Procedure AddItem(AItem:TEnumItemDefinition);
function FindItem(Const AName:String):TEnumItemDefinition;
Property ItemCount : Integer Read GetItemCount;
Property Item[Index:Integer]:TEnumItemDefinition Read GetItem;
End;
{ TClassTypeDefinition }
TClassTypeDefinition = class(TTypeDefinition)
public
function NeedFinalization():Boolean;override;
end;
TParameterModifier = ( pmNone, pmConst, pmVar, pmOut );
{ TParameterDefinition }
TParameterDefinition = class(TAbstractSymbolDefinition)
private
FDataType: TTypeDefinition;
FModifier: TParameterModifier;
Public
constructor Create(
Const AName : String;
Const AModifier : TParameterModifier;
ADataType : TTypeDefinition
);
property Modifier : TParameterModifier Read FModifier;
property DataType : TTypeDefinition Read FDataType;
End;
TMethodType = ( mtProcedure, mtFunction );
Const
ParameterModifierMAP : Array[TParameterModifier] Of String =
( '', 'Const', 'Var', 'Out' );
Type
{ TMethodDefinition }
TMethodDefinition = class(TAbstractSymbolDefinition)
private
FMethodType: TMethodType;
FParameterList : TObjectList;
function GetParameter(Index: Integer): TParameterDefinition;
function GetParameterCount: Integer;
Public
constructor Create(Const AName : String; Const AMethodType : TMethodType);
destructor Destroy();override;
function AddParameter(
Const AName : String;
Const AModifier : TParameterModifier;
ADataType : TTypeDefinition
):TParameterDefinition;
function GetParameterIndex(Const AName : String):Integer;
function FindParameter(Const AName : String):TParameterDefinition;
property MethodType : TMethodType Read FMethodType;
property ParameterCount : Integer Read GetParameterCount;
property Parameter[Index:Integer] : TParameterDefinition Read GetParameter;
End;
{ TInterfaceDefinition }
TInterfaceDefinition = class(TAbstractSymbolDefinition)
Private
FInterfaceGUID: string;
FMethodList : TObjectList;
function GetMethod(Index: Integer): TMethodDefinition;
function GetMethodCount: Integer;
Public
constructor Create(Const AName : String);
destructor Destroy();override;
function GetMethodIndex(Const AName : String):Integer;
function FindMethod(Const AName : String):TMethodDefinition;
function AddMethod(
Const AName : String;
Const AMethodType : TMethodType
):TMethodDefinition;
Property MethodCount : Integer Read GetMethodCount;
Property Method[Index:Integer] : TMethodDefinition Read GetMethod;
property InterfaceGUID : string read FInterfaceGUID write FInterfaceGUID;
End;
{ TSymbolTable }
TSymbolTable = class(TAbstractSymbolDefinition)
Private
FList : TObjectList;
procedure CheckIndex(Const AIndex : Integer);
function GetCount: Integer;
function GetItem(Index: Integer): TAbstractSymbolDefinition;
procedure SetName(const AValue: String);
Public
constructor Create(Const AName : String);
destructor Destroy();override;
procedure Clear();
function Add(ASym : TAbstractSymbolDefinition):Integer;
function IndexOf(Const AName : String):Integer;overload;
function IndexOf(ASym : TAbstractSymbolDefinition):Integer;overload;
function Find(Const AName : String):TAbstractSymbolDefinition;
function ByName(Const AName : String):TAbstractSymbolDefinition;
Property Name : String Read FName Write SetName;
Property Count : Integer Read GetCount;
Property Item[Index:Integer] : TAbstractSymbolDefinition Read GetItem;
End;
implementation
uses StrUtils, parserutils;
{ TAbstractSymbolDefinition }
constructor TAbstractSymbolDefinition.Create(const AName: String);
begin
Assert(Not IsStrEmpty(AName));
FName := AName;
end;
{ TParameterDefinition }
constructor TParameterDefinition.Create(
const AName: String;
const AModifier: TParameterModifier;
ADataType: TTypeDefinition
);
begin
Inherited Create(AName);
Assert(Assigned(ADataType));
FModifier := AModifier;
FDataType := ADataType;
end;
{ TMethodDefinition }
function TMethodDefinition.GetParameter(Index: Integer): TParameterDefinition;
begin
Result := FParameterList[Index] As TParameterDefinition;
end;
function TMethodDefinition.GetParameterCount: Integer;
begin
Result := FParameterList.Count;
end;
constructor TMethodDefinition.Create(
const AName: String;
const AMethodType: TMethodType
);
begin
Inherited Create(AName);
FMethodType := AMethodType;
FParameterList := TObjectList.create(True);
end;
destructor TMethodDefinition.Destroy();
begin
FreeAndNil(FParameterList);
inherited Destroy();
end;
function TMethodDefinition.AddParameter(
Const AName : String;
Const AModifier : TParameterModifier;
ADataType : TTypeDefinition
): TParameterDefinition;
begin
If ( GetParameterIndex(Name) = -1 ) Then Begin
Result := TParameterDefinition.Create(AName,AModifier,ADataType);
FParameterList.Add(Result);
End Else Begin
Raise ESymbolException.CreateFmt('Duplicated parameter : %s.%s',[Name,AName]);
End;
end;
function TMethodDefinition.GetParameterIndex(const AName: String): Integer;
begin
For Result := 0 To Pred(ParameterCount) Do
If AnsiSameText(AName,Parameter[Result].Name) Then
Exit;
Result := -1;
end;
function TMethodDefinition.FindParameter(
const AName: String
): TParameterDefinition;
Var
i : Integer;
begin
i := GetParameterIndex(AName);
If ( i > -1 ) Then
Result := Parameter[i]
Else
Result := Nil;
end;
{ TInterfaceDefinition }
function TInterfaceDefinition.GetMethod(Index: Integer): TMethodDefinition;
begin
Result := FMethodList[Index] As TMethodDefinition;
end;
function TInterfaceDefinition.GetMethodCount: Integer;
begin
Result := FMethodList.Count;
end;
constructor TInterfaceDefinition.Create(const AName: String);
begin
Inherited Create(AName);
FMethodList := TObjectList.create(True);
end;
destructor TInterfaceDefinition.Destroy();
begin
FreeAndNil(FMethodList);
inherited Destroy();
end;
function TInterfaceDefinition.GetMethodIndex(const AName: String): Integer;
begin
For Result := 0 To Pred(MethodCount) Do
If AnsiSameText(AName,Method[Result].Name) Then
Exit;
Result := -1;
end;
function TInterfaceDefinition.FindMethod(const AName: String): TMethodDefinition;
Var
i : Integer;
begin
i := GetMethodIndex(AName);
If ( i > -1 ) Then
Result := Method[i]
Else
Result := Nil;
end;
function TInterfaceDefinition.AddMethod(
Const AName : String;
Const AMethodType : TMethodType
):TMethodDefinition;
begin
If ( GetMethodIndex(Name) = -1 ) Then Begin
Result := TMethodDefinition.Create(AName,AMethodType);
FMethodList.Add(Result);
End Else Begin
Raise ESymbolException.CreateFmt('Duplicated methode : %s.%s',[Name,AName]);
End;
end;
{ TSymbolTable }
procedure TSymbolTable.CheckIndex(const AIndex: Integer);
begin
If ( AIndex < 0 ) Or ( AIndex >= Count ) Then
Raise ESymbolException.CreateFmt('Invalid Table Index : %d',[AIndex]);
end;
function TSymbolTable.GetCount: Integer;
begin
Result := FList.Count;
end;
function TSymbolTable.GetItem(Index: Integer): TAbstractSymbolDefinition;
begin
CheckIndex(Index);
Result := FList[Index] As TAbstractSymbolDefinition;
end;
procedure TSymbolTable.SetName(const AValue: String);
begin
if ( FName = AValue ) then exit;
FName := AValue;
end;
constructor TSymbolTable.Create(Const AName : String);
begin
Inherited Create(AName);
FList := TObjectList.Create(True);
end;
destructor TSymbolTable.Destroy();
begin
FList.Free();
inherited Destroy();
end;
procedure TSymbolTable.Clear();
begin
FList.Clear();
end;
function TSymbolTable.Add(ASym: TAbstractSymbolDefinition): Integer;
begin
Result := IndexOf(ASym);
If ( Result = -1 ) Then Begin
If ( IndexOf(ASym.Name) <> -1 ) Then
Raise ESymbolException.CreateFmt('Duplicated symbol name : %s',[ASym.Name]);
Result := FList.Add(ASym);
End;
end;
function TSymbolTable.IndexOf(const AName: String): Integer;
begin
For Result := 0 To Pred(Count) Do
If AnsiSameText(AName,Item[Result].Name) Then
Exit;
Result := -1;
end;
function TSymbolTable.IndexOf(ASym: TAbstractSymbolDefinition): Integer;
begin
Result := FList.IndexOf(ASym);
end;
function TSymbolTable.Find(const AName: String): TAbstractSymbolDefinition;
Var
i : Integer;
begin
i := IndexOf(AName);
If ( i > -1 ) Then
Result := Item[i]
Else
Result := Nil;
end;
function TSymbolTable.ByName(const AName: String): TAbstractSymbolDefinition;
begin
Result := Find(AName);
If Not Assigned(Result) Then
Raise ESymbolException.CreateFmt('No such Symbol : %s',[AName]);
end;
{ TEnumItemDefinition }
constructor TEnumItemDefinition.Create(const AName: String; Const AOrder: Integer);
begin
Inherited Create(AName);
FOrder := AOrder;
end;
{ TEnumTypeDefinition }
function TEnumTypeDefinition.GetItem(Index: Integer): TEnumItemDefinition;
begin
Result := FItemList[Index] As TEnumItemDefinition;
end;
function TEnumTypeDefinition.GetItemCount: Integer;
begin
Result := FItemList.Count;
end;
constructor TEnumTypeDefinition.Create(const AName: String);
begin
Inherited Create(AName);
FItemList := TObjectList.Create(False);
end;
destructor TEnumTypeDefinition.Destroy();
begin
FItemList.Free();
inherited Destroy();
end;
function TEnumTypeDefinition.NeedFinalization(): Boolean;
begin
Result := False;
end;
procedure TEnumTypeDefinition.AddItem(AItem:TEnumItemDefinition);
Begin
If ( FItemList.IndexOf(AItem) = -1 ) Then
FItemList.Add(AItem);
end;
function TEnumTypeDefinition.FindItem(const AName: String): TEnumItemDefinition;
Var
i,c : Integer;
begin
c := Pred(ItemCount);
For i := 0 To c Do Begin
If AnsiSameText(AName,Item[i].Name) Then Begin
Result := Item[i];
Exit;
End;
End;
Result := Nil;
end;
{ TTypeDefinition }
const SIMPLE_TYPES : Array[0..12] Of string = (
'string', 'integer', 'smallint', 'shortint', 'char', 'boolean',
'byte', 'word', 'longint', 'int64',
'single', 'double', 'extended'
);
function TTypeDefinition.NeedFinalization(): Boolean;
begin
Result := ( AnsiIndexText(Name,SIMPLE_TYPES) = -1 );
end;
{ TClassTypeDefinition }
function TClassTypeDefinition.NeedFinalization(): Boolean;
begin
Result := True;
end;
end.

42
wst/tags/3.1/ws_helper/parserutils.pas Normal file
View File

@ -0,0 +1,42 @@
{
This unit is part of the Web Service Toolkit
Copyright (c) 2006 by Inoussa OUEDRAOGO
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
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. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
}
unit parserutils;
{$mode objfpc}{$H+}
interface
uses
SysUtils;
const
sNEW_LINE = {$ifndef Unix}#13#10{$else}#10{$endif};
function IsStrEmpty(Const AStr : String):Boolean;
implementation
function IsStrEmpty(Const AStr : String):Boolean;
begin
Result := ( Length(Trim(AStr)) = 0 );
end;
end.

307
wst/tags/3.1/ws_helper/source_utils.pas Normal file
View File

@ -0,0 +1,307 @@
{
This unit is part of the Web Service Toolkit
Copyright (c) 2006 by Inoussa OUEDRAOGO
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
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. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
}
unit source_utils;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils;
Type
EsourceException = class(Exception)
End;
ISourceStream = Interface
function GetFileName():string;
procedure SaveToFile(const APath : string);
procedure Indent();
function IncIndent():Integer;
function DecIndent():Integer;
procedure Write(AText : String);overload;
procedure Write(AText : String; Const AArgs : array of const);overload;
procedure WriteLn(AText : String);overload;
procedure WriteLn(AText : String; Const AArgs : array of const);overload;
procedure NewLine();
procedure BeginAutoIndent();
procedure EndAutoIndent();
End;
ISourceManager = Interface
function CreateItem(const AFileName : string):ISourceStream;
function Find(const AFileName : string):ISourceStream;
function Merge(
const AFinalFileName : string;
const ASourceList : array of ISourceStream
) : ISourceStream;
procedure SaveToFile(const APath : string);
End;
function CreateSourceManager():ISourceManager;
implementation
uses StrUtils, parserutils;
Type
ISavableSourceStream = Interface(ISourceStream)
procedure SaveToStream(AStream : TStream);
procedure SaveToFile(const APath : string);
function GetStream(): TStream;
End;
{ TSourceStream }
TSourceStream = class(TInterfacedObject,ISavableSourceStream)
Private
FStream : TMemoryStream;
FIndentCount : Integer;
FAutoIndentCount : Integer;
FFileName : string;
Protected
function GetFileName():string;
procedure SaveToStream(AStream : TStream);
function GetStream(): TStream;
procedure SaveToFile(const APath : string);
procedure Indent();
function IncIndent():Integer;
function DecIndent():Integer;
procedure Write(AText : String);overload;
procedure Write(AText : String; Const AArgs : array of const);overload;
procedure WriteLn(AText : String);overload;
procedure WriteLn(AText : String; Const AArgs : array of const);overload;
procedure NewLine();
procedure BeginAutoIndent();
procedure EndAutoIndent();
function IsInAutoInden():Boolean;
Public
constructor Create(const AFileName:string);
destructor Destroy();override;
End;
{ TSourceManager }
TSourceManager = class(TInterfacedObject,ISourceManager)
Private
FList : IInterfaceList;
Private
procedure Error(AText : String);overload;
procedure Error(AText : String; Const AArgs : array of const);overload;
function GetCount():Integer;
function GetItem(const AIndex:Integer):ISourceStream;
Protected
function CreateItem(const AFileName : string):ISourceStream;
function Find(const AFileName : string):ISourceStream;
procedure SaveToFile(const APath : string);
function Merge(
const AFinalFileName : string;
const ASourceList : array of ISourceStream
) : ISourceStream;
Public
constructor Create();
End;
function CreateSourceManager():ISourceManager;
begin
Result := TSourceManager.Create() as ISourceManager;
end;
{ TSourceManager }
procedure TSourceManager.Error(AText: String);
begin
Raise EsourceException.Create(AText);
end;
procedure TSourceManager.Error(AText: String; const AArgs: array of const);
begin
Raise EsourceException.CreateFmt(AText,AArgs);
end;
function TSourceManager.GetCount(): Integer;
begin
Result := FList.Count;
end;
function TSourceManager.GetItem(const AIndex: Integer): ISourceStream;
begin
Result := FList[AIndex] as ISourceStream;
end;
function TSourceManager.CreateItem(const AFileName: string): ISourceStream;
begin
If Assigned(Find(AFileName)) Then
Error('A file named "%s" allready exists.',[AFileName]);
Result := TSourceStream.Create(AFileName) as ISourceStream;
FList.Add(Result);
end;
function TSourceManager.Find(const AFileName: string): ISourceStream;
Var
i : Integer;
s : string;
begin
s := LowerCase(AFileName);
For i := 0 To Pred(GetCount()) Do Begin
Result := GetItem(i);
If AnsiSameText(s,Result.GetFileName()) Then
Exit;
End;
Result := Nil;
end;
procedure TSourceManager.SaveToFile(const APath: string);
Var
i : Integer;
begin
For i := 0 To Pred(GetCount()) Do Begin
(GetItem(i) As ISavableSourceStream).SaveToFile(APath);
End;
end;
function TSourceManager.Merge(const AFinalFileName: string;const ASourceList: array of ISourceStream): ISourceStream;
Var
i : Integer;
s : TStream;
begin
Result := CreateItem(AFinalFileName);
s := (Result as ISavableSourceStream).GetStream();
For i := Low(ASourceList) To High(ASourceList) Do Begin
(ASourceList[i] as ISavableSourceStream).SaveToStream(s);
FList.Remove(ASourceList[i]);
End;
end;
constructor TSourceManager.Create();
begin
FList := TInterfaceList.Create() as IInterfaceList;
end;
{ TSourceStream }
function TSourceStream.GetFileName(): string;
begin
Result := FFileName;
end;
procedure TSourceStream.SaveToStream(AStream: TStream);
begin
AStream.CopyFrom(FStream,0);
end;
function TSourceStream.GetStream(): TStream;
begin
Result := FStream;
end;
procedure TSourceStream.SaveToFile(const APath: string);
begin
FStream.SaveToFile(IncludeTrailingPathDelimiter(APath) + GetFileName());
end;
procedure TSourceStream.Indent();
Const INDENT_STR = ' ';
Var
s : string;
begin
If ( FIndentCount > 0 ) Then Begin
s := DupeString(INDENT_STR,FIndentCount);
FStream.Write(s[1],Length(s));
End;
end;
function TSourceStream.IncIndent():Integer;
begin
Inc(FIndentCount);
Result := FIndentCount;
end;
function TSourceStream.DecIndent():Integer;
begin
Assert(FIndentCount>0);
Dec(FIndentCount);
Result := FIndentCount;
end;
procedure TSourceStream.Write(AText: String);
Var
i : Integer;
begin
If IsInAutoInden() Then
Indent();
i := Length(AText);
If ( i > 0 ) Then
FStream.Write(AText[1],i);
end;
procedure TSourceStream.Write(AText: String; const AArgs: array of const);
begin
Write(Format(AText,AArgs));
end;
procedure TSourceStream.WriteLn(AText: String);
begin
Write(AText+sNEW_LINE);
end;
procedure TSourceStream.WriteLn(AText: String; const AArgs: array of const);
begin
Write(AText+sNEW_LINE,AArgs);
end;
procedure TSourceStream.NewLine();
begin
WriteLn('');
end;
procedure TSourceStream.BeginAutoIndent();
begin
Inc(FAutoIndentCount);
end;
procedure TSourceStream.EndAutoIndent();
begin
Assert(FAutoIndentCount>0);
Dec(FAutoIndentCount);
end;
function TSourceStream.IsInAutoInden(): Boolean;
begin
Result := ( FAutoIndentCount > 0 );
end;
constructor TSourceStream.Create(const AFileName: string);
begin
FFileName := AFileName;
FStream := TMemoryStream.Create();
FIndentCount := 0;
FAutoIndentCount := 0;
end;
destructor TSourceStream.Destroy();
begin
FreeAndNil(FStream);
inherited Destroy();
end;
end.

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