Initial commit
This commit is contained in:
commit
c128b16996
674
LICENSE
Normal file
674
LICENSE
Normal file
@ -0,0 +1,674 @@
|
||||
GNU GENERAL PUBLIC LICENSE
|
||||
Version 3, 29 June 2007
|
||||
|
||||
Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>
|
||||
Everyone is permitted to copy and distribute verbatim copies
|
||||
of this license document, but changing it is not allowed.
|
||||
|
||||
Preamble
|
||||
|
||||
The GNU General Public License is a free, copyleft license for
|
||||
software and other kinds of works.
|
||||
|
||||
The licenses for most software and other practical works are designed
|
||||
to take away your freedom to share and change the works. By contrast,
|
||||
the GNU General Public License is intended to guarantee your freedom to
|
||||
share and change all versions of a program--to make sure it remains free
|
||||
software for all its users. We, the Free Software Foundation, use the
|
||||
GNU General Public License for most of our software; it applies also to
|
||||
any other work released this way by its authors. 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
|
||||
them 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 prevent others from denying you
|
||||
these rights or asking you to surrender the rights. Therefore, you have
|
||||
certain responsibilities if you distribute copies of the software, or if
|
||||
you modify it: responsibilities to respect the freedom of others.
|
||||
|
||||
For example, if you distribute copies of such a program, whether
|
||||
gratis or for a fee, you must pass on to the recipients the same
|
||||
freedoms that you received. 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.
|
||||
|
||||
Developers that use the GNU GPL protect your rights with two steps:
|
||||
(1) assert copyright on the software, and (2) offer you this License
|
||||
giving you legal permission to copy, distribute and/or modify it.
|
||||
|
||||
For the developers' and authors' protection, the GPL clearly explains
|
||||
that there is no warranty for this free software. For both users' and
|
||||
authors' sake, the GPL requires that modified versions be marked as
|
||||
changed, so that their problems will not be attributed erroneously to
|
||||
authors of previous versions.
|
||||
|
||||
Some devices are designed to deny users access to install or run
|
||||
modified versions of the software inside them, although the manufacturer
|
||||
can do so. This is fundamentally incompatible with the aim of
|
||||
protecting users' freedom to change the software. The systematic
|
||||
pattern of such abuse occurs in the area of products for individuals to
|
||||
use, which is precisely where it is most unacceptable. Therefore, we
|
||||
have designed this version of the GPL to prohibit the practice for those
|
||||
products. If such problems arise substantially in other domains, we
|
||||
stand ready to extend this provision to those domains in future versions
|
||||
of the GPL, as needed to protect the freedom of users.
|
||||
|
||||
Finally, every program is threatened constantly by software patents.
|
||||
States should not allow patents to restrict development and use of
|
||||
software on general-purpose computers, but in those that do, we wish to
|
||||
avoid the special danger that patents applied to a free program could
|
||||
make it effectively proprietary. To prevent this, the GPL assures that
|
||||
patents cannot be used to render the program non-free.
|
||||
|
||||
The precise terms and conditions for copying, distribution and
|
||||
modification follow.
|
||||
|
||||
TERMS AND CONDITIONS
|
||||
|
||||
0. Definitions.
|
||||
|
||||
"This License" refers to version 3 of the GNU General Public License.
|
||||
|
||||
"Copyright" also means copyright-like laws that apply to other kinds of
|
||||
works, such as semiconductor masks.
|
||||
|
||||
"The Program" refers to any copyrightable work licensed under this
|
||||
License. Each licensee is addressed as "you". "Licensees" and
|
||||
"recipients" may be individuals or organizations.
|
||||
|
||||
To "modify" a work means to copy from or adapt all or part of the work
|
||||
in a fashion requiring copyright permission, other than the making of an
|
||||
exact copy. The resulting work is called a "modified version" of the
|
||||
earlier work or a work "based on" the earlier work.
|
||||
|
||||
A "covered work" means either the unmodified Program or a work based
|
||||
on the Program.
|
||||
|
||||
To "propagate" a work means to do anything with it that, without
|
||||
permission, would make you directly or secondarily liable for
|
||||
infringement under applicable copyright law, except executing it on a
|
||||
computer or modifying a private copy. Propagation includes copying,
|
||||
distribution (with or without modification), making available to the
|
||||
public, and in some countries other activities as well.
|
||||
|
||||
To "convey" a work means any kind of propagation that enables other
|
||||
parties to make or receive copies. Mere interaction with a user through
|
||||
a computer network, with no transfer of a copy, is not conveying.
|
||||
|
||||
An interactive user interface displays "Appropriate Legal Notices"
|
||||
to the extent that it includes a convenient and prominently visible
|
||||
feature that (1) displays an appropriate copyright notice, and (2)
|
||||
tells the user that there is no warranty for the work (except to the
|
||||
extent that warranties are provided), that licensees may convey the
|
||||
work under this License, and how to view a copy of this License. If
|
||||
the interface presents a list of user commands or options, such as a
|
||||
menu, a prominent item in the list meets this criterion.
|
||||
|
||||
1. Source Code.
|
||||
|
||||
The "source code" for a work means the preferred form of the work
|
||||
for making modifications to it. "Object code" means any non-source
|
||||
form of a work.
|
||||
|
||||
A "Standard Interface" means an interface that either is an official
|
||||
standard defined by a recognized standards body, or, in the case of
|
||||
interfaces specified for a particular programming language, one that
|
||||
is widely used among developers working in that language.
|
||||
|
||||
The "System Libraries" of an executable work include anything, other
|
||||
than the work as a whole, that (a) is included in the normal form of
|
||||
packaging a Major Component, but which is not part of that Major
|
||||
Component, and (b) serves only to enable use of the work with that
|
||||
Major Component, or to implement a Standard Interface for which an
|
||||
implementation is available to the public in source code form. A
|
||||
"Major Component", in this context, means a major essential component
|
||||
(kernel, window system, and so on) of the specific operating system
|
||||
(if any) on which the executable work runs, or a compiler used to
|
||||
produce the work, or an object code interpreter used to run it.
|
||||
|
||||
The "Corresponding Source" for a work in object code form means all
|
||||
the source code needed to generate, install, and (for an executable
|
||||
work) run the object code and to modify the work, including scripts to
|
||||
control those activities. However, it does not include the work's
|
||||
System Libraries, or general-purpose tools or generally available free
|
||||
programs which are used unmodified in performing those activities but
|
||||
which are not part of the work. For example, Corresponding Source
|
||||
includes interface definition files associated with source files for
|
||||
the work, and the source code for shared libraries and dynamically
|
||||
linked subprograms that the work is specifically designed to require,
|
||||
such as by intimate data communication or control flow between those
|
||||
subprograms and other parts of the work.
|
||||
|
||||
The Corresponding Source need not include anything that users
|
||||
can regenerate automatically from other parts of the Corresponding
|
||||
Source.
|
||||
|
||||
The Corresponding Source for a work in source code form is that
|
||||
same work.
|
||||
|
||||
2. Basic Permissions.
|
||||
|
||||
All rights granted under this License are granted for the term of
|
||||
copyright on the Program, and are irrevocable provided the stated
|
||||
conditions are met. This License explicitly affirms your unlimited
|
||||
permission to run the unmodified Program. The output from running a
|
||||
covered work is covered by this License only if the output, given its
|
||||
content, constitutes a covered work. This License acknowledges your
|
||||
rights of fair use or other equivalent, as provided by copyright law.
|
||||
|
||||
You may make, run and propagate covered works that you do not
|
||||
convey, without conditions so long as your license otherwise remains
|
||||
in force. You may convey covered works to others for the sole purpose
|
||||
of having them make modifications exclusively for you, or provide you
|
||||
with facilities for running those works, provided that you comply with
|
||||
the terms of this License in conveying all material for which you do
|
||||
not control copyright. Those thus making or running the covered works
|
||||
for you must do so exclusively on your behalf, under your direction
|
||||
and control, on terms that prohibit them from making any copies of
|
||||
your copyrighted material outside their relationship with you.
|
||||
|
||||
Conveying under any other circumstances is permitted solely under
|
||||
the conditions stated below. Sublicensing is not allowed; section 10
|
||||
makes it unnecessary.
|
||||
|
||||
3. Protecting Users' Legal Rights From Anti-Circumvention Law.
|
||||
|
||||
No covered work shall be deemed part of an effective technological
|
||||
measure under any applicable law fulfilling obligations under article
|
||||
11 of the WIPO copyright treaty adopted on 20 December 1996, or
|
||||
similar laws prohibiting or restricting circumvention of such
|
||||
measures.
|
||||
|
||||
When you convey a covered work, you waive any legal power to forbid
|
||||
circumvention of technological measures to the extent such circumvention
|
||||
is effected by exercising rights under this License with respect to
|
||||
the covered work, and you disclaim any intention to limit operation or
|
||||
modification of the work as a means of enforcing, against the work's
|
||||
users, your or third parties' legal rights to forbid circumvention of
|
||||
technological measures.
|
||||
|
||||
4. Conveying Verbatim Copies.
|
||||
|
||||
You may convey 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;
|
||||
keep intact all notices stating that this License and any
|
||||
non-permissive terms added in accord with section 7 apply to the code;
|
||||
keep intact all notices of the absence of any warranty; and give all
|
||||
recipients a copy of this License along with the Program.
|
||||
|
||||
You may charge any price or no price for each copy that you convey,
|
||||
and you may offer support or warranty protection for a fee.
|
||||
|
||||
5. Conveying Modified Source Versions.
|
||||
|
||||
You may convey a work based on the Program, or the modifications to
|
||||
produce it from the Program, in the form of source code under the
|
||||
terms of section 4, provided that you also meet all of these conditions:
|
||||
|
||||
a) The work must carry prominent notices stating that you modified
|
||||
it, and giving a relevant date.
|
||||
|
||||
b) The work must carry prominent notices stating that it is
|
||||
released under this License and any conditions added under section
|
||||
7. This requirement modifies the requirement in section 4 to
|
||||
"keep intact all notices".
|
||||
|
||||
c) You must license the entire work, as a whole, under this
|
||||
License to anyone who comes into possession of a copy. This
|
||||
License will therefore apply, along with any applicable section 7
|
||||
additional terms, to the whole of the work, and all its parts,
|
||||
regardless of how they are packaged. This License gives no
|
||||
permission to license the work in any other way, but it does not
|
||||
invalidate such permission if you have separately received it.
|
||||
|
||||
d) If the work has interactive user interfaces, each must display
|
||||
Appropriate Legal Notices; however, if the Program has interactive
|
||||
interfaces that do not display Appropriate Legal Notices, your
|
||||
work need not make them do so.
|
||||
|
||||
A compilation of a covered work with other separate and independent
|
||||
works, which are not by their nature extensions of the covered work,
|
||||
and which are not combined with it such as to form a larger program,
|
||||
in or on a volume of a storage or distribution medium, is called an
|
||||
"aggregate" if the compilation and its resulting copyright are not
|
||||
used to limit the access or legal rights of the compilation's users
|
||||
beyond what the individual works permit. Inclusion of a covered work
|
||||
in an aggregate does not cause this License to apply to the other
|
||||
parts of the aggregate.
|
||||
|
||||
6. Conveying Non-Source Forms.
|
||||
|
||||
You may convey a covered work in object code form under the terms
|
||||
of sections 4 and 5, provided that you also convey the
|
||||
machine-readable Corresponding Source under the terms of this License,
|
||||
in one of these ways:
|
||||
|
||||
a) Convey the object code in, or embodied in, a physical product
|
||||
(including a physical distribution medium), accompanied by the
|
||||
Corresponding Source fixed on a durable physical medium
|
||||
customarily used for software interchange.
|
||||
|
||||
b) Convey the object code in, or embodied in, a physical product
|
||||
(including a physical distribution medium), accompanied by a
|
||||
written offer, valid for at least three years and valid for as
|
||||
long as you offer spare parts or customer support for that product
|
||||
model, to give anyone who possesses the object code either (1) a
|
||||
copy of the Corresponding Source for all the software in the
|
||||
product that is covered by this License, on a durable physical
|
||||
medium customarily used for software interchange, for a price no
|
||||
more than your reasonable cost of physically performing this
|
||||
conveying of source, or (2) access to copy the
|
||||
Corresponding Source from a network server at no charge.
|
||||
|
||||
c) Convey individual copies of the object code with a copy of the
|
||||
written offer to provide the Corresponding Source. This
|
||||
alternative is allowed only occasionally and noncommercially, and
|
||||
only if you received the object code with such an offer, in accord
|
||||
with subsection 6b.
|
||||
|
||||
d) Convey the object code by offering access from a designated
|
||||
place (gratis or for a charge), and offer equivalent access to the
|
||||
Corresponding Source in the same way through the same place at no
|
||||
further charge. You need not require recipients to copy the
|
||||
Corresponding Source along with the object code. If the place to
|
||||
copy the object code is a network server, the Corresponding Source
|
||||
may be on a different server (operated by you or a third party)
|
||||
that supports equivalent copying facilities, provided you maintain
|
||||
clear directions next to the object code saying where to find the
|
||||
Corresponding Source. Regardless of what server hosts the
|
||||
Corresponding Source, you remain obligated to ensure that it is
|
||||
available for as long as needed to satisfy these requirements.
|
||||
|
||||
e) Convey the object code using peer-to-peer transmission, provided
|
||||
you inform other peers where the object code and Corresponding
|
||||
Source of the work are being offered to the general public at no
|
||||
charge under subsection 6d.
|
||||
|
||||
A separable portion of the object code, whose source code is excluded
|
||||
from the Corresponding Source as a System Library, need not be
|
||||
included in conveying the object code work.
|
||||
|
||||
A "User Product" is either (1) a "consumer product", which means any
|
||||
tangible personal property which is normally used for personal, family,
|
||||
or household purposes, or (2) anything designed or sold for incorporation
|
||||
into a dwelling. In determining whether a product is a consumer product,
|
||||
doubtful cases shall be resolved in favor of coverage. For a particular
|
||||
product received by a particular user, "normally used" refers to a
|
||||
typical or common use of that class of product, regardless of the status
|
||||
of the particular user or of the way in which the particular user
|
||||
actually uses, or expects or is expected to use, the product. A product
|
||||
is a consumer product regardless of whether the product has substantial
|
||||
commercial, industrial or non-consumer uses, unless such uses represent
|
||||
the only significant mode of use of the product.
|
||||
|
||||
"Installation Information" for a User Product means any methods,
|
||||
procedures, authorization keys, or other information required to install
|
||||
and execute modified versions of a covered work in that User Product from
|
||||
a modified version of its Corresponding Source. The information must
|
||||
suffice to ensure that the continued functioning of the modified object
|
||||
code is in no case prevented or interfered with solely because
|
||||
modification has been made.
|
||||
|
||||
If you convey an object code work under this section in, or with, or
|
||||
specifically for use in, a User Product, and the conveying occurs as
|
||||
part of a transaction in which the right of possession and use of the
|
||||
User Product is transferred to the recipient in perpetuity or for a
|
||||
fixed term (regardless of how the transaction is characterized), the
|
||||
Corresponding Source conveyed under this section must be accompanied
|
||||
by the Installation Information. But this requirement does not apply
|
||||
if neither you nor any third party retains the ability to install
|
||||
modified object code on the User Product (for example, the work has
|
||||
been installed in ROM).
|
||||
|
||||
The requirement to provide Installation Information does not include a
|
||||
requirement to continue to provide support service, warranty, or updates
|
||||
for a work that has been modified or installed by the recipient, or for
|
||||
the User Product in which it has been modified or installed. Access to a
|
||||
network may be denied when the modification itself materially and
|
||||
adversely affects the operation of the network or violates the rules and
|
||||
protocols for communication across the network.
|
||||
|
||||
Corresponding Source conveyed, and Installation Information provided,
|
||||
in accord with this section must be in a format that is publicly
|
||||
documented (and with an implementation available to the public in
|
||||
source code form), and must require no special password or key for
|
||||
unpacking, reading or copying.
|
||||
|
||||
7. Additional Terms.
|
||||
|
||||
"Additional permissions" are terms that supplement the terms of this
|
||||
License by making exceptions from one or more of its conditions.
|
||||
Additional permissions that are applicable to the entire Program shall
|
||||
be treated as though they were included in this License, to the extent
|
||||
that they are valid under applicable law. If additional permissions
|
||||
apply only to part of the Program, that part may be used separately
|
||||
under those permissions, but the entire Program remains governed by
|
||||
this License without regard to the additional permissions.
|
||||
|
||||
When you convey a copy of a covered work, you may at your option
|
||||
remove any additional permissions from that copy, or from any part of
|
||||
it. (Additional permissions may be written to require their own
|
||||
removal in certain cases when you modify the work.) You may place
|
||||
additional permissions on material, added by you to a covered work,
|
||||
for which you have or can give appropriate copyright permission.
|
||||
|
||||
Notwithstanding any other provision of this License, for material you
|
||||
add to a covered work, you may (if authorized by the copyright holders of
|
||||
that material) supplement the terms of this License with terms:
|
||||
|
||||
a) Disclaiming warranty or limiting liability differently from the
|
||||
terms of sections 15 and 16 of this License; or
|
||||
|
||||
b) Requiring preservation of specified reasonable legal notices or
|
||||
author attributions in that material or in the Appropriate Legal
|
||||
Notices displayed by works containing it; or
|
||||
|
||||
c) Prohibiting misrepresentation of the origin of that material, or
|
||||
requiring that modified versions of such material be marked in
|
||||
reasonable ways as different from the original version; or
|
||||
|
||||
d) Limiting the use for publicity purposes of names of licensors or
|
||||
authors of the material; or
|
||||
|
||||
e) Declining to grant rights under trademark law for use of some
|
||||
trade names, trademarks, or service marks; or
|
||||
|
||||
f) Requiring indemnification of licensors and authors of that
|
||||
material by anyone who conveys the material (or modified versions of
|
||||
it) with contractual assumptions of liability to the recipient, for
|
||||
any liability that these contractual assumptions directly impose on
|
||||
those licensors and authors.
|
||||
|
||||
All other non-permissive additional terms are considered "further
|
||||
restrictions" within the meaning of section 10. If the Program as you
|
||||
received it, or any part of it, contains a notice stating that it is
|
||||
governed by this License along with a term that is a further
|
||||
restriction, you may remove that term. If a license document contains
|
||||
a further restriction but permits relicensing or conveying under this
|
||||
License, you may add to a covered work material governed by the terms
|
||||
of that license document, provided that the further restriction does
|
||||
not survive such relicensing or conveying.
|
||||
|
||||
If you add terms to a covered work in accord with this section, you
|
||||
must place, in the relevant source files, a statement of the
|
||||
additional terms that apply to those files, or a notice indicating
|
||||
where to find the applicable terms.
|
||||
|
||||
Additional terms, permissive or non-permissive, may be stated in the
|
||||
form of a separately written license, or stated as exceptions;
|
||||
the above requirements apply either way.
|
||||
|
||||
8. Termination.
|
||||
|
||||
You may not propagate or modify a covered work except as expressly
|
||||
provided under this License. Any attempt otherwise to propagate or
|
||||
modify it is void, and will automatically terminate your rights under
|
||||
this License (including any patent licenses granted under the third
|
||||
paragraph of section 11).
|
||||
|
||||
However, if you cease all violation of this License, then your
|
||||
license from a particular copyright holder is reinstated (a)
|
||||
provisionally, unless and until the copyright holder explicitly and
|
||||
finally terminates your license, and (b) permanently, if the copyright
|
||||
holder fails to notify you of the violation by some reasonable means
|
||||
prior to 60 days after the cessation.
|
||||
|
||||
Moreover, your license from a particular copyright holder is
|
||||
reinstated permanently if the copyright holder notifies you of the
|
||||
violation by some reasonable means, this is the first time you have
|
||||
received notice of violation of this License (for any work) from that
|
||||
copyright holder, and you cure the violation prior to 30 days after
|
||||
your receipt of the notice.
|
||||
|
||||
Termination of your rights under this section does not terminate the
|
||||
licenses of parties who have received copies or rights from you under
|
||||
this License. If your rights have been terminated and not permanently
|
||||
reinstated, you do not qualify to receive new licenses for the same
|
||||
material under section 10.
|
||||
|
||||
9. Acceptance Not Required for Having Copies.
|
||||
|
||||
You are not required to accept this License in order to receive or
|
||||
run a copy of the Program. Ancillary propagation of a covered work
|
||||
occurring solely as a consequence of using peer-to-peer transmission
|
||||
to receive a copy likewise does not require acceptance. However,
|
||||
nothing other than this License grants you permission to propagate or
|
||||
modify any covered work. These actions infringe copyright if you do
|
||||
not accept this License. Therefore, by modifying or propagating a
|
||||
covered work, you indicate your acceptance of this License to do so.
|
||||
|
||||
10. Automatic Licensing of Downstream Recipients.
|
||||
|
||||
Each time you convey a covered work, the recipient automatically
|
||||
receives a license from the original licensors, to run, modify and
|
||||
propagate that work, subject to this License. You are not responsible
|
||||
for enforcing compliance by third parties with this License.
|
||||
|
||||
An "entity transaction" is a transaction transferring control of an
|
||||
organization, or substantially all assets of one, or subdividing an
|
||||
organization, or merging organizations. If propagation of a covered
|
||||
work results from an entity transaction, each party to that
|
||||
transaction who receives a copy of the work also receives whatever
|
||||
licenses to the work the party's predecessor in interest had or could
|
||||
give under the previous paragraph, plus a right to possession of the
|
||||
Corresponding Source of the work from the predecessor in interest, if
|
||||
the predecessor has it or can get it with reasonable efforts.
|
||||
|
||||
You may not impose any further restrictions on the exercise of the
|
||||
rights granted or affirmed under this License. For example, you may
|
||||
not impose a license fee, royalty, or other charge for exercise of
|
||||
rights granted under this License, and you may not initiate litigation
|
||||
(including a cross-claim or counterclaim in a lawsuit) alleging that
|
||||
any patent claim is infringed by making, using, selling, offering for
|
||||
sale, or importing the Program or any portion of it.
|
||||
|
||||
11. Patents.
|
||||
|
||||
A "contributor" is a copyright holder who authorizes use under this
|
||||
License of the Program or a work on which the Program is based. The
|
||||
work thus licensed is called the contributor's "contributor version".
|
||||
|
||||
A contributor's "essential patent claims" are all patent claims
|
||||
owned or controlled by the contributor, whether already acquired or
|
||||
hereafter acquired, that would be infringed by some manner, permitted
|
||||
by this License, of making, using, or selling its contributor version,
|
||||
but do not include claims that would be infringed only as a
|
||||
consequence of further modification of the contributor version. For
|
||||
purposes of this definition, "control" includes the right to grant
|
||||
patent sublicenses in a manner consistent with the requirements of
|
||||
this License.
|
||||
|
||||
Each contributor grants you a non-exclusive, worldwide, royalty-free
|
||||
patent license under the contributor's essential patent claims, to
|
||||
make, use, sell, offer for sale, import and otherwise run, modify and
|
||||
propagate the contents of its contributor version.
|
||||
|
||||
In the following three paragraphs, a "patent license" is any express
|
||||
agreement or commitment, however denominated, not to enforce a patent
|
||||
(such as an express permission to practice a patent or covenant not to
|
||||
sue for patent infringement). To "grant" such a patent license to a
|
||||
party means to make such an agreement or commitment not to enforce a
|
||||
patent against the party.
|
||||
|
||||
If you convey a covered work, knowingly relying on a patent license,
|
||||
and the Corresponding Source of the work is not available for anyone
|
||||
to copy, free of charge and under the terms of this License, through a
|
||||
publicly available network server or other readily accessible means,
|
||||
then you must either (1) cause the Corresponding Source to be so
|
||||
available, or (2) arrange to deprive yourself of the benefit of the
|
||||
patent license for this particular work, or (3) arrange, in a manner
|
||||
consistent with the requirements of this License, to extend the patent
|
||||
license to downstream recipients. "Knowingly relying" means you have
|
||||
actual knowledge that, but for the patent license, your conveying the
|
||||
covered work in a country, or your recipient's use of the covered work
|
||||
in a country, would infringe one or more identifiable patents in that
|
||||
country that you have reason to believe are valid.
|
||||
|
||||
If, pursuant to or in connection with a single transaction or
|
||||
arrangement, you convey, or propagate by procuring conveyance of, a
|
||||
covered work, and grant a patent license to some of the parties
|
||||
receiving the covered work authorizing them to use, propagate, modify
|
||||
or convey a specific copy of the covered work, then the patent license
|
||||
you grant is automatically extended to all recipients of the covered
|
||||
work and works based on it.
|
||||
|
||||
A patent license is "discriminatory" if it does not include within
|
||||
the scope of its coverage, prohibits the exercise of, or is
|
||||
conditioned on the non-exercise of one or more of the rights that are
|
||||
specifically granted under this License. You may not convey a covered
|
||||
work if you are a party to an arrangement with a third party that is
|
||||
in the business of distributing software, under which you make payment
|
||||
to the third party based on the extent of your activity of conveying
|
||||
the work, and under which the third party grants, to any of the
|
||||
parties who would receive the covered work from you, a discriminatory
|
||||
patent license (a) in connection with copies of the covered work
|
||||
conveyed by you (or copies made from those copies), or (b) primarily
|
||||
for and in connection with specific products or compilations that
|
||||
contain the covered work, unless you entered into that arrangement,
|
||||
or that patent license was granted, prior to 28 March 2007.
|
||||
|
||||
Nothing in this License shall be construed as excluding or limiting
|
||||
any implied license or other defenses to infringement that may
|
||||
otherwise be available to you under applicable patent law.
|
||||
|
||||
12. No Surrender of Others' Freedom.
|
||||
|
||||
If 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 convey a
|
||||
covered work so as to satisfy simultaneously your obligations under this
|
||||
License and any other pertinent obligations, then as a consequence you may
|
||||
not convey it at all. For example, if you agree to terms that obligate you
|
||||
to collect a royalty for further conveying from those to whom you convey
|
||||
the Program, the only way you could satisfy both those terms and this
|
||||
License would be to refrain entirely from conveying the Program.
|
||||
|
||||
13. Use with the GNU Affero General Public License.
|
||||
|
||||
Notwithstanding any other provision of this License, you have
|
||||
permission to link or combine any covered work with a work licensed
|
||||
under version 3 of the GNU Affero General Public License into a single
|
||||
combined work, and to convey the resulting work. The terms of this
|
||||
License will continue to apply to the part which is the covered work,
|
||||
but the special requirements of the GNU Affero General Public License,
|
||||
section 13, concerning interaction through a network will apply to the
|
||||
combination as such.
|
||||
|
||||
14. Revised Versions of this License.
|
||||
|
||||
The Free Software Foundation may publish revised and/or new versions of
|
||||
the GNU 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 that a certain numbered version of the GNU General
|
||||
Public License "or any later version" applies to it, you have the
|
||||
option of following the terms and conditions either of that numbered
|
||||
version or of any later version published by the Free Software
|
||||
Foundation. If the Program does not specify a version number of the
|
||||
GNU General Public License, you may choose any version ever published
|
||||
by the Free Software Foundation.
|
||||
|
||||
If the Program specifies that a proxy can decide which future
|
||||
versions of the GNU General Public License can be used, that proxy's
|
||||
public statement of acceptance of a version permanently authorizes you
|
||||
to choose that version for the Program.
|
||||
|
||||
Later license versions may give you additional or different
|
||||
permissions. However, no additional obligations are imposed on any
|
||||
author or copyright holder as a result of your choosing to follow a
|
||||
later version.
|
||||
|
||||
15. Disclaimer of Warranty.
|
||||
|
||||
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.
|
||||
|
||||
16. Limitation of Liability.
|
||||
|
||||
IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
|
||||
WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS
|
||||
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.
|
||||
|
||||
17. Interpretation of Sections 15 and 16.
|
||||
|
||||
If the disclaimer of warranty and limitation of liability provided
|
||||
above cannot be given local legal effect according to their terms,
|
||||
reviewing courts shall apply local law that most closely approximates
|
||||
an absolute waiver of all civil liability in connection with the
|
||||
Program, unless a warranty or assumption of liability accompanies a
|
||||
copy of the Program in return for a fee.
|
||||
|
||||
END OF TERMS AND CONDITIONS
|
||||
|
||||
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
|
||||
state 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) <year> <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 3 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, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
Also add information on how to contact you by electronic and paper mail.
|
||||
|
||||
If the program does terminal interaction, make it output a short
|
||||
notice like this when it starts in an interactive mode:
|
||||
|
||||
<program> Copyright (C) <year> <name of author>
|
||||
This program 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, your program's commands
|
||||
might be different; for a GUI interface, you would use an "about box".
|
||||
|
||||
You should also get your employer (if you work as a programmer) or school,
|
||||
if any, to sign a "copyright disclaimer" for the program, if necessary.
|
||||
For more information on this, and how to apply and follow the GNU GPL, see
|
||||
<http://www.gnu.org/licenses/>.
|
||||
|
||||
The GNU 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 Lesser General
|
||||
Public License instead of this License. But first, please read
|
||||
<http://www.gnu.org/philosophy/why-not-lgpl.html>.
|
28
jtemplate/LICENSE
Normal file
28
jtemplate/LICENSE
Normal file
@ -0,0 +1,28 @@
|
||||
JTemplate plugin.
|
||||
|
||||
Copyright (C) 2013 Silvio Clecio - silvioprog@gmail.com
|
||||
|
||||
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 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.
|
||||
|
||||
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 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 Software Foundation,
|
||||
Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
|
496
jtemplate/jtemplate.pas
Normal file
496
jtemplate/jtemplate.pas
Normal file
@ -0,0 +1,496 @@
|
||||
(*
|
||||
J-Template plugin.
|
||||
Copyright (C) 2012-2014 Silvio Clecio.
|
||||
|
||||
Please see the LICENSE, README and AUTHORS files.
|
||||
*)
|
||||
|
||||
unit JTemplate;
|
||||
|
||||
{$mode objfpc}{$H+}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
SysUtils, StrUtils, Classes, FPJSON;
|
||||
|
||||
type
|
||||
EJTemplate = class(Exception);
|
||||
|
||||
TJTemplateParserClass = class of TJTemplateParser;
|
||||
|
||||
TJTemplateStreamClass = class of TJTemplateStream;
|
||||
|
||||
TJTemplateLoadingFieldsEvent = procedure(Sender: TObject;
|
||||
var AVar, AValue: string) of object;
|
||||
|
||||
TJTemplateReplacingEvent = procedure(Sender: TObject;
|
||||
var AValue: string) of object;
|
||||
|
||||
{ TJTemplateParser }
|
||||
|
||||
TJTemplateParser = class
|
||||
private
|
||||
FContent: string;
|
||||
FFields: TJSONObject;
|
||||
FHtmlSupports: Boolean;
|
||||
FOnLoadingFields: TJTemplateLoadingFieldsEvent;
|
||||
FOnReplace: TNotifyEvent;
|
||||
FOnReplacing: TJTemplateReplacingEvent;
|
||||
FTagEscape: ShortString;
|
||||
FTagPrefix: ShortString;
|
||||
FTagSuffix: ShortString;
|
||||
public
|
||||
constructor Create; virtual;
|
||||
destructor Destroy; override;
|
||||
procedure Replace(const ARecursive: Boolean = False); virtual;
|
||||
property Content: string read FContent write FContent;
|
||||
property Fields: TJSONObject read FFields write FFields;
|
||||
property HtmlSupports: Boolean read FHtmlSupports write FHtmlSupports;
|
||||
property TagPrefix: ShortString read FTagPrefix write FTagPrefix;
|
||||
property TagSuffix: ShortString read FTagSuffix write FTagSuffix;
|
||||
property TagEscape: ShortString read FTagEscape write FTagEscape;
|
||||
property OnLoadingFields: TJTemplateLoadingFieldsEvent read FOnLoadingFields
|
||||
write FOnLoadingFields;
|
||||
property OnReplacing: TJTemplateReplacingEvent read FOnReplacing
|
||||
write FOnReplacing;
|
||||
property OnReplace: TNotifyEvent read FOnReplace write FOnReplace;
|
||||
end;
|
||||
|
||||
{ TJTemplateStream }
|
||||
|
||||
TJTemplateStream = class
|
||||
private
|
||||
FParser: TJTemplateParser;
|
||||
protected
|
||||
function CreateParser: TJTemplateParser; virtual;
|
||||
procedure FreeParser; virtual;
|
||||
function GetParserClass: TJTemplateParserClass; virtual;
|
||||
public
|
||||
constructor Create; virtual;
|
||||
destructor Destroy; override;
|
||||
procedure LoadFromStream(AStream: TStream);
|
||||
procedure LoadFromFile(const AFileName: TFileName);
|
||||
procedure SaveToStream(AStream: TStream);
|
||||
procedure SaveToFile(const AFileName: TFileName);
|
||||
property Parser: TJTemplateParser read FParser write FParser;
|
||||
end;
|
||||
|
||||
{ TJTemplate }
|
||||
|
||||
TJTemplate = class(TComponent)
|
||||
private
|
||||
FContent: TStrings;
|
||||
FOnLoadingFields: TJTemplateLoadingFieldsEvent;
|
||||
FOnReplace: TNotifyEvent;
|
||||
FOnReplacing: TJTemplateReplacingEvent;
|
||||
FStream: TJTemplateStream;
|
||||
function GetContent: TStrings;
|
||||
function GetFields: TJSONObject;
|
||||
function GetHtmlSupports: Boolean;
|
||||
function GetParser: TJTemplateParser;
|
||||
function GetStream: TJTemplateStream;
|
||||
function GetTagEscape: string;
|
||||
function GetTagPrefix: string;
|
||||
function GetTagSuffix: string;
|
||||
procedure SetContent(AValue: TStrings);
|
||||
procedure SetFields(AValue: TJSONObject);
|
||||
procedure SetHtmlSupports(AValue: Boolean);
|
||||
procedure SetParser(AValue: TJTemplateParser);
|
||||
procedure SetStream(AValue: TJTemplateStream);
|
||||
procedure SetTagEscape(AValue: string);
|
||||
procedure SetTagPrefix(AValue: string);
|
||||
procedure SetTagSuffix(AValue: string);
|
||||
protected
|
||||
procedure Loaded; override;
|
||||
function CreateStream: TJTemplateStream; virtual;
|
||||
procedure FreeStream; virtual;
|
||||
function GetStreamClass: TJTemplateStreamClass;
|
||||
public
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
destructor Destroy; override;
|
||||
procedure Replace(const ARecursive: Boolean = False);
|
||||
procedure LoadFromStream(AStream: TStream);
|
||||
procedure LoadFromFile(const AFileName: TFileName);
|
||||
procedure SaveToStream(AStream: TStream);
|
||||
procedure SaveToFile(const AFileName: TFileName);
|
||||
property Fields: TJSONObject read GetFields write SetFields;
|
||||
property Parser: TJTemplateParser read GetParser write SetParser;
|
||||
property Stream: TJTemplateStream read GetStream write SetStream;
|
||||
published
|
||||
property Content: TStrings read GetContent write SetContent;
|
||||
property HtmlSupports: Boolean read GetHtmlSupports write SetHtmlSupports;
|
||||
property TagPrefix: string read GetTagPrefix write SetTagPrefix;
|
||||
property TagSuffix: string read GetTagSuffix write SetTagSuffix;
|
||||
property TagEscape: string read GetTagEscape write SetTagEscape;
|
||||
property OnLoadingFields: TJTemplateLoadingFieldsEvent read FOnLoadingFields
|
||||
write FOnLoadingFields;
|
||||
property OnReplacing: TJTemplateReplacingEvent read FOnReplacing
|
||||
write FOnReplacing;
|
||||
property OnReplace: TNotifyEvent read FOnReplace write FOnReplace;
|
||||
end;
|
||||
|
||||
resourcestring
|
||||
SNilParamError = '"%s" must not be nil.';
|
||||
|
||||
const
|
||||
LatinCharsCount = 74;
|
||||
LatinChars: array[0..LatinCharsCount] of string = (
|
||||
'"', '<', '>', '^', '~', '£', '§', '°', '²', '³', 'µ', '·', '¼', '½', '¿',
|
||||
'À', 'Á', 'Â', 'Ã', 'Ä', 'Å', 'Æ', 'Ç', 'È', 'É', 'Ê', 'Ë', 'Ì', 'Í', 'Î',
|
||||
'Ï', 'Ñ', 'Ò', 'Ó', 'Ô', 'Õ', 'Ö', 'Ù', 'Ú', 'Û', 'Ü', 'Ý', 'ß', 'á', 'à',
|
||||
'â', 'ã', 'ä', 'å', 'æ', 'ç', 'é', 'è', 'ê', 'ë', 'ì', 'í', 'î', 'ï', 'ñ',
|
||||
'ò', 'ó', 'ô', 'õ', 'ö', '÷', 'ù', 'ú', 'û', 'ü', 'ý', 'ÿ', '&', '´', '`');
|
||||
HtmlChars: array[0..LatinCharsCount] of string = (
|
||||
'"', '<', '>', 'ˆ', '˜', '£', '§', '°',
|
||||
'²', '³', 'µ', '·', '¼', '½', '¿',
|
||||
'À', 'Á', 'Â', 'Ã', 'Ä', 'Å', 'Æ',
|
||||
'Ç', 'È', 'É', 'Ê', 'Ë', 'Ì', 'Í',
|
||||
'Î', 'Ï', 'Ñ', 'Ò', 'Ó', 'Ô', 'Õ',
|
||||
'Ö', 'Ù', 'Ú', 'Û', 'Ü', 'Ý', 'ß',
|
||||
'á', 'à', 'â', 'ã', 'ä', 'å', 'æ',
|
||||
'ç', 'é', 'è', 'ê', 'ë', 'ì', 'í',
|
||||
'î', 'ï', 'ñ', 'ò', 'ó', 'ô', 'õ',
|
||||
'ö', '÷', 'ù', 'ú', 'û', 'ü', 'ý',
|
||||
'ÿ', '&', '´', '`');
|
||||
|
||||
function StrToHtml(const S: string): string;
|
||||
|
||||
implementation
|
||||
|
||||
function StrToHtml(const S: string): string;
|
||||
|
||||
function _Found(const ABuf: PChar; const ALen: Integer): Integer; inline;
|
||||
var
|
||||
P: PString;
|
||||
begin
|
||||
for Result := Low(LatinChars) to High(LatinChars) do
|
||||
begin
|
||||
P := @LatinChars[Result];
|
||||
if Length(P^) <= ALen then
|
||||
// compare in blocks of 8(x64), 4, 2 and 1 byte
|
||||
if CompareByte(P^[1], ABuf^, Length(P^)) = 0 then
|
||||
Exit;
|
||||
end;
|
||||
Result := -1;
|
||||
end;
|
||||
|
||||
var
|
||||
I: Integer;
|
||||
VResStr: string;
|
||||
PComp, PLast: PChar;
|
||||
begin
|
||||
VResStr := '';
|
||||
PComp := @S[1];
|
||||
PLast := PComp + Length(S);
|
||||
while PComp < PLast do
|
||||
begin
|
||||
I := _Found(PComp, PLast - PComp);
|
||||
if I > -1 then
|
||||
begin
|
||||
VResStr := VResStr + HtmlChars[I];
|
||||
Inc(PComp, Length(LatinChars[I]));
|
||||
end
|
||||
else
|
||||
begin
|
||||
// it can be optimized decreasing the concatenations
|
||||
VResStr := VResStr + PComp^;
|
||||
Inc(PComp);
|
||||
end;
|
||||
end;
|
||||
Result := VResStr;
|
||||
end;
|
||||
|
||||
{ TJTemplateParser }
|
||||
|
||||
constructor TJTemplateParser.Create;
|
||||
begin
|
||||
FFields := TJSONObject.Create;
|
||||
FTagPrefix := '@';
|
||||
FHtmlSupports := True;
|
||||
end;
|
||||
|
||||
destructor TJTemplateParser.Destroy;
|
||||
begin
|
||||
FreeAndNil(FFields);
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
procedure TJTemplateParser.Replace(const ARecursive: Boolean);
|
||||
var
|
||||
VVar, VValue: string;
|
||||
I, P, VTagLen, VEscapLen: Integer;
|
||||
begin
|
||||
VEscapLen := Length(FTagEscape);
|
||||
for I := 0 to Pred(FFields.Count) do
|
||||
begin
|
||||
VVar := FTagPrefix + FFields.Names[I] + FTagSuffix;
|
||||
if FHtmlSupports then
|
||||
VValue := StrToHtml(FFields.Items[I].AsString)
|
||||
else
|
||||
VValue := FFields.Items[I].AsString;
|
||||
if Assigned(FOnLoadingFields) then
|
||||
FOnLoadingFields(Self, VVar, VValue);
|
||||
P := 1;
|
||||
VTagLen := Length(VVar);
|
||||
repeat
|
||||
P := PosEx(VVar, FContent, P);
|
||||
if P < 1 then
|
||||
Break;
|
||||
if (VEscapLen <> 0) and // no TagEscape defined
|
||||
(CompareChar(FContent[P - VEscapLen], FTagEscape[1], VEscapLen) = 0) then
|
||||
begin
|
||||
System.Delete(FContent, P - VEscapLen, VEscapLen);
|
||||
Inc(P, VTagLen - VEscapLen);
|
||||
end
|
||||
else
|
||||
begin
|
||||
System.Delete(FContent, P, VTagLen);
|
||||
if Assigned(FOnReplacing) then
|
||||
FOnReplacing(Self, VValue);
|
||||
Insert(VValue, FContent, P);
|
||||
Inc(P, Length(VValue));
|
||||
if not ARecursive then
|
||||
Break;
|
||||
end;
|
||||
until False;
|
||||
end;
|
||||
if Assigned(FOnReplace) then
|
||||
FOnReplace(Self);
|
||||
end;
|
||||
|
||||
{ TJTemplateStream }
|
||||
|
||||
constructor TJTemplateStream.Create;
|
||||
begin
|
||||
inherited Create;
|
||||
FParser := CreateParser;
|
||||
end;
|
||||
|
||||
destructor TJTemplateStream.Destroy;
|
||||
begin
|
||||
FreeParser;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
function TJTemplateStream.CreateParser: TJTemplateParser;
|
||||
begin
|
||||
Result := GetParserClass.Create;
|
||||
end;
|
||||
|
||||
procedure TJTemplateStream.FreeParser;
|
||||
begin
|
||||
FreeAndNil(FParser);
|
||||
end;
|
||||
|
||||
function TJTemplateStream.GetParserClass: TJTemplateParserClass;
|
||||
begin
|
||||
Result := TJTemplateParser;
|
||||
end;
|
||||
|
||||
procedure TJTemplateStream.LoadFromStream(AStream: TStream);
|
||||
begin
|
||||
if not Assigned(AStream) then
|
||||
raise EJTemplate.CreateFmt(SNilParamError, ['AStream']);
|
||||
AStream.Seek(0, 0);
|
||||
SetLength(FParser.FContent, AStream.Size);
|
||||
AStream.Read(Pointer(FParser.FContent)^, Length(FParser.FContent));
|
||||
end;
|
||||
|
||||
procedure TJTemplateStream.LoadFromFile(const AFileName: TFileName);
|
||||
var
|
||||
VFile: TFileStream;
|
||||
begin
|
||||
VFile := TFileStream.Create(AFileName, fmOpenRead or fmShareDenyWrite);
|
||||
try
|
||||
LoadFromStream(VFile);
|
||||
finally
|
||||
VFile.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TJTemplateStream.SaveToStream(AStream: TStream);
|
||||
begin
|
||||
if not Assigned(AStream) then
|
||||
raise EJTemplate.CreateFmt(SNilParamError, ['AStream']);
|
||||
AStream.Seek(0, 0);
|
||||
AStream.Write(Pointer(FParser.FContent)^, Length(FParser.FContent));
|
||||
end;
|
||||
|
||||
procedure TJTemplateStream.SaveToFile(const AFileName: TFileName);
|
||||
var
|
||||
VFile: TFileStream;
|
||||
begin
|
||||
VFile := TFileStream.Create(AFileName, fmCreate);
|
||||
try
|
||||
SaveToStream(VFile);
|
||||
finally
|
||||
VFile.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
{ TJTemplate }
|
||||
|
||||
constructor TJTemplate.Create(AOwner: TComponent);
|
||||
begin
|
||||
inherited Create(AOwner);
|
||||
FStream := CreateStream;
|
||||
FContent := TStringList.Create;
|
||||
end;
|
||||
|
||||
destructor TJTemplate.Destroy;
|
||||
begin
|
||||
FContent.Free;
|
||||
FreeStream;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
function TJTemplate.CreateStream: TJTemplateStream;
|
||||
begin
|
||||
Result := GetStreamClass.Create;
|
||||
end;
|
||||
|
||||
procedure TJTemplate.FreeStream;
|
||||
begin
|
||||
FreeAndNil(FStream);
|
||||
end;
|
||||
|
||||
function TJTemplate.GetStreamClass: TJTemplateStreamClass;
|
||||
begin
|
||||
Result := TJTemplateStream;
|
||||
end;
|
||||
|
||||
function TJTemplate.GetContent: TStrings;
|
||||
begin
|
||||
Result := FContent;
|
||||
if Assigned(FContent) then
|
||||
FContent.Text := FStream.FParser.FContent;
|
||||
end;
|
||||
|
||||
function TJTemplate.GetFields: TJSONObject;
|
||||
begin
|
||||
Result := FStream.FParser.FFields;
|
||||
end;
|
||||
|
||||
function TJTemplate.GetHtmlSupports: Boolean;
|
||||
begin
|
||||
Result := FStream.FParser.FHtmlSupports;
|
||||
end;
|
||||
|
||||
function TJTemplate.GetParser: TJTemplateParser;
|
||||
begin
|
||||
Result := FStream.FParser;
|
||||
end;
|
||||
|
||||
function TJTemplate.GetStream: TJTemplateStream;
|
||||
begin
|
||||
Result := FStream;
|
||||
end;
|
||||
|
||||
function TJTemplate.GetTagEscape: string;
|
||||
begin
|
||||
Result := FStream.FParser.FTagEscape;
|
||||
end;
|
||||
|
||||
function TJTemplate.GetTagPrefix: string;
|
||||
begin
|
||||
Result := FStream.FParser.FTagPrefix;
|
||||
end;
|
||||
|
||||
function TJTemplate.GetTagSuffix: string;
|
||||
begin
|
||||
Result := FStream.FParser.FTagSuffix;
|
||||
end;
|
||||
|
||||
procedure TJTemplate.SetContent(AValue: TStrings);
|
||||
begin
|
||||
if Assigned(AValue) then
|
||||
begin
|
||||
FContent.Assign(AValue);
|
||||
FStream.FParser.FContent := AValue.Text;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TJTemplate.SetFields(AValue: TJSONObject);
|
||||
begin
|
||||
FStream.FParser.FFields := AValue;
|
||||
end;
|
||||
|
||||
procedure TJTemplate.SetHtmlSupports(AValue: Boolean);
|
||||
begin
|
||||
FStream.FParser.FHtmlSupports := AValue;
|
||||
end;
|
||||
|
||||
procedure TJTemplate.SetParser(AValue: TJTemplateParser);
|
||||
begin
|
||||
FStream.FParser := AValue;
|
||||
if Assigned(AValue) then
|
||||
begin
|
||||
AValue.OnLoadingFields := FOnLoadingFields;
|
||||
AValue.OnReplacing := FOnReplacing;
|
||||
AValue.OnReplace := FOnReplace;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TJTemplate.SetStream(AValue: TJTemplateStream);
|
||||
begin
|
||||
FStream := AValue;
|
||||
end;
|
||||
|
||||
procedure TJTemplate.SetTagEscape(AValue: string);
|
||||
begin
|
||||
FStream.FParser.FTagEscape := AValue;
|
||||
end;
|
||||
|
||||
procedure TJTemplate.SetTagPrefix(AValue: string);
|
||||
begin
|
||||
FStream.FParser.FTagPrefix := AValue;
|
||||
end;
|
||||
|
||||
procedure TJTemplate.SetTagSuffix(AValue: string);
|
||||
begin
|
||||
FStream.FParser.FTagSuffix := AValue;
|
||||
end;
|
||||
|
||||
procedure TJTemplate.Loaded;
|
||||
begin
|
||||
inherited Loaded;
|
||||
if Assigned(FContent) then
|
||||
FStream.FParser.FContent := FContent.Text;
|
||||
if Assigned(FStream) and Assigned(FStream.FParser) then
|
||||
begin
|
||||
if Assigned(FOnLoadingFields) then
|
||||
FStream.FParser.OnLoadingFields := FOnLoadingFields;
|
||||
if Assigned(FOnReplacing) then
|
||||
FStream.FParser.OnReplacing := FOnReplacing;
|
||||
if Assigned(FOnReplace) then
|
||||
FStream.FParser.OnReplace := FOnReplace;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TJTemplate.Replace(const ARecursive: Boolean);
|
||||
begin
|
||||
FStream.FParser.Replace(ARecursive);
|
||||
end;
|
||||
|
||||
procedure TJTemplate.LoadFromStream(AStream: TStream);
|
||||
begin
|
||||
FStream.LoadFromStream(AStream);
|
||||
end;
|
||||
|
||||
procedure TJTemplate.LoadFromFile(const AFileName: TFileName);
|
||||
begin
|
||||
FStream.LoadFromFile(AFileName);
|
||||
end;
|
||||
|
||||
procedure TJTemplate.SaveToStream(AStream: TStream);
|
||||
begin
|
||||
FStream.SaveToStream(AStream);
|
||||
end;
|
||||
|
||||
procedure TJTemplate.SaveToFile(const AFileName: TFileName);
|
||||
begin
|
||||
FStream.LoadFromFile(AFileName);
|
||||
end;
|
||||
|
||||
end.
|
64
restemplate.lpi
Normal file
64
restemplate.lpi
Normal file
@ -0,0 +1,64 @@
|
||||
<?xml version="1.0" encoding="UTF-8"?>
|
||||
<CONFIG>
|
||||
<ProjectOptions>
|
||||
<Version Value="9"/>
|
||||
<General>
|
||||
<Flags>
|
||||
<MainUnitHasCreateFormStatements Value="False"/>
|
||||
<MainUnitHasTitleStatement Value="False"/>
|
||||
</Flags>
|
||||
<SessionStorage Value="InProjectDir"/>
|
||||
<MainUnit Value="0"/>
|
||||
<Title Value="restemplate"/>
|
||||
<UseAppBundle Value="False"/>
|
||||
<ResourceType Value="res"/>
|
||||
</General>
|
||||
<i18n>
|
||||
<EnableI18N LFM="False"/>
|
||||
</i18n>
|
||||
<VersionInfo>
|
||||
<StringTable ProductVersion=""/>
|
||||
</VersionInfo>
|
||||
<BuildModes Count="1">
|
||||
<Item1 Name="Default" Default="True"/>
|
||||
</BuildModes>
|
||||
<PublishOptions>
|
||||
<Version Value="2"/>
|
||||
</PublishOptions>
|
||||
<RunParams>
|
||||
<local>
|
||||
<FormatVersion Value="1"/>
|
||||
</local>
|
||||
</RunParams>
|
||||
<Units Count="1">
|
||||
<Unit0>
|
||||
<Filename Value="restemplate.lpr"/>
|
||||
<IsPartOfProject Value="True"/>
|
||||
</Unit0>
|
||||
</Units>
|
||||
</ProjectOptions>
|
||||
<CompilerOptions>
|
||||
<Version Value="11"/>
|
||||
<Target>
|
||||
<Filename Value="restemplate"/>
|
||||
</Target>
|
||||
<SearchPaths>
|
||||
<IncludeFiles Value="$(ProjOutDir)"/>
|
||||
<OtherUnitFiles Value="jtemplate;synapse"/>
|
||||
<UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/>
|
||||
</SearchPaths>
|
||||
</CompilerOptions>
|
||||
<Debugging>
|
||||
<Exceptions Count="3">
|
||||
<Item1>
|
||||
<Name Value="EAbort"/>
|
||||
</Item1>
|
||||
<Item2>
|
||||
<Name Value="ECodetoolError"/>
|
||||
</Item2>
|
||||
<Item3>
|
||||
<Name Value="EFOpenError"/>
|
||||
</Item3>
|
||||
</Exceptions>
|
||||
</Debugging>
|
||||
</CONFIG>
|
127
restemplate.lpr
Normal file
127
restemplate.lpr
Normal file
@ -0,0 +1,127 @@
|
||||
{
|
||||
This file is part of restemplate.
|
||||
|
||||
Copyright (C) 2015 Andreas Schneider
|
||||
|
||||
restemplate 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 3 of the License, or
|
||||
(at your option) any later version.
|
||||
|
||||
sqlvision 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 restemplate. If not, see <http://www.gnu.org/licenses/>.
|
||||
}
|
||||
|
||||
program restemplate;
|
||||
|
||||
uses
|
||||
SysUtils, Classes, strutils, JTemplate, httpsend;
|
||||
|
||||
var
|
||||
data: TextFile;
|
||||
line: String;
|
||||
parser: TJTemplateParser;
|
||||
http: THTTPSend;
|
||||
method: String;
|
||||
content: TStringList;
|
||||
commandMode: Boolean;
|
||||
|
||||
procedure CmdAskUser(AName: String);
|
||||
var
|
||||
value: String;
|
||||
begin
|
||||
Write(AName, ': ');
|
||||
ReadLn(value);
|
||||
parser.Fields.Add(AName, value);
|
||||
end;
|
||||
|
||||
procedure CmdHeader(AHeader: String);
|
||||
begin
|
||||
parser.Content := AHeader;
|
||||
parser.Replace;
|
||||
http.Headers.Add(parser.Content);
|
||||
end;
|
||||
|
||||
procedure CmdCall(AURL: String);
|
||||
var
|
||||
s: String;
|
||||
begin
|
||||
parser.Content := AURL;
|
||||
parser.Replace;
|
||||
writeln('Calling ', parser.Content);
|
||||
|
||||
if content.Count > 0 then
|
||||
content.SaveToStream(http.Document);
|
||||
|
||||
if http.HTTPMethod(method, parser.Content) then
|
||||
begin
|
||||
writeln;
|
||||
writeln('Status: ', http.ResultCode);
|
||||
writeln;
|
||||
writeln('Headers:');
|
||||
for s in http.Headers do
|
||||
writeln(' ', s);
|
||||
writeln;
|
||||
content.LoadFromStream(http.Document);
|
||||
writeln(content.Text);
|
||||
end else
|
||||
writeln('FAILED !!!');
|
||||
end;
|
||||
|
||||
function ProcessCommand(ALine: String): Boolean;
|
||||
begin
|
||||
Result := False;
|
||||
if AnsiStartsStr('Ask ', ALine) then
|
||||
begin
|
||||
Result := True;
|
||||
CmdAskUser(Copy(ALine, 5, Length(ALine)));
|
||||
end else
|
||||
if AnsiStartsStr('Header ', ALine) then
|
||||
begin
|
||||
Result := True;
|
||||
CmdHeader(Copy(ALine, 8, Length(ALine)));
|
||||
end else
|
||||
if AnsiStartsStr('Method ', ALine) then
|
||||
begin
|
||||
Result := True;
|
||||
method := Copy(ALine, 8, Length(ALine));
|
||||
end else
|
||||
if AnsiStartsStr('Call ', ALine) then
|
||||
begin
|
||||
Result := True;
|
||||
CmdCall(Copy(ALine, 6, Length(ALine)));
|
||||
end;
|
||||
end;
|
||||
|
||||
begin
|
||||
AssignFile(data, ParamStr(1));
|
||||
Reset(data);
|
||||
|
||||
parser := TJTemplateParser.Create;
|
||||
http := THTTPSend.Create;
|
||||
content := TStringList.Create;
|
||||
|
||||
commandMode := True;
|
||||
|
||||
while not EOF(data) do
|
||||
begin
|
||||
ReadLn(data, line);
|
||||
if commandMode and (line <> '') and not ProcessCommand(line) then
|
||||
commandMode := False;
|
||||
|
||||
if not commandMode then
|
||||
content.Add(line);
|
||||
end;
|
||||
|
||||
parser.Free;
|
||||
http.Free;
|
||||
content.Free;
|
||||
|
||||
CloseFile(data);
|
||||
end.
|
||||
|
510
synapse/asn1util.pas
Normal file
510
synapse/asn1util.pas
Normal file
@ -0,0 +1,510 @@
|
||||
{==============================================================================|
|
||||
| Project : Ararat Synapse | 001.004.004 |
|
||||
|==============================================================================|
|
||||
| Content: support for ASN.1 BER coding and decoding |
|
||||
|==============================================================================|
|
||||
| Copyright (c)1999-2003, Lukas Gebauer |
|
||||
| All rights reserved. |
|
||||
| |
|
||||
| Redistribution and use in source and binary forms, with or without |
|
||||
| modification, are permitted provided that the following conditions are met: |
|
||||
| |
|
||||
| Redistributions of source code must retain the above copyright notice, this |
|
||||
| list of conditions and the following disclaimer. |
|
||||
| |
|
||||
| Redistributions in binary form must reproduce the above copyright notice, |
|
||||
| this list of conditions and the following disclaimer in the documentation |
|
||||
| and/or other materials provided with the distribution. |
|
||||
| |
|
||||
| Neither the name of Lukas Gebauer nor the names of its contributors may |
|
||||
| be used to endorse or promote products derived from this software without |
|
||||
| specific prior written permission. |
|
||||
| |
|
||||
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
|
||||
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
|
||||
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
|
||||
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
|
||||
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
|
||||
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
|
||||
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
|
||||
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
|
||||
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
|
||||
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
|
||||
| DAMAGE. |
|
||||
|==============================================================================|
|
||||
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
|
||||
| Portions created by Lukas Gebauer are Copyright (c) 1999-2003 |
|
||||
| Portions created by Hernan Sanchez are Copyright (c) 2000. |
|
||||
| All Rights Reserved. |
|
||||
|==============================================================================|
|
||||
| Contributor(s): |
|
||||
| Hernan Sanchez (hernan.sanchez@iname.com) |
|
||||
|==============================================================================|
|
||||
| History: see HISTORY.HTM from distribution package |
|
||||
| (Found at URL: http://www.ararat.cz/synapse/) |
|
||||
|==============================================================================}
|
||||
|
||||
{: @abstract(Utilities for handling ASN.1 BER encoding)
|
||||
By this unit you can parse ASN.1 BER encoded data to elements or build back any
|
||||
elements to ASN.1 BER encoded buffer. You can dump ASN.1 BER encoded data to
|
||||
human readable form for easy debugging, too.
|
||||
|
||||
Supported element types are: ASN1_BOOL, ASN1_INT, ASN1_OCTSTR, ASN1_NULL,
|
||||
ASN1_OBJID, ASN1_ENUM, ASN1_SEQ, ASN1_SETOF, ASN1_IPADDR, ASN1_COUNTER,
|
||||
ASN1_GAUGE, ASN1_TIMETICKS, ASN1_OPAQUE
|
||||
|
||||
For sample of using, look to @link(TSnmpSend) or @link(TLdapSend)class.
|
||||
}
|
||||
|
||||
{$Q-}
|
||||
{$H+}
|
||||
{$IFDEF FPC}
|
||||
{$MODE DELPHI}
|
||||
{$ENDIF}
|
||||
|
||||
{$IFDEF UNICODE}
|
||||
{$WARN IMPLICIT_STRING_CAST OFF}
|
||||
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
|
||||
{$ENDIF}
|
||||
|
||||
unit asn1util;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
SysUtils, Classes, synautil;
|
||||
|
||||
const
|
||||
ASN1_BOOL = $01;
|
||||
ASN1_INT = $02;
|
||||
ASN1_OCTSTR = $04;
|
||||
ASN1_NULL = $05;
|
||||
ASN1_OBJID = $06;
|
||||
ASN1_ENUM = $0a;
|
||||
ASN1_SEQ = $30;
|
||||
ASN1_SETOF = $31;
|
||||
ASN1_IPADDR = $40;
|
||||
ASN1_COUNTER = $41;
|
||||
ASN1_GAUGE = $42;
|
||||
ASN1_TIMETICKS = $43;
|
||||
ASN1_OPAQUE = $44;
|
||||
|
||||
{:Encodes OID item to binary form.}
|
||||
function ASNEncOIDItem(Value: Integer): AnsiString;
|
||||
|
||||
{:Decodes an OID item of the next element in the "Buffer" from the "Start"
|
||||
position.}
|
||||
function ASNDecOIDItem(var Start: Integer; const Buffer: AnsiString): Integer;
|
||||
|
||||
{:Encodes the length of ASN.1 element to binary.}
|
||||
function ASNEncLen(Len: Integer): AnsiString;
|
||||
|
||||
{:Decodes length of next element in "Buffer" from the "Start" position.}
|
||||
function ASNDecLen(var Start: Integer; const Buffer: AnsiString): Integer;
|
||||
|
||||
{:Encodes a signed integer to ASN.1 binary}
|
||||
function ASNEncInt(Value: Integer): AnsiString;
|
||||
|
||||
{:Encodes unsigned integer into ASN.1 binary}
|
||||
function ASNEncUInt(Value: Integer): AnsiString;
|
||||
|
||||
{:Encodes ASN.1 object to binary form.}
|
||||
function ASNObject(const Data: AnsiString; ASNType: Integer): AnsiString;
|
||||
|
||||
{:Beginning with the "Start" position, decode the ASN.1 item of the next element
|
||||
in "Buffer". Type of item is stored in "ValueType."}
|
||||
function ASNItem(var Start: Integer; const Buffer: AnsiString;
|
||||
var ValueType: Integer): AnsiString;
|
||||
|
||||
{:Encodes an MIB OID string to binary form.}
|
||||
function MibToId(Mib: String): AnsiString;
|
||||
|
||||
{:Decodes MIB OID from binary form to string form.}
|
||||
function IdToMib(const Id: AnsiString): String;
|
||||
|
||||
{:Encodes an one number from MIB OID to binary form. (used internally from
|
||||
@link(MibToId))}
|
||||
function IntMibToStr(const Value: AnsiString): AnsiString;
|
||||
|
||||
{:Convert ASN.1 BER encoded buffer to human readable form for debugging.}
|
||||
function ASNdump(const Value: AnsiString): AnsiString;
|
||||
|
||||
implementation
|
||||
|
||||
{==============================================================================}
|
||||
function ASNEncOIDItem(Value: Integer): AnsiString;
|
||||
var
|
||||
x, xm: Integer;
|
||||
b: Boolean;
|
||||
begin
|
||||
x := Value;
|
||||
b := False;
|
||||
Result := '';
|
||||
repeat
|
||||
xm := x mod 128;
|
||||
x := x div 128;
|
||||
if b then
|
||||
xm := xm or $80;
|
||||
if x > 0 then
|
||||
b := True;
|
||||
Result := AnsiChar(xm) + Result;
|
||||
until x = 0;
|
||||
end;
|
||||
|
||||
{==============================================================================}
|
||||
function ASNDecOIDItem(var Start: Integer; const Buffer: AnsiString): Integer;
|
||||
var
|
||||
x: Integer;
|
||||
b: Boolean;
|
||||
begin
|
||||
Result := 0;
|
||||
repeat
|
||||
Result := Result * 128;
|
||||
x := Ord(Buffer[Start]);
|
||||
Inc(Start);
|
||||
b := x > $7F;
|
||||
x := x and $7F;
|
||||
Result := Result + x;
|
||||
until not b;
|
||||
end;
|
||||
|
||||
{==============================================================================}
|
||||
function ASNEncLen(Len: Integer): AnsiString;
|
||||
var
|
||||
x, y: Integer;
|
||||
begin
|
||||
if Len < $80 then
|
||||
Result := AnsiChar(Len)
|
||||
else
|
||||
begin
|
||||
x := Len;
|
||||
Result := '';
|
||||
repeat
|
||||
y := x mod 256;
|
||||
x := x div 256;
|
||||
Result := AnsiChar(y) + Result;
|
||||
until x = 0;
|
||||
y := Length(Result);
|
||||
y := y or $80;
|
||||
Result := AnsiChar(y) + Result;
|
||||
end;
|
||||
end;
|
||||
|
||||
{==============================================================================}
|
||||
function ASNDecLen(var Start: Integer; const Buffer: AnsiString): Integer;
|
||||
var
|
||||
x, n: Integer;
|
||||
begin
|
||||
x := Ord(Buffer[Start]);
|
||||
Inc(Start);
|
||||
if x < $80 then
|
||||
Result := x
|
||||
else
|
||||
begin
|
||||
Result := 0;
|
||||
x := x and $7F;
|
||||
for n := 1 to x do
|
||||
begin
|
||||
Result := Result * 256;
|
||||
x := Ord(Buffer[Start]);
|
||||
Inc(Start);
|
||||
Result := Result + x;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
{==============================================================================}
|
||||
function ASNEncInt(Value: Integer): AnsiString;
|
||||
var
|
||||
x, y: Cardinal;
|
||||
neg: Boolean;
|
||||
begin
|
||||
neg := Value < 0;
|
||||
x := Abs(Value);
|
||||
if neg then
|
||||
x := not (x - 1);
|
||||
Result := '';
|
||||
repeat
|
||||
y := x mod 256;
|
||||
x := x div 256;
|
||||
Result := AnsiChar(y) + Result;
|
||||
until x = 0;
|
||||
if (not neg) and (Result[1] > #$7F) then
|
||||
Result := #0 + Result;
|
||||
end;
|
||||
|
||||
{==============================================================================}
|
||||
function ASNEncUInt(Value: Integer): AnsiString;
|
||||
var
|
||||
x, y: Integer;
|
||||
neg: Boolean;
|
||||
begin
|
||||
neg := Value < 0;
|
||||
x := Value;
|
||||
if neg then
|
||||
x := x and $7FFFFFFF;
|
||||
Result := '';
|
||||
repeat
|
||||
y := x mod 256;
|
||||
x := x div 256;
|
||||
Result := AnsiChar(y) + Result;
|
||||
until x = 0;
|
||||
if neg then
|
||||
Result[1] := AnsiChar(Ord(Result[1]) or $80);
|
||||
end;
|
||||
|
||||
{==============================================================================}
|
||||
function ASNObject(const Data: AnsiString; ASNType: Integer): AnsiString;
|
||||
begin
|
||||
Result := AnsiChar(ASNType) + ASNEncLen(Length(Data)) + Data;
|
||||
end;
|
||||
|
||||
{==============================================================================}
|
||||
function ASNItem(var Start: Integer; const Buffer: AnsiString;
|
||||
var ValueType: Integer): AnsiString;
|
||||
var
|
||||
ASNType: Integer;
|
||||
ASNSize: Integer;
|
||||
y, n: Integer;
|
||||
x: byte;
|
||||
s: AnsiString;
|
||||
c: AnsiChar;
|
||||
neg: Boolean;
|
||||
l: Integer;
|
||||
begin
|
||||
Result := '';
|
||||
ValueType := ASN1_NULL;
|
||||
l := Length(Buffer);
|
||||
if l < (Start + 1) then
|
||||
Exit;
|
||||
ASNType := Ord(Buffer[Start]);
|
||||
ValueType := ASNType;
|
||||
Inc(Start);
|
||||
ASNSize := ASNDecLen(Start, Buffer);
|
||||
if (Start + ASNSize - 1) > l then
|
||||
Exit;
|
||||
if (ASNType and $20) > 0 then
|
||||
// Result := '$' + IntToHex(ASNType, 2)
|
||||
Result := Copy(Buffer, Start, ASNSize)
|
||||
else
|
||||
case ASNType of
|
||||
ASN1_INT, ASN1_ENUM, ASN1_BOOL:
|
||||
begin
|
||||
y := 0;
|
||||
neg := False;
|
||||
for n := 1 to ASNSize do
|
||||
begin
|
||||
x := Ord(Buffer[Start]);
|
||||
if (n = 1) and (x > $7F) then
|
||||
neg := True;
|
||||
if neg then
|
||||
x := not x;
|
||||
y := y * 256 + x;
|
||||
Inc(Start);
|
||||
end;
|
||||
if neg then
|
||||
y := -(y + 1);
|
||||
Result := IntToStr(y);
|
||||
end;
|
||||
ASN1_COUNTER, ASN1_GAUGE, ASN1_TIMETICKS:
|
||||
begin
|
||||
y := 0;
|
||||
for n := 1 to ASNSize do
|
||||
begin
|
||||
y := y * 256 + Ord(Buffer[Start]);
|
||||
Inc(Start);
|
||||
end;
|
||||
Result := IntToStr(y);
|
||||
end;
|
||||
ASN1_OCTSTR, ASN1_OPAQUE:
|
||||
begin
|
||||
for n := 1 to ASNSize do
|
||||
begin
|
||||
c := AnsiChar(Buffer[Start]);
|
||||
Inc(Start);
|
||||
s := s + c;
|
||||
end;
|
||||
Result := s;
|
||||
end;
|
||||
ASN1_OBJID:
|
||||
begin
|
||||
for n := 1 to ASNSize do
|
||||
begin
|
||||
c := AnsiChar(Buffer[Start]);
|
||||
Inc(Start);
|
||||
s := s + c;
|
||||
end;
|
||||
Result := IdToMib(s);
|
||||
end;
|
||||
ASN1_IPADDR:
|
||||
begin
|
||||
s := '';
|
||||
for n := 1 to ASNSize do
|
||||
begin
|
||||
if (n <> 1) then
|
||||
s := s + '.';
|
||||
y := Ord(Buffer[Start]);
|
||||
Inc(Start);
|
||||
s := s + IntToStr(y);
|
||||
end;
|
||||
Result := s;
|
||||
end;
|
||||
ASN1_NULL:
|
||||
begin
|
||||
Result := '';
|
||||
Start := Start + ASNSize;
|
||||
end;
|
||||
else // unknown
|
||||
begin
|
||||
for n := 1 to ASNSize do
|
||||
begin
|
||||
c := AnsiChar(Buffer[Start]);
|
||||
Inc(Start);
|
||||
s := s + c;
|
||||
end;
|
||||
Result := s;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
{==============================================================================}
|
||||
function MibToId(Mib: String): AnsiString;
|
||||
var
|
||||
x: Integer;
|
||||
|
||||
function WalkInt(var s: String): Integer;
|
||||
var
|
||||
x: Integer;
|
||||
t: AnsiString;
|
||||
begin
|
||||
x := Pos('.', s);
|
||||
if x < 1 then
|
||||
begin
|
||||
t := s;
|
||||
s := '';
|
||||
end
|
||||
else
|
||||
begin
|
||||
t := Copy(s, 1, x - 1);
|
||||
s := Copy(s, x + 1, Length(s) - x);
|
||||
end;
|
||||
Result := StrToIntDef(t, 0);
|
||||
end;
|
||||
|
||||
begin
|
||||
Result := '';
|
||||
x := WalkInt(Mib);
|
||||
x := x * 40 + WalkInt(Mib);
|
||||
Result := ASNEncOIDItem(x);
|
||||
while Mib <> '' do
|
||||
begin
|
||||
x := WalkInt(Mib);
|
||||
Result := Result + ASNEncOIDItem(x);
|
||||
end;
|
||||
end;
|
||||
|
||||
{==============================================================================}
|
||||
function IdToMib(const Id: AnsiString): String;
|
||||
var
|
||||
x, y, n: Integer;
|
||||
begin
|
||||
Result := '';
|
||||
n := 1;
|
||||
while Length(Id) + 1 > n do
|
||||
begin
|
||||
x := ASNDecOIDItem(n, Id);
|
||||
if (n - 1) = 1 then
|
||||
begin
|
||||
y := x div 40;
|
||||
x := x mod 40;
|
||||
Result := IntToStr(y);
|
||||
end;
|
||||
Result := Result + '.' + IntToStr(x);
|
||||
end;
|
||||
end;
|
||||
|
||||
{==============================================================================}
|
||||
function IntMibToStr(const Value: AnsiString): AnsiString;
|
||||
var
|
||||
n, y: Integer;
|
||||
begin
|
||||
y := 0;
|
||||
for n := 1 to Length(Value) - 1 do
|
||||
y := y * 256 + Ord(Value[n]);
|
||||
Result := IntToStr(y);
|
||||
end;
|
||||
|
||||
{==============================================================================}
|
||||
function ASNdump(const Value: AnsiString): AnsiString;
|
||||
var
|
||||
i, at, x, n: integer;
|
||||
s, indent: AnsiString;
|
||||
il: TStringList;
|
||||
begin
|
||||
il := TStringList.Create;
|
||||
try
|
||||
Result := '';
|
||||
i := 1;
|
||||
indent := '';
|
||||
while i < Length(Value) do
|
||||
begin
|
||||
for n := il.Count - 1 downto 0 do
|
||||
begin
|
||||
x := StrToIntDef(il[n], 0);
|
||||
if x <= i then
|
||||
begin
|
||||
il.Delete(n);
|
||||
Delete(indent, 1, 2);
|
||||
end;
|
||||
end;
|
||||
s := ASNItem(i, Value, at);
|
||||
Result := Result + indent + '$' + IntToHex(at, 2);
|
||||
if (at and $20) > 0 then
|
||||
begin
|
||||
x := Length(s);
|
||||
Result := Result + ' constructed: length ' + IntToStr(x);
|
||||
indent := indent + ' ';
|
||||
il.Add(IntToStr(x + i - 1));
|
||||
end
|
||||
else
|
||||
begin
|
||||
case at of
|
||||
ASN1_BOOL:
|
||||
Result := Result + ' BOOL: ';
|
||||
ASN1_INT:
|
||||
Result := Result + ' INT: ';
|
||||
ASN1_ENUM:
|
||||
Result := Result + ' ENUM: ';
|
||||
ASN1_COUNTER:
|
||||
Result := Result + ' COUNTER: ';
|
||||
ASN1_GAUGE:
|
||||
Result := Result + ' GAUGE: ';
|
||||
ASN1_TIMETICKS:
|
||||
Result := Result + ' TIMETICKS: ';
|
||||
ASN1_OCTSTR:
|
||||
Result := Result + ' OCTSTR: ';
|
||||
ASN1_OPAQUE:
|
||||
Result := Result + ' OPAQUE: ';
|
||||
ASN1_OBJID:
|
||||
Result := Result + ' OBJID: ';
|
||||
ASN1_IPADDR:
|
||||
Result := Result + ' IPADDR: ';
|
||||
ASN1_NULL:
|
||||
Result := Result + ' NULL: ';
|
||||
else // other
|
||||
Result := Result + ' unknown: ';
|
||||
end;
|
||||
if IsBinaryString(s) then
|
||||
s := DumpExStr(s);
|
||||
Result := Result + s;
|
||||
end;
|
||||
Result := Result + #$0d + #$0a;
|
||||
end;
|
||||
finally
|
||||
il.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
{==============================================================================}
|
||||
|
||||
end.
|
4333
synapse/blcksock.pas
Normal file
4333
synapse/blcksock.pas
Normal file
File diff suppressed because it is too large
Load Diff
277
synapse/clamsend.pas
Normal file
277
synapse/clamsend.pas
Normal file
@ -0,0 +1,277 @@
|
||||
{==============================================================================|
|
||||
| Project : Ararat Synapse | 001.001.001 |
|
||||
|==============================================================================|
|
||||
| Content: ClamAV-daemon client |
|
||||
|==============================================================================|
|
||||
| Copyright (c)2005-2010, Lukas Gebauer |
|
||||
| All rights reserved. |
|
||||
| |
|
||||
| Redistribution and use in source and binary forms, with or without |
|
||||
| modification, are permitted provided that the following conditions are met: |
|
||||
| |
|
||||
| Redistributions of source code must retain the above copyright notice, this |
|
||||
| list of conditions and the following disclaimer. |
|
||||
| |
|
||||
| Redistributions in binary form must reproduce the above copyright notice, |
|
||||
| this list of conditions and the following disclaimer in the documentation |
|
||||
| and/or other materials provided with the distribution. |
|
||||
| |
|
||||
| Neither the name of Lukas Gebauer nor the names of its contributors may |
|
||||
| be used to endorse or promote products derived from this software without |
|
||||
| specific prior written permission. |
|
||||
| |
|
||||
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
|
||||
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
|
||||
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
|
||||
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
|
||||
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
|
||||
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
|
||||
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
|
||||
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
|
||||
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
|
||||
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
|
||||
| DAMAGE. |
|
||||
|==============================================================================|
|
||||
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
|
||||
| Portions created by Lukas Gebauer are Copyright (c)2005-2010. |
|
||||
| All Rights Reserved. |
|
||||
|==============================================================================|
|
||||
| Contributor(s): |
|
||||
|==============================================================================|
|
||||
| History: see HISTORY.HTM from distribution package |
|
||||
| (Found at URL: http://www.ararat.cz/synapse/) |
|
||||
|==============================================================================}
|
||||
|
||||
{:@abstract( ClamAV-daemon client)
|
||||
|
||||
This unit is capable to do antivirus scan of your data by TCP channel to ClamD
|
||||
daemon from ClamAV. See more about ClamAV on @LINK(http://www.clamav.net)
|
||||
}
|
||||
|
||||
{$IFDEF FPC}
|
||||
{$MODE DELPHI}
|
||||
{$ENDIF}
|
||||
{$Q-}
|
||||
{$H+}
|
||||
|
||||
{$IFDEF UNICODE}
|
||||
{$WARN IMPLICIT_STRING_CAST OFF}
|
||||
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
|
||||
{$ENDIF}
|
||||
|
||||
unit clamsend;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
SysUtils, Classes,
|
||||
synsock, blcksock, synautil;
|
||||
|
||||
const
|
||||
cClamProtocol = '3310';
|
||||
|
||||
type
|
||||
|
||||
{:@abstract(Implementation of ClamAV-daemon client protocol)
|
||||
By this class you can scan any your data by ClamAV opensource antivirus.
|
||||
|
||||
This class can connect to ClamD by TCP channel, send your data to ClamD
|
||||
and read result.}
|
||||
TClamSend = class(TSynaClient)
|
||||
private
|
||||
FSock: TTCPBlockSocket;
|
||||
FDSock: TTCPBlockSocket;
|
||||
FSession: boolean;
|
||||
function Login: boolean; virtual;
|
||||
function Logout: Boolean; virtual;
|
||||
function OpenStream: Boolean; virtual;
|
||||
public
|
||||
constructor Create;
|
||||
destructor Destroy; override;
|
||||
|
||||
{:Call any command to ClamD. Used internally by other methods.}
|
||||
function DoCommand(const Value: AnsiString): AnsiString; virtual;
|
||||
|
||||
{:Return ClamAV version and version of loaded databases.}
|
||||
function GetVersion: AnsiString; virtual;
|
||||
|
||||
{:Scan content of TStrings.}
|
||||
function ScanStrings(const Value: TStrings): AnsiString; virtual;
|
||||
|
||||
{:Scan content of TStream.}
|
||||
function ScanStream(const Value: TStream): AnsiString; virtual;
|
||||
|
||||
{:Scan content of TStrings by new 0.95 API.}
|
||||
function ScanStrings2(const Value: TStrings): AnsiString; virtual;
|
||||
|
||||
{:Scan content of TStream by new 0.95 API.}
|
||||
function ScanStream2(const Value: TStream): AnsiString; virtual;
|
||||
published
|
||||
{:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.}
|
||||
property Sock: TTCPBlockSocket read FSock;
|
||||
|
||||
{:Socket object used for TCP data transfer operation. Good for seting OnStatus hook, etc.}
|
||||
property DSock: TTCPBlockSocket read FDSock;
|
||||
|
||||
{:Can turn-on session mode of communication with ClamD. Default is @false,
|
||||
because ClamAV developers design their TCP code very badly and session mode
|
||||
is broken now (CVS-20051031). Maybe ClamAV developers fix their bugs
|
||||
and this mode will be possible in future.}
|
||||
property Session: boolean read FSession write FSession;
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
constructor TClamSend.Create;
|
||||
begin
|
||||
inherited Create;
|
||||
FSock := TTCPBlockSocket.Create;
|
||||
FSock.Owner := self;
|
||||
FDSock := TTCPBlockSocket.Create;
|
||||
FDSock.Owner := self;
|
||||
FTimeout := 60000;
|
||||
FTargetPort := cClamProtocol;
|
||||
FSession := false;
|
||||
end;
|
||||
|
||||
destructor TClamSend.Destroy;
|
||||
begin
|
||||
Logout;
|
||||
FDSock.Free;
|
||||
FSock.Free;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
function TClamSend.DoCommand(const Value: AnsiString): AnsiString;
|
||||
begin
|
||||
Result := '';
|
||||
if not FSession then
|
||||
FSock.CloseSocket
|
||||
else
|
||||
FSock.SendString(Value + LF);
|
||||
if not FSession or (FSock.LastError <> 0) then
|
||||
begin
|
||||
if Login then
|
||||
FSock.SendString(Value + LF)
|
||||
else
|
||||
Exit;
|
||||
end;
|
||||
Result := FSock.RecvTerminated(FTimeout, LF);
|
||||
end;
|
||||
|
||||
function TClamSend.Login: boolean;
|
||||
begin
|
||||
Result := False;
|
||||
Sock.CloseSocket;
|
||||
FSock.Bind(FIPInterface, cAnyPort);
|
||||
if FSock.LastError <> 0 then
|
||||
Exit;
|
||||
FSock.Connect(FTargetHost, FTargetPort);
|
||||
if FSock.LastError <> 0 then
|
||||
Exit;
|
||||
if FSession then
|
||||
FSock.SendString('SESSION' + LF);
|
||||
Result := FSock.LastError = 0;
|
||||
end;
|
||||
|
||||
function TClamSend.Logout: Boolean;
|
||||
begin
|
||||
FSock.SendString('END' + LF);
|
||||
Result := FSock.LastError = 0;
|
||||
FSock.CloseSocket;
|
||||
end;
|
||||
|
||||
function TClamSend.GetVersion: AnsiString;
|
||||
begin
|
||||
Result := DoCommand('nVERSION');
|
||||
end;
|
||||
|
||||
function TClamSend.OpenStream: Boolean;
|
||||
var
|
||||
S: AnsiString;
|
||||
begin
|
||||
Result := False;
|
||||
s := DoCommand('nSTREAM');
|
||||
if (s <> '') and (Copy(s, 1, 4) = 'PORT') then
|
||||
begin
|
||||
s := SeparateRight(s, ' ');
|
||||
FDSock.CloseSocket;
|
||||
FDSock.Bind(FIPInterface, cAnyPort);
|
||||
if FDSock.LastError <> 0 then
|
||||
Exit;
|
||||
FDSock.Connect(FTargetHost, s);
|
||||
if FDSock.LastError <> 0 then
|
||||
Exit;
|
||||
Result := True;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TClamSend.ScanStrings(const Value: TStrings): AnsiString;
|
||||
begin
|
||||
Result := '';
|
||||
if OpenStream then
|
||||
begin
|
||||
DSock.SendString(Value.Text);
|
||||
DSock.CloseSocket;
|
||||
Result := FSock.RecvTerminated(FTimeout, LF);
|
||||
end;
|
||||
end;
|
||||
|
||||
function TClamSend.ScanStream(const Value: TStream): AnsiString;
|
||||
begin
|
||||
Result := '';
|
||||
if OpenStream then
|
||||
begin
|
||||
DSock.SendStreamRaw(Value);
|
||||
DSock.CloseSocket;
|
||||
Result := FSock.RecvTerminated(FTimeout, LF);
|
||||
end;
|
||||
end;
|
||||
|
||||
function TClamSend.ScanStrings2(const Value: TStrings): AnsiString;
|
||||
var
|
||||
i: integer;
|
||||
s: AnsiString;
|
||||
begin
|
||||
Result := '';
|
||||
if not FSession then
|
||||
FSock.CloseSocket
|
||||
else
|
||||
FSock.sendstring('nINSTREAM' + LF);
|
||||
if not FSession or (FSock.LastError <> 0) then
|
||||
begin
|
||||
if Login then
|
||||
FSock.sendstring('nINSTREAM' + LF)
|
||||
else
|
||||
Exit;
|
||||
end;
|
||||
s := Value.text;
|
||||
i := length(s);
|
||||
FSock.SendString(CodeLongint(i) + s + #0#0#0#0);
|
||||
Result := FSock.RecvTerminated(FTimeout, LF);
|
||||
end;
|
||||
|
||||
function TClamSend.ScanStream2(const Value: TStream): AnsiString;
|
||||
var
|
||||
i: integer;
|
||||
begin
|
||||
Result := '';
|
||||
if not FSession then
|
||||
FSock.CloseSocket
|
||||
else
|
||||
FSock.sendstring('nINSTREAM' + LF);
|
||||
if not FSession or (FSock.LastError <> 0) then
|
||||
begin
|
||||
if Login then
|
||||
FSock.sendstring('nINSTREAM' + LF)
|
||||
else
|
||||
Exit;
|
||||
end;
|
||||
i := value.Size;
|
||||
FSock.SendString(CodeLongint(i));
|
||||
FSock.SendStreamRaw(Value);
|
||||
FSock.SendString(#0#0#0#0);
|
||||
Result := FSock.RecvTerminated(FTimeout, LF);
|
||||
end;
|
||||
|
||||
end.
|
603
synapse/dnssend.pas
Normal file
603
synapse/dnssend.pas
Normal file
@ -0,0 +1,603 @@
|
||||
{==============================================================================|
|
||||
| Project : Ararat Synapse | 002.007.006 |
|
||||
|==============================================================================|
|
||||
| Content: DNS client |
|
||||
|==============================================================================|
|
||||
| Copyright (c)1999-2010, Lukas Gebauer |
|
||||
| All rights reserved. |
|
||||
| |
|
||||
| Redistribution and use in source and binary forms, with or without |
|
||||
| modification, are permitted provided that the following conditions are met: |
|
||||
| |
|
||||
| Redistributions of source code must retain the above copyright notice, this |
|
||||
| list of conditions and the following disclaimer. |
|
||||
| |
|
||||
| Redistributions in binary form must reproduce the above copyright notice, |
|
||||
| this list of conditions and the following disclaimer in the documentation |
|
||||
| and/or other materials provided with the distribution. |
|
||||
| |
|
||||
| Neither the name of Lukas Gebauer nor the names of its contributors may |
|
||||
| be used to endorse or promote products derived from this software without |
|
||||
| specific prior written permission. |
|
||||
| |
|
||||
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
|
||||
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
|
||||
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
|
||||
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
|
||||
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
|
||||
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
|
||||
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
|
||||
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
|
||||
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
|
||||
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
|
||||
| DAMAGE. |
|
||||
|==============================================================================|
|
||||
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
|
||||
| Portions created by Lukas Gebauer are Copyright (c)2000-2010. |
|
||||
| All Rights Reserved. |
|
||||
|==============================================================================|
|
||||
| Contributor(s): |
|
||||
|==============================================================================|
|
||||
| History: see HISTORY.HTM from distribution package |
|
||||
| (Found at URL: http://www.ararat.cz/synapse/) |
|
||||
|==============================================================================}
|
||||
{: @abstract(DNS client by UDP or TCP)
|
||||
Support for sending DNS queries by UDP or TCP protocol. It can retrieve zone
|
||||
transfers too!
|
||||
|
||||
Used RFC: RFC-1035, RFC-1183, RFC1706, RFC1712, RFC2163, RFC2230
|
||||
}
|
||||
|
||||
{$IFDEF FPC}
|
||||
{$MODE DELPHI}
|
||||
{$ENDIF}
|
||||
{$Q-}
|
||||
{$H+}
|
||||
|
||||
{$IFDEF UNICODE}
|
||||
{$WARN IMPLICIT_STRING_CAST OFF}
|
||||
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
|
||||
{$ENDIF}
|
||||
|
||||
unit dnssend;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
SysUtils, Classes,
|
||||
blcksock, synautil, synaip, synsock;
|
||||
|
||||
const
|
||||
cDnsProtocol = '53';
|
||||
|
||||
QTYPE_A = 1;
|
||||
QTYPE_NS = 2;
|
||||
QTYPE_MD = 3;
|
||||
QTYPE_MF = 4;
|
||||
QTYPE_CNAME = 5;
|
||||
QTYPE_SOA = 6;
|
||||
QTYPE_MB = 7;
|
||||
QTYPE_MG = 8;
|
||||
QTYPE_MR = 9;
|
||||
QTYPE_NULL = 10;
|
||||
QTYPE_WKS = 11; //
|
||||
QTYPE_PTR = 12;
|
||||
QTYPE_HINFO = 13;
|
||||
QTYPE_MINFO = 14;
|
||||
QTYPE_MX = 15;
|
||||
QTYPE_TXT = 16;
|
||||
|
||||
QTYPE_RP = 17;
|
||||
QTYPE_AFSDB = 18;
|
||||
QTYPE_X25 = 19;
|
||||
QTYPE_ISDN = 20;
|
||||
QTYPE_RT = 21;
|
||||
QTYPE_NSAP = 22;
|
||||
QTYPE_NSAPPTR = 23;
|
||||
QTYPE_SIG = 24; // RFC-2065
|
||||
QTYPE_KEY = 25; // RFC-2065
|
||||
QTYPE_PX = 26;
|
||||
QTYPE_GPOS = 27;
|
||||
QTYPE_AAAA = 28;
|
||||
QTYPE_LOC = 29; // RFC-1876
|
||||
QTYPE_NXT = 30; // RFC-2065
|
||||
|
||||
QTYPE_SRV = 33;
|
||||
QTYPE_NAPTR = 35; // RFC-2168
|
||||
QTYPE_KX = 36;
|
||||
QTYPE_SPF = 99;
|
||||
|
||||
QTYPE_AXFR = 252;
|
||||
QTYPE_MAILB = 253; //
|
||||
QTYPE_MAILA = 254; //
|
||||
QTYPE_ALL = 255;
|
||||
|
||||
type
|
||||
{:@abstract(Implementation of DNS protocol by UDP or TCP protocol.)
|
||||
|
||||
Note: Are you missing properties for specify server address and port? Look to
|
||||
parent @link(TSynaClient) too!}
|
||||
TDNSSend = class(TSynaClient)
|
||||
private
|
||||
FID: Word;
|
||||
FRCode: Integer;
|
||||
FBuffer: AnsiString;
|
||||
FSock: TUDPBlockSocket;
|
||||
FTCPSock: TTCPBlockSocket;
|
||||
FUseTCP: Boolean;
|
||||
FAnswerInfo: TStringList;
|
||||
FNameserverInfo: TStringList;
|
||||
FAdditionalInfo: TStringList;
|
||||
FAuthoritative: Boolean;
|
||||
FTruncated: Boolean;
|
||||
function CompressName(const Value: AnsiString): AnsiString;
|
||||
function CodeHeader: AnsiString;
|
||||
function CodeQuery(const Name: AnsiString; QType: Integer): AnsiString;
|
||||
function DecodeLabels(var From: Integer): AnsiString;
|
||||
function DecodeString(var From: Integer): AnsiString;
|
||||
function DecodeResource(var i: Integer; const Info: TStringList;
|
||||
QType: Integer): AnsiString;
|
||||
function RecvTCPResponse(const WorkSock: TBlockSocket): AnsiString;
|
||||
function DecodeResponse(const Buf: AnsiString; const Reply: TStrings;
|
||||
QType: Integer):boolean;
|
||||
public
|
||||
constructor Create;
|
||||
destructor Destroy; override;
|
||||
|
||||
{:Query a DNSHost for QType resources correspond to a name. Supported QType
|
||||
values are: Qtype_A, Qtype_NS, Qtype_MD, Qtype_MF, Qtype_CNAME, Qtype_SOA,
|
||||
Qtype_MB, Qtype_MG, Qtype_MR, Qtype_NULL, Qtype_PTR, Qtype_HINFO,
|
||||
Qtype_MINFO, Qtype_MX, Qtype_TXT, Qtype_RP, Qtype_AFSDB, Qtype_X25,
|
||||
Qtype_ISDN, Qtype_RT, Qtype_NSAP, Qtype_NSAPPTR, Qtype_PX, Qtype_GPOS,
|
||||
Qtype_KX.
|
||||
|
||||
Type for zone transfers QTYPE_AXFR is supported too, but only in TCP mode!
|
||||
|
||||
"Name" is domain name or host name for queried resource. If "name" is
|
||||
IP address, automatically convert to reverse domain form (.in-addr.arpa).
|
||||
|
||||
If result is @true, Reply contains resource records. One record on one line.
|
||||
If Resource record have multiple fields, they are stored on line divided by
|
||||
comma. (example: MX record contains value 'rs.cesnet.cz' with preference
|
||||
number 10, string in Reply is: '10,rs.cesnet.cz'). All numbers or IP address
|
||||
in resource are converted to string form.}
|
||||
function DNSQuery(Name: AnsiString; QType: Integer;
|
||||
const Reply: TStrings): Boolean;
|
||||
published
|
||||
|
||||
{:Socket object used for UDP operation. Good for seting OnStatus hook, etc.}
|
||||
property Sock: TUDPBlockSocket read FSock;
|
||||
|
||||
{:Socket object used for TCP operation. Good for seting OnStatus hook, etc.}
|
||||
property TCPSock: TTCPBlockSocket read FTCPSock;
|
||||
|
||||
{:if @true, then is used TCP protocol instead UDP. It is needed for zone
|
||||
transfers, etc.}
|
||||
property UseTCP: Boolean read FUseTCP Write FUseTCP;
|
||||
|
||||
{:After DNS operation contains ResultCode of DNS operation.
|
||||
Values are: 0-no error, 1-format error, 2-server failure, 3-name error,
|
||||
4-not implemented, 5-refused.}
|
||||
property RCode: Integer read FRCode;
|
||||
|
||||
{:@True, if answer is authoritative.}
|
||||
property Authoritative: Boolean read FAuthoritative;
|
||||
|
||||
{:@True, if answer is truncated to 512 bytes.}
|
||||
property Truncated: Boolean read FTRuncated;
|
||||
|
||||
{:Detailed informations from name server reply. One record per line. Record
|
||||
have comma delimited entries with type number, TTL and data filelds.
|
||||
This information contains detailed information about query reply.}
|
||||
property AnswerInfo: TStringList read FAnswerInfo;
|
||||
|
||||
{:Detailed informations from name server reply. One record per line. Record
|
||||
have comma delimited entries with type number, TTL and data filelds.
|
||||
This information contains detailed information about nameserver.}
|
||||
property NameserverInfo: TStringList read FNameserverInfo;
|
||||
|
||||
{:Detailed informations from name server reply. One record per line. Record
|
||||
have comma delimited entries with type number, TTL and data filelds.
|
||||
This information contains detailed additional information.}
|
||||
property AdditionalInfo: TStringList read FAdditionalInfo;
|
||||
end;
|
||||
|
||||
{:A very useful function, and example of it's use is found in the TDNSSend object.
|
||||
This function is used to get mail servers for a domain and sort them by
|
||||
preference numbers. "Servers" contains only the domain names of the mail
|
||||
servers in the right order (without preference number!). The first domain name
|
||||
will always be the highest preferenced mail server. Returns boolean @TRUE if
|
||||
all went well.}
|
||||
function GetMailServers(const DNSHost, Domain: AnsiString;
|
||||
const Servers: TStrings): Boolean;
|
||||
|
||||
implementation
|
||||
|
||||
constructor TDNSSend.Create;
|
||||
begin
|
||||
inherited Create;
|
||||
FSock := TUDPBlockSocket.Create;
|
||||
FSock.Owner := self;
|
||||
FTCPSock := TTCPBlockSocket.Create;
|
||||
FTCPSock.Owner := self;
|
||||
FUseTCP := False;
|
||||
FTimeout := 10000;
|
||||
FTargetPort := cDnsProtocol;
|
||||
FAnswerInfo := TStringList.Create;
|
||||
FNameserverInfo := TStringList.Create;
|
||||
FAdditionalInfo := TStringList.Create;
|
||||
Randomize;
|
||||
end;
|
||||
|
||||
destructor TDNSSend.Destroy;
|
||||
begin
|
||||
FAnswerInfo.Free;
|
||||
FNameserverInfo.Free;
|
||||
FAdditionalInfo.Free;
|
||||
FTCPSock.Free;
|
||||
FSock.Free;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
function TDNSSend.CompressName(const Value: AnsiString): AnsiString;
|
||||
var
|
||||
n: Integer;
|
||||
s: AnsiString;
|
||||
begin
|
||||
Result := '';
|
||||
if Value = '' then
|
||||
Result := #0
|
||||
else
|
||||
begin
|
||||
s := '';
|
||||
for n := 1 to Length(Value) do
|
||||
if Value[n] = '.' then
|
||||
begin
|
||||
Result := Result + AnsiChar(Length(s)) + s;
|
||||
s := '';
|
||||
end
|
||||
else
|
||||
s := s + Value[n];
|
||||
if s <> '' then
|
||||
Result := Result + AnsiChar(Length(s)) + s;
|
||||
Result := Result + #0;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TDNSSend.CodeHeader: AnsiString;
|
||||
begin
|
||||
FID := Random(32767);
|
||||
Result := CodeInt(FID); // ID
|
||||
Result := Result + CodeInt($0100); // flags
|
||||
Result := Result + CodeInt(1); // QDCount
|
||||
Result := Result + CodeInt(0); // ANCount
|
||||
Result := Result + CodeInt(0); // NSCount
|
||||
Result := Result + CodeInt(0); // ARCount
|
||||
end;
|
||||
|
||||
function TDNSSend.CodeQuery(const Name: AnsiString; QType: Integer): AnsiString;
|
||||
begin
|
||||
Result := CompressName(Name);
|
||||
Result := Result + CodeInt(QType);
|
||||
Result := Result + CodeInt(1); // Type INTERNET
|
||||
end;
|
||||
|
||||
function TDNSSend.DecodeString(var From: Integer): AnsiString;
|
||||
var
|
||||
Len: integer;
|
||||
begin
|
||||
Len := Ord(FBuffer[From]);
|
||||
Inc(From);
|
||||
Result := Copy(FBuffer, From, Len);
|
||||
Inc(From, Len);
|
||||
end;
|
||||
|
||||
function TDNSSend.DecodeLabels(var From: Integer): AnsiString;
|
||||
var
|
||||
l, f: Integer;
|
||||
begin
|
||||
Result := '';
|
||||
while True do
|
||||
begin
|
||||
if From >= Length(FBuffer) then
|
||||
Break;
|
||||
l := Ord(FBuffer[From]);
|
||||
Inc(From);
|
||||
if l = 0 then
|
||||
Break;
|
||||
if Result <> '' then
|
||||
Result := Result + '.';
|
||||
if (l and $C0) = $C0 then
|
||||
begin
|
||||
f := l and $3F;
|
||||
f := f * 256 + Ord(FBuffer[From]) + 1;
|
||||
Inc(From);
|
||||
Result := Result + DecodeLabels(f);
|
||||
Break;
|
||||
end
|
||||
else
|
||||
begin
|
||||
Result := Result + Copy(FBuffer, From, l);
|
||||
Inc(From, l);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TDNSSend.DecodeResource(var i: Integer; const Info: TStringList;
|
||||
QType: Integer): AnsiString;
|
||||
var
|
||||
Rname: AnsiString;
|
||||
RType, Len, j, x, y, z, n: Integer;
|
||||
R: AnsiString;
|
||||
t1, t2, ttl: integer;
|
||||
ip6: TIp6bytes;
|
||||
begin
|
||||
Result := '';
|
||||
R := '';
|
||||
Rname := DecodeLabels(i);
|
||||
RType := DecodeInt(FBuffer, i);
|
||||
Inc(i, 4);
|
||||
t1 := DecodeInt(FBuffer, i);
|
||||
Inc(i, 2);
|
||||
t2 := DecodeInt(FBuffer, i);
|
||||
Inc(i, 2);
|
||||
ttl := t1 * 65536 + t2;
|
||||
Len := DecodeInt(FBuffer, i);
|
||||
Inc(i, 2); // i point to begin of data
|
||||
j := i;
|
||||
i := i + len; // i point to next record
|
||||
if Length(FBuffer) >= (i - 1) then
|
||||
case RType of
|
||||
QTYPE_A:
|
||||
begin
|
||||
R := IntToStr(Ord(FBuffer[j]));
|
||||
Inc(j);
|
||||
R := R + '.' + IntToStr(Ord(FBuffer[j]));
|
||||
Inc(j);
|
||||
R := R + '.' + IntToStr(Ord(FBuffer[j]));
|
||||
Inc(j);
|
||||
R := R + '.' + IntToStr(Ord(FBuffer[j]));
|
||||
end;
|
||||
QTYPE_AAAA:
|
||||
begin
|
||||
for n := 0 to 15 do
|
||||
ip6[n] := ord(FBuffer[j + n]);
|
||||
R := IP6ToStr(ip6);
|
||||
end;
|
||||
QTYPE_NS, QTYPE_MD, QTYPE_MF, QTYPE_CNAME, QTYPE_MB,
|
||||
QTYPE_MG, QTYPE_MR, QTYPE_PTR, QTYPE_X25, QTYPE_NSAP,
|
||||
QTYPE_NSAPPTR:
|
||||
R := DecodeLabels(j);
|
||||
QTYPE_SOA:
|
||||
begin
|
||||
R := DecodeLabels(j);
|
||||
R := R + ',' + DecodeLabels(j);
|
||||
for n := 1 to 5 do
|
||||
begin
|
||||
x := DecodeInt(FBuffer, j) * 65536 + DecodeInt(FBuffer, j + 2);
|
||||
Inc(j, 4);
|
||||
R := R + ',' + IntToStr(x);
|
||||
end;
|
||||
end;
|
||||
QTYPE_NULL:
|
||||
begin
|
||||
end;
|
||||
QTYPE_WKS:
|
||||
begin
|
||||
end;
|
||||
QTYPE_HINFO:
|
||||
begin
|
||||
R := DecodeString(j);
|
||||
R := R + ',' + DecodeString(j);
|
||||
end;
|
||||
QTYPE_MINFO, QTYPE_RP, QTYPE_ISDN:
|
||||
begin
|
||||
R := DecodeLabels(j);
|
||||
R := R + ',' + DecodeLabels(j);
|
||||
end;
|
||||
QTYPE_MX, QTYPE_AFSDB, QTYPE_RT, QTYPE_KX:
|
||||
begin
|
||||
x := DecodeInt(FBuffer, j);
|
||||
Inc(j, 2);
|
||||
R := IntToStr(x);
|
||||
R := R + ',' + DecodeLabels(j);
|
||||
end;
|
||||
QTYPE_TXT, QTYPE_SPF:
|
||||
begin
|
||||
R := '';
|
||||
while j < i do
|
||||
R := R + DecodeString(j);
|
||||
end;
|
||||
QTYPE_GPOS:
|
||||
begin
|
||||
R := DecodeLabels(j);
|
||||
R := R + ',' + DecodeLabels(j);
|
||||
R := R + ',' + DecodeLabels(j);
|
||||
end;
|
||||
QTYPE_PX:
|
||||
begin
|
||||
x := DecodeInt(FBuffer, j);
|
||||
Inc(j, 2);
|
||||
R := IntToStr(x);
|
||||
R := R + ',' + DecodeLabels(j);
|
||||
R := R + ',' + DecodeLabels(j);
|
||||
end;
|
||||
QTYPE_SRV:
|
||||
// Author: Dan <ml@mutox.org>
|
||||
begin
|
||||
x := DecodeInt(FBuffer, j);
|
||||
Inc(j, 2);
|
||||
y := DecodeInt(FBuffer, j);
|
||||
Inc(j, 2);
|
||||
z := DecodeInt(FBuffer, j);
|
||||
Inc(j, 2);
|
||||
R := IntToStr(x); // Priority
|
||||
R := R + ',' + IntToStr(y); // Weight
|
||||
R := R + ',' + IntToStr(z); // Port
|
||||
R := R + ',' + DecodeLabels(j); // Server DNS Name
|
||||
end;
|
||||
end;
|
||||
if R <> '' then
|
||||
Info.Add(RName + ',' + IntToStr(RType) + ',' + IntToStr(ttl) + ',' + R);
|
||||
if QType = RType then
|
||||
Result := R;
|
||||
end;
|
||||
|
||||
function TDNSSend.RecvTCPResponse(const WorkSock: TBlockSocket): AnsiString;
|
||||
var
|
||||
l: integer;
|
||||
begin
|
||||
Result := '';
|
||||
l := WorkSock.recvbyte(FTimeout) * 256 + WorkSock.recvbyte(FTimeout);
|
||||
if l > 0 then
|
||||
Result := WorkSock.RecvBufferStr(l, FTimeout);
|
||||
end;
|
||||
|
||||
function TDNSSend.DecodeResponse(const Buf: AnsiString; const Reply: TStrings;
|
||||
QType: Integer):boolean;
|
||||
var
|
||||
n, i: Integer;
|
||||
flag, qdcount, ancount, nscount, arcount: Integer;
|
||||
s: AnsiString;
|
||||
begin
|
||||
Result := False;
|
||||
Reply.Clear;
|
||||
FAnswerInfo.Clear;
|
||||
FNameserverInfo.Clear;
|
||||
FAdditionalInfo.Clear;
|
||||
FAuthoritative := False;
|
||||
if (Length(Buf) > 13) and (FID = DecodeInt(Buf, 1)) then
|
||||
begin
|
||||
Result := True;
|
||||
flag := DecodeInt(Buf, 3);
|
||||
FRCode := Flag and $000F;
|
||||
FAuthoritative := (Flag and $0400) > 0;
|
||||
FTruncated := (Flag and $0200) > 0;
|
||||
if FRCode = 0 then
|
||||
begin
|
||||
qdcount := DecodeInt(Buf, 5);
|
||||
ancount := DecodeInt(Buf, 7);
|
||||
nscount := DecodeInt(Buf, 9);
|
||||
arcount := DecodeInt(Buf, 11);
|
||||
i := 13; //begin of body
|
||||
if (qdcount > 0) and (Length(Buf) > i) then //skip questions
|
||||
for n := 1 to qdcount do
|
||||
begin
|
||||
while (Buf[i] <> #0) and ((Ord(Buf[i]) and $C0) <> $C0) do
|
||||
Inc(i);
|
||||
Inc(i, 5);
|
||||
end;
|
||||
if (ancount > 0) and (Length(Buf) > i) then // decode reply
|
||||
for n := 1 to ancount do
|
||||
begin
|
||||
s := DecodeResource(i, FAnswerInfo, QType);
|
||||
if s <> '' then
|
||||
Reply.Add(s);
|
||||
end;
|
||||
if (nscount > 0) and (Length(Buf) > i) then // decode nameserver info
|
||||
for n := 1 to nscount do
|
||||
DecodeResource(i, FNameserverInfo, QType);
|
||||
if (arcount > 0) and (Length(Buf) > i) then // decode additional info
|
||||
for n := 1 to arcount do
|
||||
DecodeResource(i, FAdditionalInfo, QType);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TDNSSend.DNSQuery(Name: AnsiString; QType: Integer;
|
||||
const Reply: TStrings): Boolean;
|
||||
var
|
||||
WorkSock: TBlockSocket;
|
||||
t: TStringList;
|
||||
b: boolean;
|
||||
begin
|
||||
Result := False;
|
||||
if IsIP(Name) then
|
||||
Name := ReverseIP(Name) + '.in-addr.arpa';
|
||||
if IsIP6(Name) then
|
||||
Name := ReverseIP6(Name) + '.ip6.arpa';
|
||||
FBuffer := CodeHeader + CodeQuery(Name, QType);
|
||||
if FUseTCP then
|
||||
WorkSock := FTCPSock
|
||||
else
|
||||
WorkSock := FSock;
|
||||
WorkSock.Bind(FIPInterface, cAnyPort);
|
||||
WorkSock.Connect(FTargetHost, FTargetPort);
|
||||
if FUseTCP then
|
||||
FBuffer := Codeint(length(FBuffer)) + FBuffer;
|
||||
WorkSock.SendString(FBuffer);
|
||||
if FUseTCP then
|
||||
FBuffer := RecvTCPResponse(WorkSock)
|
||||
else
|
||||
FBuffer := WorkSock.RecvPacket(FTimeout);
|
||||
if FUseTCP and (QType = QTYPE_AXFR) then //zone transfer
|
||||
begin
|
||||
t := TStringList.Create;
|
||||
try
|
||||
repeat
|
||||
b := DecodeResponse(FBuffer, Reply, QType);
|
||||
if (t.Count > 1) and (AnswerInfo.Count > 0) then //find end of transfer
|
||||
b := b and (t[0] <> AnswerInfo[AnswerInfo.count - 1]);
|
||||
if b then
|
||||
begin
|
||||
t.AddStrings(AnswerInfo);
|
||||
FBuffer := RecvTCPResponse(WorkSock);
|
||||
if FBuffer = '' then
|
||||
Break;
|
||||
if WorkSock.LastError <> 0 then
|
||||
Break;
|
||||
end;
|
||||
until not b;
|
||||
Reply.Assign(t);
|
||||
Result := True;
|
||||
finally
|
||||
t.free;
|
||||
end;
|
||||
end
|
||||
else //normal query
|
||||
if WorkSock.LastError = 0 then
|
||||
Result := DecodeResponse(FBuffer, Reply, QType);
|
||||
end;
|
||||
|
||||
{==============================================================================}
|
||||
|
||||
function GetMailServers(const DNSHost, Domain: AnsiString;
|
||||
const Servers: TStrings): Boolean;
|
||||
var
|
||||
DNS: TDNSSend;
|
||||
t: TStringList;
|
||||
n, m, x: Integer;
|
||||
begin
|
||||
Result := False;
|
||||
Servers.Clear;
|
||||
t := TStringList.Create;
|
||||
DNS := TDNSSend.Create;
|
||||
try
|
||||
DNS.TargetHost := DNSHost;
|
||||
if DNS.DNSQuery(Domain, QType_MX, t) then
|
||||
begin
|
||||
{ normalize preference number to 5 digits }
|
||||
for n := 0 to t.Count - 1 do
|
||||
begin
|
||||
x := Pos(',', t[n]);
|
||||
if x > 0 then
|
||||
for m := 1 to 6 - x do
|
||||
t[n] := '0' + t[n];
|
||||
end;
|
||||
{ sort server list }
|
||||
t.Sorted := True;
|
||||
{ result is sorted list without preference numbers }
|
||||
for n := 0 to t.Count - 1 do
|
||||
begin
|
||||
x := Pos(',', t[n]);
|
||||
Servers.Add(Copy(t[n], x + 1, Length(t[n]) - x));
|
||||
end;
|
||||
Result := True;
|
||||
end;
|
||||
finally
|
||||
DNS.Free;
|
||||
t.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
end.
|
1964
synapse/ftpsend.pas
Normal file
1964
synapse/ftpsend.pas
Normal file
File diff suppressed because it is too large
Load Diff
403
synapse/ftptsend.pas
Normal file
403
synapse/ftptsend.pas
Normal file
@ -0,0 +1,403 @@
|
||||
{==============================================================================|
|
||||
| Project : Ararat Synapse | 001.001.001 |
|
||||
|==============================================================================|
|
||||
| Content: Trivial FTP (TFTP) client and server |
|
||||
|==============================================================================|
|
||||
| Copyright (c)1999-2010, Lukas Gebauer |
|
||||
| All rights reserved. |
|
||||
| |
|
||||
| Redistribution and use in source and binary forms, with or without |
|
||||
| modification, are permitted provided that the following conditions are met: |
|
||||
| |
|
||||
| Redistributions of source code must retain the above copyright notice, this |
|
||||
| list of conditions and the following disclaimer. |
|
||||
| |
|
||||
| Redistributions in binary form must reproduce the above copyright notice, |
|
||||
| this list of conditions and the following disclaimer in the documentation |
|
||||
| and/or other materials provided with the distribution. |
|
||||
| |
|
||||
| Neither the name of Lukas Gebauer nor the names of its contributors may |
|
||||
| be used to endorse or promote products derived from this software without |
|
||||
| specific prior written permission. |
|
||||
| |
|
||||
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
|
||||
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
|
||||
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
|
||||
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
|
||||
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
|
||||
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
|
||||
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
|
||||
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
|
||||
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
|
||||
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
|
||||
| DAMAGE. |
|
||||
|==============================================================================|
|
||||
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
|
||||
| Portions created by Lukas Gebauer are Copyright (c)2003-2010. |
|
||||
| All Rights Reserved. |
|
||||
|==============================================================================|
|
||||
| Contributor(s): |
|
||||
|==============================================================================|
|
||||
| History: see HISTORY.HTM from distribution package |
|
||||
| (Found at URL: http://www.ararat.cz/synapse/) |
|
||||
|==============================================================================}
|
||||
|
||||
{: @abstract(TFTP client and server protocol)
|
||||
|
||||
Used RFC: RFC-1350
|
||||
}
|
||||
|
||||
{$IFDEF FPC}
|
||||
{$MODE DELPHI}
|
||||
{$ENDIF}
|
||||
{$Q-}
|
||||
{$H+}
|
||||
|
||||
{$IFDEF UNICODE}
|
||||
{$WARN IMPLICIT_STRING_CAST OFF}
|
||||
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
|
||||
{$ENDIF}
|
||||
|
||||
unit ftptsend;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
SysUtils, Classes,
|
||||
blcksock, synautil;
|
||||
|
||||
const
|
||||
cTFTPProtocol = '69';
|
||||
|
||||
cTFTP_RRQ = word(1);
|
||||
cTFTP_WRQ = word(2);
|
||||
cTFTP_DTA = word(3);
|
||||
cTFTP_ACK = word(4);
|
||||
cTFTP_ERR = word(5);
|
||||
|
||||
type
|
||||
{:@abstract(Implementation of TFTP client and server)
|
||||
Note: Are you missing properties for specify server address and port? Look to
|
||||
parent @link(TSynaClient) too!}
|
||||
TTFTPSend = class(TSynaClient)
|
||||
private
|
||||
FSock: TUDPBlockSocket;
|
||||
FErrorCode: integer;
|
||||
FErrorString: string;
|
||||
FData: TMemoryStream;
|
||||
FRequestIP: string;
|
||||
FRequestPort: string;
|
||||
function SendPacket(Cmd: word; Serial: word; const Value: string): Boolean;
|
||||
function RecvPacket(Serial: word; var Value: string): Boolean;
|
||||
public
|
||||
constructor Create;
|
||||
destructor Destroy; override;
|
||||
|
||||
{:Upload @link(data) as file to TFTP server.}
|
||||
function SendFile(const Filename: string): Boolean;
|
||||
|
||||
{:Download file from TFTP server to @link(data).}
|
||||
function RecvFile(const Filename: string): Boolean;
|
||||
|
||||
{:Acts as TFTP server and wait for client request. When some request
|
||||
incoming within Timeout, result is @true and parametres is filled with
|
||||
information from request. You must handle this request, validate it, and
|
||||
call @link(ReplyError), @link(ReplyRecv) or @link(ReplySend) for send reply
|
||||
to TFTP Client.}
|
||||
function WaitForRequest(var Req: word; var filename: string): Boolean;
|
||||
|
||||
{:send error to TFTP client, when you acts as TFTP server.}
|
||||
procedure ReplyError(Error: word; Description: string);
|
||||
|
||||
{:Accept uploaded file from TFTP client to @link(data), when you acts as
|
||||
TFTP server.}
|
||||
function ReplyRecv: Boolean;
|
||||
|
||||
{:Accept download request file from TFTP client and send content of
|
||||
@link(data), when you acts as TFTP server.}
|
||||
function ReplySend: Boolean;
|
||||
published
|
||||
{:Code of TFTP error.}
|
||||
property ErrorCode: integer read FErrorCode;
|
||||
|
||||
{:Human readable decription of TFTP error. (if is sended by remote side)}
|
||||
property ErrorString: string read FErrorString;
|
||||
|
||||
{:MemoryStream with datas for sending or receiving}
|
||||
property Data: TMemoryStream read FData;
|
||||
|
||||
{:Address of TFTP remote side.}
|
||||
property RequestIP: string read FRequestIP write FRequestIP;
|
||||
|
||||
{:Port of TFTP remote side.}
|
||||
property RequestPort: string read FRequestPort write FRequestPort;
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
constructor TTFTPSend.Create;
|
||||
begin
|
||||
inherited Create;
|
||||
FSock := TUDPBlockSocket.Create;
|
||||
FSock.Owner := self;
|
||||
FTargetPort := cTFTPProtocol;
|
||||
FData := TMemoryStream.Create;
|
||||
FErrorCode := 0;
|
||||
FErrorString := '';
|
||||
end;
|
||||
|
||||
destructor TTFTPSend.Destroy;
|
||||
begin
|
||||
FSock.Free;
|
||||
FData.Free;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
function TTFTPSend.SendPacket(Cmd: word; Serial: word; const Value: string): Boolean;
|
||||
var
|
||||
s, sh: string;
|
||||
begin
|
||||
FErrorCode := 0;
|
||||
FErrorString := '';
|
||||
Result := false;
|
||||
if Cmd <> 2 then
|
||||
s := CodeInt(Cmd) + CodeInt(Serial) + Value
|
||||
else
|
||||
s := CodeInt(Cmd) + Value;
|
||||
FSock.SendString(s);
|
||||
s := FSock.RecvPacket(FTimeout);
|
||||
if FSock.LastError = 0 then
|
||||
if length(s) >= 4 then
|
||||
begin
|
||||
sh := CodeInt(4) + CodeInt(Serial);
|
||||
if Pos(sh, s) = 1 then
|
||||
Result := True
|
||||
else
|
||||
if s[1] = #5 then
|
||||
begin
|
||||
FErrorCode := DecodeInt(s, 3);
|
||||
Delete(s, 1, 4);
|
||||
FErrorString := SeparateLeft(s, #0);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TTFTPSend.RecvPacket(Serial: word; var Value: string): Boolean;
|
||||
var
|
||||
s: string;
|
||||
ser: word;
|
||||
begin
|
||||
FErrorCode := 0;
|
||||
FErrorString := '';
|
||||
Result := False;
|
||||
Value := '';
|
||||
s := FSock.RecvPacket(FTimeout);
|
||||
if FSock.LastError = 0 then
|
||||
if length(s) >= 4 then
|
||||
if DecodeInt(s, 1) = 3 then
|
||||
begin
|
||||
ser := DecodeInt(s, 3);
|
||||
if ser = Serial then
|
||||
begin
|
||||
Delete(s, 1, 4);
|
||||
Value := s;
|
||||
S := CodeInt(4) + CodeInt(ser);
|
||||
FSock.SendString(s);
|
||||
Result := FSock.LastError = 0;
|
||||
end
|
||||
else
|
||||
begin
|
||||
S := CodeInt(5) + CodeInt(5) + 'Unexcepted serial#' + #0;
|
||||
FSock.SendString(s);
|
||||
end;
|
||||
end;
|
||||
if DecodeInt(s, 1) = 5 then
|
||||
begin
|
||||
FErrorCode := DecodeInt(s, 3);
|
||||
Delete(s, 1, 4);
|
||||
FErrorString := SeparateLeft(s, #0);
|
||||
end;
|
||||
end;
|
||||
|
||||
function TTFTPSend.SendFile(const Filename: string): Boolean;
|
||||
var
|
||||
s: string;
|
||||
ser: word;
|
||||
n, n1, n2: integer;
|
||||
begin
|
||||
Result := False;
|
||||
FErrorCode := 0;
|
||||
FErrorString := '';
|
||||
FSock.CloseSocket;
|
||||
FSock.Connect(FTargetHost, FTargetPort);
|
||||
try
|
||||
if FSock.LastError = 0 then
|
||||
begin
|
||||
s := Filename + #0 + 'octet' + #0;
|
||||
if not Sendpacket(2, 0, s) then
|
||||
Exit;
|
||||
ser := 1;
|
||||
FData.Position := 0;
|
||||
n1 := FData.Size div 512;
|
||||
n2 := FData.Size mod 512;
|
||||
for n := 1 to n1 do
|
||||
begin
|
||||
s := ReadStrFromStream(FData, 512);
|
||||
// SetLength(s, 512);
|
||||
// FData.Read(pointer(s)^, 512);
|
||||
if not Sendpacket(3, ser, s) then
|
||||
Exit;
|
||||
inc(ser);
|
||||
end;
|
||||
s := ReadStrFromStream(FData, n2);
|
||||
// SetLength(s, n2);
|
||||
// FData.Read(pointer(s)^, n2);
|
||||
if not Sendpacket(3, ser, s) then
|
||||
Exit;
|
||||
Result := True;
|
||||
end;
|
||||
finally
|
||||
FSock.CloseSocket;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TTFTPSend.RecvFile(const Filename: string): Boolean;
|
||||
var
|
||||
s: string;
|
||||
ser: word;
|
||||
begin
|
||||
Result := False;
|
||||
FErrorCode := 0;
|
||||
FErrorString := '';
|
||||
FSock.CloseSocket;
|
||||
FSock.Connect(FTargetHost, FTargetPort);
|
||||
try
|
||||
if FSock.LastError = 0 then
|
||||
begin
|
||||
s := CodeInt(1) + Filename + #0 + 'octet' + #0;
|
||||
FSock.SendString(s);
|
||||
if FSock.LastError <> 0 then
|
||||
Exit;
|
||||
FData.Clear;
|
||||
ser := 1;
|
||||
repeat
|
||||
if not RecvPacket(ser, s) then
|
||||
Exit;
|
||||
inc(ser);
|
||||
WriteStrToStream(FData, s);
|
||||
// FData.Write(pointer(s)^, length(s));
|
||||
until length(s) <> 512;
|
||||
FData.Position := 0;
|
||||
Result := true;
|
||||
end;
|
||||
finally
|
||||
FSock.CloseSocket;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TTFTPSend.WaitForRequest(var Req: word; var filename: string): Boolean;
|
||||
var
|
||||
s: string;
|
||||
begin
|
||||
Result := False;
|
||||
FErrorCode := 0;
|
||||
FErrorString := '';
|
||||
FSock.CloseSocket;
|
||||
FSock.Bind('0.0.0.0', FTargetPort);
|
||||
if FSock.LastError = 0 then
|
||||
begin
|
||||
s := FSock.RecvPacket(FTimeout);
|
||||
if FSock.LastError = 0 then
|
||||
if Length(s) >= 4 then
|
||||
begin
|
||||
FRequestIP := FSock.GetRemoteSinIP;
|
||||
FRequestPort := IntToStr(FSock.GetRemoteSinPort);
|
||||
Req := DecodeInt(s, 1);
|
||||
delete(s, 1, 2);
|
||||
filename := Trim(SeparateLeft(s, #0));
|
||||
s := SeparateRight(s, #0);
|
||||
s := SeparateLeft(s, #0);
|
||||
Result := lowercase(trim(s)) = 'octet';
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTFTPSend.ReplyError(Error: word; Description: string);
|
||||
var
|
||||
s: string;
|
||||
begin
|
||||
FSock.CloseSocket;
|
||||
FSock.Connect(FRequestIP, FRequestPort);
|
||||
s := CodeInt(5) + CodeInt(Error) + Description + #0;
|
||||
FSock.SendString(s);
|
||||
FSock.CloseSocket;
|
||||
end;
|
||||
|
||||
function TTFTPSend.ReplyRecv: Boolean;
|
||||
var
|
||||
s: string;
|
||||
ser: integer;
|
||||
begin
|
||||
Result := False;
|
||||
FErrorCode := 0;
|
||||
FErrorString := '';
|
||||
FSock.CloseSocket;
|
||||
FSock.Connect(FRequestIP, FRequestPort);
|
||||
try
|
||||
s := CodeInt(4) + CodeInt(0);
|
||||
FSock.SendString(s);
|
||||
FData.Clear;
|
||||
ser := 1;
|
||||
repeat
|
||||
if not RecvPacket(ser, s) then
|
||||
Exit;
|
||||
inc(ser);
|
||||
WriteStrToStream(FData, s);
|
||||
// FData.Write(pointer(s)^, length(s));
|
||||
until length(s) <> 512;
|
||||
FData.Position := 0;
|
||||
Result := true;
|
||||
finally
|
||||
FSock.CloseSocket;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TTFTPSend.ReplySend: Boolean;
|
||||
var
|
||||
s: string;
|
||||
ser: word;
|
||||
n, n1, n2: integer;
|
||||
begin
|
||||
Result := False;
|
||||
FErrorCode := 0;
|
||||
FErrorString := '';
|
||||
FSock.CloseSocket;
|
||||
FSock.Connect(FRequestIP, FRequestPort);
|
||||
try
|
||||
ser := 1;
|
||||
FData.Position := 0;
|
||||
n1 := FData.Size div 512;
|
||||
n2 := FData.Size mod 512;
|
||||
for n := 1 to n1 do
|
||||
begin
|
||||
s := ReadStrFromStream(FData, 512);
|
||||
// SetLength(s, 512);
|
||||
// FData.Read(pointer(s)^, 512);
|
||||
if not Sendpacket(3, ser, s) then
|
||||
Exit;
|
||||
inc(ser);
|
||||
end;
|
||||
s := ReadStrFromStream(FData, n2);
|
||||
// SetLength(s, n2);
|
||||
// FData.Read(pointer(s)^, n2);
|
||||
if not Sendpacket(3, ser, s) then
|
||||
Exit;
|
||||
Result := True;
|
||||
finally
|
||||
FSock.CloseSocket;
|
||||
end;
|
||||
end;
|
||||
|
||||
{==============================================================================}
|
||||
|
||||
end.
|
845
synapse/httpsend.pas
Normal file
845
synapse/httpsend.pas
Normal file
@ -0,0 +1,845 @@
|
||||
{==============================================================================|
|
||||
| Project : Ararat Synapse | 003.012.006 |
|
||||
|==============================================================================|
|
||||
| Content: HTTP client |
|
||||
|==============================================================================|
|
||||
| Copyright (c)1999-2011, Lukas Gebauer |
|
||||
| All rights reserved. |
|
||||
| |
|
||||
| Redistribution and use in source and binary forms, with or without |
|
||||
| modification, are permitted provided that the following conditions are met: |
|
||||
| |
|
||||
| Redistributions of source code must retain the above copyright notice, this |
|
||||
| list of conditions and the following disclaimer. |
|
||||
| |
|
||||
| Redistributions in binary form must reproduce the above copyright notice, |
|
||||
| this list of conditions and the following disclaimer in the documentation |
|
||||
| and/or other materials provided with the distribution. |
|
||||
| |
|
||||
| Neither the name of Lukas Gebauer nor the names of its contributors may |
|
||||
| be used to endorse or promote products derived from this software without |
|
||||
| specific prior written permission. |
|
||||
| |
|
||||
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
|
||||
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
|
||||
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
|
||||
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
|
||||
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
|
||||
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
|
||||
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
|
||||
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
|
||||
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
|
||||
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
|
||||
| DAMAGE. |
|
||||
|==============================================================================|
|
||||
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
|
||||
| Portions created by Lukas Gebauer are Copyright (c) 1999-2011. |
|
||||
| All Rights Reserved. |
|
||||
|==============================================================================|
|
||||
| Contributor(s): |
|
||||
|==============================================================================|
|
||||
| History: see HISTORY.HTM from distribution package |
|
||||
| (Found at URL: http://www.ararat.cz/synapse/) |
|
||||
|==============================================================================}
|
||||
|
||||
{:@abstract(HTTP protocol client)
|
||||
|
||||
Used RFC: RFC-1867, RFC-1947, RFC-2388, RFC-2616
|
||||
}
|
||||
|
||||
{$IFDEF FPC}
|
||||
{$MODE DELPHI}
|
||||
{$ENDIF}
|
||||
{$H+}
|
||||
//old Delphi does not have MSWINDOWS define.
|
||||
{$IFDEF WIN32}
|
||||
{$IFNDEF MSWINDOWS}
|
||||
{$DEFINE MSWINDOWS}
|
||||
{$ENDIF}
|
||||
{$ENDIF}
|
||||
|
||||
{$IFDEF UNICODE}
|
||||
{$WARN IMPLICIT_STRING_CAST OFF}
|
||||
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
|
||||
{$ENDIF}
|
||||
|
||||
unit httpsend;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
SysUtils, Classes,
|
||||
blcksock, synautil, synaip, synacode, synsock;
|
||||
|
||||
const
|
||||
cHttpProtocol = '80';
|
||||
|
||||
type
|
||||
{:These encoding types are used internally by the THTTPSend object to identify
|
||||
the transfer data types.}
|
||||
TTransferEncoding = (TE_UNKNOWN, TE_IDENTITY, TE_CHUNKED);
|
||||
|
||||
{:abstract(Implementation of HTTP protocol.)}
|
||||
THTTPSend = class(TSynaClient)
|
||||
protected
|
||||
FSock: TTCPBlockSocket;
|
||||
FTransferEncoding: TTransferEncoding;
|
||||
FAliveHost: string;
|
||||
FAlivePort: string;
|
||||
FHeaders: TStringList;
|
||||
FDocument: TMemoryStream;
|
||||
FMimeType: string;
|
||||
FProtocol: string;
|
||||
FKeepAlive: Boolean;
|
||||
FKeepAliveTimeout: integer;
|
||||
FStatus100: Boolean;
|
||||
FProxyHost: string;
|
||||
FProxyPort: string;
|
||||
FProxyUser: string;
|
||||
FProxyPass: string;
|
||||
FResultCode: Integer;
|
||||
FResultString: string;
|
||||
FUserAgent: string;
|
||||
FCookies: TStringList;
|
||||
FDownloadSize: integer;
|
||||
FUploadSize: integer;
|
||||
FRangeStart: integer;
|
||||
FRangeEnd: integer;
|
||||
FAddPortNumberToHost: Boolean;
|
||||
function ReadUnknown: Boolean;
|
||||
function ReadIdentity(Size: Integer): Boolean;
|
||||
function ReadChunked: Boolean;
|
||||
procedure ParseCookies;
|
||||
function PrepareHeaders: AnsiString;
|
||||
function InternalDoConnect(needssl: Boolean): Boolean;
|
||||
function InternalConnect(needssl: Boolean): Boolean;
|
||||
public
|
||||
constructor Create;
|
||||
destructor Destroy; override;
|
||||
|
||||
{:Reset headers and document and Mimetype.}
|
||||
procedure Clear;
|
||||
|
||||
{:Decode ResultCode and ResultString from Value.}
|
||||
procedure DecodeStatus(const Value: string);
|
||||
|
||||
{:Connects to host define in URL and access to resource defined in URL by
|
||||
method. If Document is not empty, send it to server as part of HTTP request.
|
||||
Server response is in Document and headers. Connection may be authorised
|
||||
by username and password in URL. If you define proxy properties, connection
|
||||
is made by this proxy. If all OK, result is @true, else result is @false.
|
||||
|
||||
If you use in URL 'https:' instead only 'http:', then your request is made
|
||||
by SSL/TLS connection (if you not specify port, then port 443 is used
|
||||
instead standard port 80). If you use SSL/TLS request and you have defined
|
||||
HTTP proxy, then HTTP-tunnel mode is automaticly used .}
|
||||
function HTTPMethod(const Method, URL: string): Boolean;
|
||||
|
||||
{:You can call this method from OnStatus event for break current data
|
||||
transfer. (or from another thread.)}
|
||||
procedure Abort;
|
||||
published
|
||||
{:Before HTTP operation you may define any non-standard headers for HTTP
|
||||
request, except of: 'Expect: 100-continue', 'Content-Length', 'Content-Type',
|
||||
'Connection', 'Authorization', 'Proxy-Authorization' and 'Host' headers.
|
||||
After HTTP operation contains full headers of returned document.}
|
||||
property Headers: TStringList read FHeaders;
|
||||
|
||||
{:This is stringlist with name-value stringlist pairs. Each this pair is one
|
||||
cookie. After HTTP request is returned cookies parsed to this stringlist.
|
||||
You can leave this cookies untouched for next HTTP request. You can also
|
||||
save this stringlist for later use.}
|
||||
property Cookies: TStringList read FCookies;
|
||||
|
||||
{:Stream with document to send (before request, or with document received
|
||||
from HTTP server (after request).}
|
||||
property Document: TMemoryStream read FDocument;
|
||||
|
||||
{:If you need download only part of requested document, here specify
|
||||
possition of subpart begin. If here 0, then is requested full document.}
|
||||
property RangeStart: integer read FRangeStart Write FRangeStart;
|
||||
|
||||
{:If you need download only part of requested document, here specify
|
||||
possition of subpart end. If here 0, then is requested document from
|
||||
rangeStart to end of document. (for broken download restoration,
|
||||
for example.)}
|
||||
property RangeEnd: integer read FRangeEnd Write FRangeEnd;
|
||||
|
||||
{:Mime type of sending data. Default is: 'text/html'.}
|
||||
property MimeType: string read FMimeType Write FMimeType;
|
||||
|
||||
{:Define protocol version. Possible values are: '1.1', '1.0' (default)
|
||||
and '0.9'.}
|
||||
property Protocol: string read FProtocol Write FProtocol;
|
||||
|
||||
{:If @true (default value), keepalives in HTTP protocol 1.1 is enabled.}
|
||||
property KeepAlive: Boolean read FKeepAlive Write FKeepAlive;
|
||||
|
||||
{:Define timeout for keepalives in seconds!}
|
||||
property KeepAliveTimeout: integer read FKeepAliveTimeout Write FKeepAliveTimeout;
|
||||
|
||||
{:if @true, then server is requested for 100status capability when uploading
|
||||
data. Default is @false (off).}
|
||||
property Status100: Boolean read FStatus100 Write FStatus100;
|
||||
|
||||
{:Address of proxy server (IP address or domain name) where you want to
|
||||
connect in @link(HTTPMethod) method.}
|
||||
property ProxyHost: string read FProxyHost Write FProxyHost;
|
||||
|
||||
{:Port number for proxy connection. Default value is 8080.}
|
||||
property ProxyPort: string read FProxyPort Write FProxyPort;
|
||||
|
||||
{:Username for connect to proxy server where you want to connect in
|
||||
HTTPMethod method.}
|
||||
property ProxyUser: string read FProxyUser Write FProxyUser;
|
||||
|
||||
{:Password for connect to proxy server where you want to connect in
|
||||
HTTPMethod method.}
|
||||
property ProxyPass: string read FProxyPass Write FProxyPass;
|
||||
|
||||
{:Here you can specify custom User-Agent indentification. By default is
|
||||
used: 'Mozilla/4.0 (compatible; Synapse)'}
|
||||
property UserAgent: string read FUserAgent Write FUserAgent;
|
||||
|
||||
{:After successful @link(HTTPMethod) method contains result code of
|
||||
operation.}
|
||||
property ResultCode: Integer read FResultCode;
|
||||
|
||||
{:After successful @link(HTTPMethod) method contains string after result code.}
|
||||
property ResultString: string read FResultString;
|
||||
|
||||
{:if this value is not 0, then data download pending. In this case you have
|
||||
here total sice of downloaded data. It is good for draw download
|
||||
progressbar from OnStatus event.}
|
||||
property DownloadSize: integer read FDownloadSize;
|
||||
|
||||
{:if this value is not 0, then data upload pending. In this case you have
|
||||
here total sice of uploaded data. It is good for draw upload progressbar
|
||||
from OnStatus event.}
|
||||
property UploadSize: integer read FUploadSize;
|
||||
{:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.}
|
||||
property Sock: TTCPBlockSocket read FSock;
|
||||
|
||||
{:To have possibility to switch off port number in 'Host:' HTTP header, by
|
||||
default @TRUE. Some buggy servers not like port informations in this header.}
|
||||
property AddPortNumberToHost: Boolean read FAddPortNumberToHost write FAddPortNumberToHost;
|
||||
end;
|
||||
|
||||
{:A very usefull function, and example of use can be found in the THTTPSend
|
||||
object. It implements the GET method of the HTTP protocol. This function sends
|
||||
the GET method for URL document to an HTTP server. Returned document is in the
|
||||
"Response" stringlist (without any headers). Returns boolean TRUE if all went
|
||||
well.}
|
||||
function HttpGetText(const URL: string; const Response: TStrings): Boolean;
|
||||
|
||||
{:A very usefull function, and example of use can be found in the THTTPSend
|
||||
object. It implements the GET method of the HTTP protocol. This function sends
|
||||
the GET method for URL document to an HTTP server. Returned document is in the
|
||||
"Response" stream. Returns boolean TRUE if all went well.}
|
||||
function HttpGetBinary(const URL: string; const Response: TStream): Boolean;
|
||||
|
||||
{:A very useful function, and example of use can be found in the THTTPSend
|
||||
object. It implements the POST method of the HTTP protocol. This function sends
|
||||
the SEND method for a URL document to an HTTP server. The document to be sent
|
||||
is located in "Data" stream. The returned document is in the "Data" stream.
|
||||
Returns boolean TRUE if all went well.}
|
||||
function HttpPostBinary(const URL: string; const Data: TStream): Boolean;
|
||||
|
||||
{:A very useful function, and example of use can be found in the THTTPSend
|
||||
object. It implements the POST method of the HTTP protocol. This function is
|
||||
good for POSTing form data. It sends the POST method for a URL document to
|
||||
an HTTP server. You must prepare the form data in the same manner as you would
|
||||
the URL data, and pass this prepared data to "URLdata". The following is
|
||||
a sample of how the data would appear: 'name=Lukas&field1=some%20data'.
|
||||
The information in the field must be encoded by EncodeURLElement function.
|
||||
The returned document is in the "Data" stream. Returns boolean TRUE if all
|
||||
went well.}
|
||||
function HttpPostURL(const URL, URLData: string; const Data: TStream): Boolean;
|
||||
|
||||
{:A very useful function, and example of use can be found in the THTTPSend
|
||||
object. It implements the POST method of the HTTP protocol. This function sends
|
||||
the POST method for a URL document to an HTTP server. This function simulate
|
||||
posting of file by HTML form used method 'multipart/form-data'. Posting file
|
||||
is in DATA stream. Its name is Filename string. Fieldname is for name of
|
||||
formular field with file. (simulate HTML INPUT FILE) The returned document is
|
||||
in the ResultData Stringlist. Returns boolean TRUE if all went well.}
|
||||
function HttpPostFile(const URL, FieldName, FileName: string;
|
||||
const Data: TStream; const ResultData: TStrings): Boolean;
|
||||
|
||||
implementation
|
||||
|
||||
constructor THTTPSend.Create;
|
||||
begin
|
||||
inherited Create;
|
||||
FHeaders := TStringList.Create;
|
||||
FCookies := TStringList.Create;
|
||||
FDocument := TMemoryStream.Create;
|
||||
FSock := TTCPBlockSocket.Create;
|
||||
FSock.Owner := self;
|
||||
FSock.ConvertLineEnd := True;
|
||||
FSock.SizeRecvBuffer := c64k;
|
||||
FSock.SizeSendBuffer := c64k;
|
||||
FTimeout := 90000;
|
||||
FTargetPort := cHttpProtocol;
|
||||
FProxyHost := '';
|
||||
FProxyPort := '8080';
|
||||
FProxyUser := '';
|
||||
FProxyPass := '';
|
||||
FAliveHost := '';
|
||||
FAlivePort := '';
|
||||
FProtocol := '1.0';
|
||||
FKeepAlive := True;
|
||||
FStatus100 := False;
|
||||
FUserAgent := 'Mozilla/4.0 (compatible; Synapse)';
|
||||
FDownloadSize := 0;
|
||||
FUploadSize := 0;
|
||||
FAddPortNumberToHost := true;
|
||||
FKeepAliveTimeout := 300;
|
||||
Clear;
|
||||
end;
|
||||
|
||||
destructor THTTPSend.Destroy;
|
||||
begin
|
||||
FSock.Free;
|
||||
FDocument.Free;
|
||||
FCookies.Free;
|
||||
FHeaders.Free;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
procedure THTTPSend.Clear;
|
||||
begin
|
||||
FRangeStart := 0;
|
||||
FRangeEnd := 0;
|
||||
FDocument.Clear;
|
||||
FHeaders.Clear;
|
||||
FMimeType := 'text/html';
|
||||
end;
|
||||
|
||||
procedure THTTPSend.DecodeStatus(const Value: string);
|
||||
var
|
||||
s, su: string;
|
||||
begin
|
||||
s := Trim(SeparateRight(Value, ' '));
|
||||
su := Trim(SeparateLeft(s, ' '));
|
||||
FResultCode := StrToIntDef(su, 0);
|
||||
FResultString := Trim(SeparateRight(s, ' '));
|
||||
if FResultString = s then
|
||||
FResultString := '';
|
||||
end;
|
||||
|
||||
function THTTPSend.PrepareHeaders: AnsiString;
|
||||
begin
|
||||
if FProtocol = '0.9' then
|
||||
Result := FHeaders[0] + CRLF
|
||||
else
|
||||
{$IFNDEF MSWINDOWS}
|
||||
Result := {$IFDEF UNICODE}AnsiString{$ENDIF}(AdjustLineBreaks(FHeaders.Text, tlbsCRLF));
|
||||
{$ELSE}
|
||||
Result := FHeaders.Text;
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
function THTTPSend.InternalDoConnect(needssl: Boolean): Boolean;
|
||||
begin
|
||||
Result := False;
|
||||
FSock.CloseSocket;
|
||||
FSock.Bind(FIPInterface, cAnyPort);
|
||||
if FSock.LastError <> 0 then
|
||||
Exit;
|
||||
FSock.Connect(FTargetHost, FTargetPort);
|
||||
if FSock.LastError <> 0 then
|
||||
Exit;
|
||||
if needssl then
|
||||
begin
|
||||
if (FSock.SSL.SNIHost='') then
|
||||
FSock.SSL.SNIHost:=FTargetHost;
|
||||
FSock.SSLDoConnect;
|
||||
FSock.SSL.SNIHost:=''; //don't need it anymore and don't wan't to reuse it in next connection
|
||||
if FSock.LastError <> 0 then
|
||||
Exit;
|
||||
end;
|
||||
FAliveHost := FTargetHost;
|
||||
FAlivePort := FTargetPort;
|
||||
Result := True;
|
||||
end;
|
||||
|
||||
function THTTPSend.InternalConnect(needssl: Boolean): Boolean;
|
||||
begin
|
||||
if FSock.Socket = INVALID_SOCKET then
|
||||
Result := InternalDoConnect(needssl)
|
||||
else
|
||||
if (FAliveHost <> FTargetHost) or (FAlivePort <> FTargetPort)
|
||||
or FSock.CanRead(0) then
|
||||
Result := InternalDoConnect(needssl)
|
||||
else
|
||||
Result := True;
|
||||
end;
|
||||
|
||||
function THTTPSend.HTTPMethod(const Method, URL: string): Boolean;
|
||||
var
|
||||
Sending, Receiving: Boolean;
|
||||
status100: Boolean;
|
||||
status100error: string;
|
||||
ToClose: Boolean;
|
||||
Size: Integer;
|
||||
Prot, User, Pass, Host, Port, Path, Para, URI: string;
|
||||
s, su: AnsiString;
|
||||
HttpTunnel: Boolean;
|
||||
n: integer;
|
||||
pp: string;
|
||||
UsingProxy: boolean;
|
||||
l: TStringList;
|
||||
x: integer;
|
||||
begin
|
||||
{initial values}
|
||||
Result := False;
|
||||
FResultCode := 500;
|
||||
FResultString := '';
|
||||
FDownloadSize := 0;
|
||||
FUploadSize := 0;
|
||||
|
||||
URI := ParseURL(URL, Prot, User, Pass, Host, Port, Path, Para);
|
||||
User := DecodeURL(user);
|
||||
Pass := DecodeURL(pass);
|
||||
if User = '' then
|
||||
begin
|
||||
User := FUsername;
|
||||
Pass := FPassword;
|
||||
end;
|
||||
if UpperCase(Prot) = 'HTTPS' then
|
||||
begin
|
||||
HttpTunnel := FProxyHost <> '';
|
||||
FSock.HTTPTunnelIP := FProxyHost;
|
||||
FSock.HTTPTunnelPort := FProxyPort;
|
||||
FSock.HTTPTunnelUser := FProxyUser;
|
||||
FSock.HTTPTunnelPass := FProxyPass;
|
||||
end
|
||||
else
|
||||
begin
|
||||
HttpTunnel := False;
|
||||
FSock.HTTPTunnelIP := '';
|
||||
FSock.HTTPTunnelPort := '';
|
||||
FSock.HTTPTunnelUser := '';
|
||||
FSock.HTTPTunnelPass := '';
|
||||
end;
|
||||
UsingProxy := (FProxyHost <> '') and not(HttpTunnel);
|
||||
Sending := FDocument.Size > 0;
|
||||
{Headers for Sending data}
|
||||
status100 := FStatus100 and Sending and (FProtocol = '1.1');
|
||||
if status100 then
|
||||
FHeaders.Insert(0, 'Expect: 100-continue');
|
||||
if Sending then
|
||||
begin
|
||||
FHeaders.Insert(0, 'Content-Length: ' + IntToStr(FDocument.Size));
|
||||
if FMimeType <> '' then
|
||||
FHeaders.Insert(0, 'Content-Type: ' + FMimeType);
|
||||
end;
|
||||
{ setting User-agent }
|
||||
if FUserAgent <> '' then
|
||||
FHeaders.Insert(0, 'User-Agent: ' + FUserAgent);
|
||||
{ setting Ranges }
|
||||
if (FRangeStart > 0) or (FRangeEnd > 0) then
|
||||
begin
|
||||
if FRangeEnd >= FRangeStart then
|
||||
FHeaders.Insert(0, 'Range: bytes=' + IntToStr(FRangeStart) + '-' + IntToStr(FRangeEnd))
|
||||
else
|
||||
FHeaders.Insert(0, 'Range: bytes=' + IntToStr(FRangeStart) + '-');
|
||||
end;
|
||||
{ setting Cookies }
|
||||
s := '';
|
||||
for n := 0 to FCookies.Count - 1 do
|
||||
begin
|
||||
if s <> '' then
|
||||
s := s + '; ';
|
||||
s := s + FCookies[n];
|
||||
end;
|
||||
if s <> '' then
|
||||
FHeaders.Insert(0, 'Cookie: ' + s);
|
||||
{ setting KeepAlives }
|
||||
pp := '';
|
||||
if UsingProxy then
|
||||
pp := 'Proxy-';
|
||||
if FKeepAlive then
|
||||
begin
|
||||
FHeaders.Insert(0, pp + 'Connection: keep-alive');
|
||||
FHeaders.Insert(0, 'Keep-Alive: ' + IntToStr(FKeepAliveTimeout));
|
||||
end
|
||||
else
|
||||
FHeaders.Insert(0, pp + 'Connection: close');
|
||||
{ set target servers/proxy, authorizations, etc... }
|
||||
if User <> '' then
|
||||
FHeaders.Insert(0, 'Authorization: Basic ' + EncodeBase64(User + ':' + Pass));
|
||||
if UsingProxy and (FProxyUser <> '') then
|
||||
FHeaders.Insert(0, 'Proxy-Authorization: Basic ' +
|
||||
EncodeBase64(FProxyUser + ':' + FProxyPass));
|
||||
if isIP6(Host) then
|
||||
s := '[' + Host + ']'
|
||||
else
|
||||
s := Host;
|
||||
if FAddPortNumberToHost and (Port <> '80') then
|
||||
FHeaders.Insert(0, 'Host: ' + s + ':' + Port)
|
||||
else
|
||||
FHeaders.Insert(0, 'Host: ' + s);
|
||||
if UsingProxy then
|
||||
URI := Prot + '://' + s + ':' + Port + URI;
|
||||
if URI = '/*' then
|
||||
URI := '*';
|
||||
if FProtocol = '0.9' then
|
||||
FHeaders.Insert(0, UpperCase(Method) + ' ' + URI)
|
||||
else
|
||||
FHeaders.Insert(0, UpperCase(Method) + ' ' + URI + ' HTTP/' + FProtocol);
|
||||
if UsingProxy then
|
||||
begin
|
||||
FTargetHost := FProxyHost;
|
||||
FTargetPort := FProxyPort;
|
||||
end
|
||||
else
|
||||
begin
|
||||
FTargetHost := Host;
|
||||
FTargetPort := Port;
|
||||
end;
|
||||
if FHeaders[FHeaders.Count - 1] <> '' then
|
||||
FHeaders.Add('');
|
||||
|
||||
{ connect }
|
||||
if not InternalConnect(UpperCase(Prot) = 'HTTPS') then
|
||||
begin
|
||||
FAliveHost := '';
|
||||
FAlivePort := '';
|
||||
Exit;
|
||||
end;
|
||||
|
||||
{ reading Status }
|
||||
FDocument.Position := 0;
|
||||
Status100Error := '';
|
||||
if status100 then
|
||||
begin
|
||||
{ send Headers }
|
||||
FSock.SendString(PrepareHeaders);
|
||||
if FSock.LastError <> 0 then
|
||||
Exit;
|
||||
repeat
|
||||
s := FSock.RecvString(FTimeout);
|
||||
if s <> '' then
|
||||
Break;
|
||||
until FSock.LastError <> 0;
|
||||
DecodeStatus(s);
|
||||
Status100Error := s;
|
||||
repeat
|
||||
s := FSock.recvstring(FTimeout);
|
||||
if s = '' then
|
||||
Break;
|
||||
until FSock.LastError <> 0;
|
||||
if (FResultCode >= 100) and (FResultCode < 200) then
|
||||
begin
|
||||
{ we can upload content }
|
||||
Status100Error := '';
|
||||
FUploadSize := FDocument.Size;
|
||||
FSock.SendBuffer(FDocument.Memory, FDocument.Size);
|
||||
end;
|
||||
end
|
||||
else
|
||||
{ upload content }
|
||||
if sending then
|
||||
begin
|
||||
if FDocument.Size >= c64k then
|
||||
begin
|
||||
FSock.SendString(PrepareHeaders);
|
||||
FUploadSize := FDocument.Size;
|
||||
FSock.SendBuffer(FDocument.Memory, FDocument.Size);
|
||||
end
|
||||
else
|
||||
begin
|
||||
s := PrepareHeaders + ReadStrFromStream(FDocument, FDocument.Size);
|
||||
FUploadSize := Length(s);
|
||||
FSock.SendString(s);
|
||||
end;
|
||||
end
|
||||
else
|
||||
begin
|
||||
{ we not need to upload document, send headers only }
|
||||
FSock.SendString(PrepareHeaders);
|
||||
end;
|
||||
|
||||
if FSock.LastError <> 0 then
|
||||
Exit;
|
||||
|
||||
Clear;
|
||||
Size := -1;
|
||||
FTransferEncoding := TE_UNKNOWN;
|
||||
|
||||
{ read status }
|
||||
if Status100Error = '' then
|
||||
begin
|
||||
repeat
|
||||
repeat
|
||||
s := FSock.RecvString(FTimeout);
|
||||
if s <> '' then
|
||||
Break;
|
||||
until FSock.LastError <> 0;
|
||||
if Pos('HTTP/', UpperCase(s)) = 1 then
|
||||
begin
|
||||
FHeaders.Add(s);
|
||||
DecodeStatus(s);
|
||||
end
|
||||
else
|
||||
begin
|
||||
{ old HTTP 0.9 and some buggy servers not send result }
|
||||
s := s + CRLF;
|
||||
WriteStrToStream(FDocument, s);
|
||||
FResultCode := 0;
|
||||
end;
|
||||
until (FSock.LastError <> 0) or (FResultCode <> 100);
|
||||
end
|
||||
else
|
||||
FHeaders.Add(Status100Error);
|
||||
|
||||
{ if need receive headers, receive and parse it }
|
||||
ToClose := FProtocol <> '1.1';
|
||||
if FHeaders.Count > 0 then
|
||||
begin
|
||||
l := TStringList.Create;
|
||||
try
|
||||
repeat
|
||||
s := FSock.RecvString(FTimeout);
|
||||
l.Add(s);
|
||||
if s = '' then
|
||||
Break;
|
||||
until FSock.LastError <> 0;
|
||||
x := 0;
|
||||
while l.Count > x do
|
||||
begin
|
||||
s := NormalizeHeader(l, x);
|
||||
FHeaders.Add(s);
|
||||
su := UpperCase(s);
|
||||
if Pos('CONTENT-LENGTH:', su) = 1 then
|
||||
begin
|
||||
Size := StrToIntDef(Trim(SeparateRight(s, ' ')), -1);
|
||||
if (Size <> -1) and (FTransferEncoding = TE_UNKNOWN) then
|
||||
FTransferEncoding := TE_IDENTITY;
|
||||
end;
|
||||
if Pos('CONTENT-TYPE:', su) = 1 then
|
||||
FMimeType := Trim(SeparateRight(s, ' '));
|
||||
if Pos('TRANSFER-ENCODING:', su) = 1 then
|
||||
begin
|
||||
s := Trim(SeparateRight(su, ' '));
|
||||
if Pos('CHUNKED', s) > 0 then
|
||||
FTransferEncoding := TE_CHUNKED;
|
||||
end;
|
||||
if UsingProxy then
|
||||
begin
|
||||
if Pos('PROXY-CONNECTION:', su) = 1 then
|
||||
if Pos('CLOSE', su) > 0 then
|
||||
ToClose := True;
|
||||
end
|
||||
else
|
||||
begin
|
||||
if Pos('CONNECTION:', su) = 1 then
|
||||
if Pos('CLOSE', su) > 0 then
|
||||
ToClose := True;
|
||||
end;
|
||||
end;
|
||||
finally
|
||||
l.free;
|
||||
end;
|
||||
end;
|
||||
|
||||
Result := FSock.LastError = 0;
|
||||
if not Result then
|
||||
Exit;
|
||||
|
||||
{if need receive response body, read it}
|
||||
Receiving := Method <> 'HEAD';
|
||||
Receiving := Receiving and (FResultCode <> 204);
|
||||
Receiving := Receiving and (FResultCode <> 304);
|
||||
if Receiving then
|
||||
case FTransferEncoding of
|
||||
TE_UNKNOWN:
|
||||
Result := ReadUnknown;
|
||||
TE_IDENTITY:
|
||||
Result := ReadIdentity(Size);
|
||||
TE_CHUNKED:
|
||||
Result := ReadChunked;
|
||||
end;
|
||||
|
||||
FDocument.Seek(0, soFromBeginning);
|
||||
if ToClose then
|
||||
begin
|
||||
FSock.CloseSocket;
|
||||
FAliveHost := '';
|
||||
FAlivePort := '';
|
||||
end;
|
||||
ParseCookies;
|
||||
end;
|
||||
|
||||
function THTTPSend.ReadUnknown: Boolean;
|
||||
var
|
||||
s: ansistring;
|
||||
begin
|
||||
Result := false;
|
||||
repeat
|
||||
s := FSock.RecvPacket(FTimeout);
|
||||
if FSock.LastError = 0 then
|
||||
WriteStrToStream(FDocument, s);
|
||||
until FSock.LastError <> 0;
|
||||
if FSock.LastError = WSAECONNRESET then
|
||||
begin
|
||||
Result := true;
|
||||
FSock.ResetLastError;
|
||||
end;
|
||||
end;
|
||||
|
||||
function THTTPSend.ReadIdentity(Size: Integer): Boolean;
|
||||
begin
|
||||
if Size > 0 then
|
||||
begin
|
||||
FDownloadSize := Size;
|
||||
FSock.RecvStreamSize(FDocument, FTimeout, Size);
|
||||
FDocument.Position := FDocument.Size;
|
||||
Result := FSock.LastError = 0;
|
||||
end
|
||||
else
|
||||
Result := true;
|
||||
end;
|
||||
|
||||
function THTTPSend.ReadChunked: Boolean;
|
||||
var
|
||||
s: ansistring;
|
||||
Size: Integer;
|
||||
begin
|
||||
repeat
|
||||
repeat
|
||||
s := FSock.RecvString(FTimeout);
|
||||
until (s <> '') or (FSock.LastError <> 0);
|
||||
if FSock.LastError <> 0 then
|
||||
Break;
|
||||
s := Trim(SeparateLeft(s, ' '));
|
||||
s := Trim(SeparateLeft(s, ';'));
|
||||
Size := StrToIntDef('$' + s, 0);
|
||||
if Size = 0 then
|
||||
Break;
|
||||
if not ReadIdentity(Size) then
|
||||
break;
|
||||
until False;
|
||||
Result := FSock.LastError = 0;
|
||||
end;
|
||||
|
||||
procedure THTTPSend.ParseCookies;
|
||||
var
|
||||
n: integer;
|
||||
s: string;
|
||||
sn, sv: string;
|
||||
begin
|
||||
for n := 0 to FHeaders.Count - 1 do
|
||||
if Pos('set-cookie:', lowercase(FHeaders[n])) = 1 then
|
||||
begin
|
||||
s := SeparateRight(FHeaders[n], ':');
|
||||
s := trim(SeparateLeft(s, ';'));
|
||||
sn := trim(SeparateLeft(s, '='));
|
||||
sv := trim(SeparateRight(s, '='));
|
||||
FCookies.Values[sn] := sv;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure THTTPSend.Abort;
|
||||
begin
|
||||
FSock.StopFlag := True;
|
||||
end;
|
||||
|
||||
{==============================================================================}
|
||||
|
||||
function HttpGetText(const URL: string; const Response: TStrings): Boolean;
|
||||
var
|
||||
HTTP: THTTPSend;
|
||||
begin
|
||||
HTTP := THTTPSend.Create;
|
||||
try
|
||||
Result := HTTP.HTTPMethod('GET', URL);
|
||||
if Result then
|
||||
Response.LoadFromStream(HTTP.Document);
|
||||
finally
|
||||
HTTP.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
function HttpGetBinary(const URL: string; const Response: TStream): Boolean;
|
||||
var
|
||||
HTTP: THTTPSend;
|
||||
begin
|
||||
HTTP := THTTPSend.Create;
|
||||
try
|
||||
Result := HTTP.HTTPMethod('GET', URL);
|
||||
if Result then
|
||||
begin
|
||||
Response.Seek(0, soFromBeginning);
|
||||
Response.CopyFrom(HTTP.Document, 0);
|
||||
end;
|
||||
finally
|
||||
HTTP.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
function HttpPostBinary(const URL: string; const Data: TStream): Boolean;
|
||||
var
|
||||
HTTP: THTTPSend;
|
||||
begin
|
||||
HTTP := THTTPSend.Create;
|
||||
try
|
||||
HTTP.Document.CopyFrom(Data, 0);
|
||||
HTTP.MimeType := 'Application/octet-stream';
|
||||
Result := HTTP.HTTPMethod('POST', URL);
|
||||
Data.Size := 0;
|
||||
if Result then
|
||||
begin
|
||||
Data.Seek(0, soFromBeginning);
|
||||
Data.CopyFrom(HTTP.Document, 0);
|
||||
end;
|
||||
finally
|
||||
HTTP.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
function HttpPostURL(const URL, URLData: string; const Data: TStream): Boolean;
|
||||
var
|
||||
HTTP: THTTPSend;
|
||||
begin
|
||||
HTTP := THTTPSend.Create;
|
||||
try
|
||||
WriteStrToStream(HTTP.Document, URLData);
|
||||
HTTP.MimeType := 'application/x-www-form-urlencoded';
|
||||
Result := HTTP.HTTPMethod('POST', URL);
|
||||
if Result then
|
||||
Data.CopyFrom(HTTP.Document, 0);
|
||||
finally
|
||||
HTTP.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
function HttpPostFile(const URL, FieldName, FileName: string;
|
||||
const Data: TStream; const ResultData: TStrings): Boolean;
|
||||
var
|
||||
HTTP: THTTPSend;
|
||||
Bound, s: string;
|
||||
begin
|
||||
Bound := IntToHex(Random(MaxInt), 8) + '_Synapse_boundary';
|
||||
HTTP := THTTPSend.Create;
|
||||
try
|
||||
s := '--' + Bound + CRLF;
|
||||
s := s + 'content-disposition: form-data; name="' + FieldName + '";';
|
||||
s := s + ' filename="' + FileName +'"' + CRLF;
|
||||
s := s + 'Content-Type: Application/octet-string' + CRLF + CRLF;
|
||||
WriteStrToStream(HTTP.Document, s);
|
||||
HTTP.Document.CopyFrom(Data, 0);
|
||||
s := CRLF + '--' + Bound + '--' + CRLF;
|
||||
WriteStrToStream(HTTP.Document, s);
|
||||
HTTP.MimeType := 'multipart/form-data; boundary=' + Bound;
|
||||
Result := HTTP.HTTPMethod('POST', URL);
|
||||
if Result then
|
||||
ResultData.LoadFromStream(HTTP.Document);
|
||||
finally
|
||||
HTTP.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
end.
|
869
synapse/imapsend.pas
Normal file
869
synapse/imapsend.pas
Normal file
@ -0,0 +1,869 @@
|
||||
{==============================================================================|
|
||||
| Project : Ararat Synapse | 002.005.003 |
|
||||
|==============================================================================|
|
||||
| Content: IMAP4rev1 client |
|
||||
|==============================================================================|
|
||||
| Copyright (c)1999-2012, Lukas Gebauer |
|
||||
| All rights reserved. |
|
||||
| |
|
||||
| Redistribution and use in source and binary forms, with or without |
|
||||
| modification, are permitted provided that the following conditions are met: |
|
||||
| |
|
||||
| Redistributions of source code must retain the above copyright notice, this |
|
||||
| list of conditions and the following disclaimer. |
|
||||
| |
|
||||
| Redistributions in binary form must reproduce the above copyright notice, |
|
||||
| this list of conditions and the following disclaimer in the documentation |
|
||||
| and/or other materials provided with the distribution. |
|
||||
| |
|
||||
| Neither the name of Lukas Gebauer nor the names of its contributors may |
|
||||
| be used to endorse or promote products derived from this software without |
|
||||
| specific prior written permission. |
|
||||
| |
|
||||
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
|
||||
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
|
||||
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
|
||||
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
|
||||
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
|
||||
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
|
||||
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
|
||||
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
|
||||
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
|
||||
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
|
||||
| DAMAGE. |
|
||||
|==============================================================================|
|
||||
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
|
||||
| Portions created by Lukas Gebauer are Copyright (c)2001-2012. |
|
||||
| All Rights Reserved. |
|
||||
|==============================================================================|
|
||||
| Contributor(s): |
|
||||
|==============================================================================|
|
||||
| History: see HISTORY.HTM from distribution package |
|
||||
| (Found at URL: http://www.ararat.cz/synapse/) |
|
||||
|==============================================================================}
|
||||
|
||||
{:@abstract(IMAP4 rev1 protocol client)
|
||||
|
||||
Used RFC: RFC-2060, RFC-2595
|
||||
}
|
||||
|
||||
{$IFDEF FPC}
|
||||
{$MODE DELPHI}
|
||||
{$ENDIF}
|
||||
{$H+}
|
||||
|
||||
{$IFDEF UNICODE}
|
||||
{$WARN IMPLICIT_STRING_CAST OFF}
|
||||
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
|
||||
{$ENDIF}
|
||||
|
||||
unit imapsend;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
SysUtils, Classes,
|
||||
blcksock, synautil;
|
||||
|
||||
const
|
||||
cIMAPProtocol = '143';
|
||||
|
||||
type
|
||||
{:@abstract(Implementation of IMAP4 protocol.)
|
||||
Note: Are you missing properties for setting Username and Password? Look to
|
||||
parent @link(TSynaClient) object!
|
||||
|
||||
Are you missing properties for specify server address and port? Look to
|
||||
parent @link(TSynaClient) too!}
|
||||
TIMAPSend = class(TSynaClient)
|
||||
protected
|
||||
FSock: TTCPBlockSocket;
|
||||
FTagCommand: integer;
|
||||
FResultString: string;
|
||||
FFullResult: TStringList;
|
||||
FIMAPcap: TStringList;
|
||||
FAuthDone: Boolean;
|
||||
FSelectedFolder: string;
|
||||
FSelectedCount: integer;
|
||||
FSelectedRecent: integer;
|
||||
FSelectedUIDvalidity: integer;
|
||||
FUID: Boolean;
|
||||
FAutoTLS: Boolean;
|
||||
FFullSSL: Boolean;
|
||||
function ReadResult: string;
|
||||
function AuthLogin: Boolean;
|
||||
function Connect: Boolean;
|
||||
procedure ParseMess(Value:TStrings);
|
||||
procedure ParseFolderList(Value:TStrings);
|
||||
procedure ParseSelect;
|
||||
procedure ParseSearch(Value:TStrings);
|
||||
procedure ProcessLiterals;
|
||||
public
|
||||
constructor Create;
|
||||
destructor Destroy; override;
|
||||
|
||||
{:By this function you can call any IMAP command. Result of this command is
|
||||
in adequate properties.}
|
||||
function IMAPcommand(Value: string): string;
|
||||
|
||||
{:By this function you can call any IMAP command what need upload any data.
|
||||
Result of this command is in adequate properties.}
|
||||
function IMAPuploadCommand(Value: string; const Data:TStrings): string;
|
||||
|
||||
{:Call CAPABILITY command and fill IMAPcap property by new values.}
|
||||
function Capability: Boolean;
|
||||
|
||||
{:Connect to IMAP server and do login to this server. This command begin
|
||||
session.}
|
||||
function Login: Boolean;
|
||||
|
||||
{:Disconnect from IMAP server and terminate session session. If exists some
|
||||
deleted and non-purged messages, these messages are not deleted!}
|
||||
function Logout: Boolean;
|
||||
|
||||
{:Do NOOP. It is for prevent disconnect by timeout.}
|
||||
function NoOp: Boolean;
|
||||
|
||||
{:Lists folder names. You may specify level of listing. If you specify
|
||||
FromFolder as empty string, return is all folders in system.}
|
||||
function List(FromFolder: string; const FolderList: TStrings): Boolean;
|
||||
|
||||
{:Lists folder names what match search criteria. You may specify level of
|
||||
listing. If you specify FromFolder as empty string, return is all folders
|
||||
in system.}
|
||||
function ListSearch(FromFolder, Search: string; const FolderList: TStrings): Boolean;
|
||||
|
||||
{:Lists subscribed folder names. You may specify level of listing. If you
|
||||
specify FromFolder as empty string, return is all subscribed folders in
|
||||
system.}
|
||||
function ListSubscribed(FromFolder: string; const FolderList: TStrings): Boolean;
|
||||
|
||||
{:Lists subscribed folder names what matching search criteria. You may
|
||||
specify level of listing. If you specify FromFolder as empty string, return
|
||||
is all subscribed folders in system.}
|
||||
function ListSearchSubscribed(FromFolder, Search: string; const FolderList: TStrings): Boolean;
|
||||
|
||||
{:Create a new folder.}
|
||||
function CreateFolder(FolderName: string): Boolean;
|
||||
|
||||
{:Delete a folder.}
|
||||
function DeleteFolder(FolderName: string): Boolean;
|
||||
|
||||
{:Rename folder names.}
|
||||
function RenameFolder(FolderName, NewFolderName: string): Boolean;
|
||||
|
||||
{:Subscribe folder.}
|
||||
function SubscribeFolder(FolderName: string): Boolean;
|
||||
|
||||
{:Unsubscribe folder.}
|
||||
function UnsubscribeFolder(FolderName: string): Boolean;
|
||||
|
||||
{:Select folder.}
|
||||
function SelectFolder(FolderName: string): Boolean;
|
||||
|
||||
{:Select folder, but only for reading. Any changes are not allowed!}
|
||||
function SelectROFolder(FolderName: string): Boolean;
|
||||
|
||||
{:Close a folder. (end of Selected state)}
|
||||
function CloseFolder: Boolean;
|
||||
|
||||
{:Ask for given status of folder. I.e. if you specify as value 'UNSEEN',
|
||||
result is number of unseen messages in folder. For another status
|
||||
indentificator check IMAP documentation and documentation of your IMAP
|
||||
server (each IMAP server can have their own statuses.)}
|
||||
function StatusFolder(FolderName, Value: string): integer;
|
||||
|
||||
{:Hardly delete all messages marked as 'deleted' in current selected folder.}
|
||||
function ExpungeFolder: Boolean;
|
||||
|
||||
{:Touch to folder. (use as update status of folder, etc.)}
|
||||
function CheckFolder: Boolean;
|
||||
|
||||
{:Append given message to specified folder.}
|
||||
function AppendMess(ToFolder: string; const Mess: TStrings): Boolean;
|
||||
|
||||
{:'Delete' message from current selected folder. It mark message as Deleted.
|
||||
Real deleting will be done after sucessfull @link(CloseFolder) or
|
||||
@link(ExpungeFolder)}
|
||||
function DeleteMess(MessID: integer): boolean;
|
||||
|
||||
{:Get full message from specified message in selected folder.}
|
||||
function FetchMess(MessID: integer; const Mess: TStrings): Boolean;
|
||||
|
||||
{:Get message headers only from specified message in selected folder.}
|
||||
function FetchHeader(MessID: integer; const Headers: TStrings): Boolean;
|
||||
|
||||
{:Return message size of specified message from current selected folder.}
|
||||
function MessageSize(MessID: integer): integer;
|
||||
|
||||
{:Copy message from current selected folder to another folder.}
|
||||
function CopyMess(MessID: integer; ToFolder: string): Boolean;
|
||||
|
||||
{:Return message numbers from currently selected folder as result
|
||||
of searching. Search criteria is very complex language (see to IMAP
|
||||
specification) similar to SQL (but not same syntax!).}
|
||||
function SearchMess(Criteria: string; const FoundMess: TStrings): Boolean;
|
||||
|
||||
{:Sets flags of message from current selected folder.}
|
||||
function SetFlagsMess(MessID: integer; Flags: string): Boolean;
|
||||
|
||||
{:Gets flags of message from current selected folder.}
|
||||
function GetFlagsMess(MessID: integer; var Flags: string): Boolean;
|
||||
|
||||
{:Add flags to message's flags.}
|
||||
function AddFlagsMess(MessID: integer; Flags: string): Boolean;
|
||||
|
||||
{:Remove flags from message's flags.}
|
||||
function DelFlagsMess(MessID: integer; Flags: string): Boolean;
|
||||
|
||||
{:Call STARTTLS command for upgrade connection to SSL/TLS mode.}
|
||||
function StartTLS: Boolean;
|
||||
|
||||
{:return UID of requested message ID.}
|
||||
function GetUID(MessID: integer; var UID : Integer): Boolean;
|
||||
|
||||
{:Try to find given capabily in capabilty string returned from IMAP server.}
|
||||
function FindCap(const Value: string): string;
|
||||
published
|
||||
{:Status line with result of last operation.}
|
||||
property ResultString: string read FResultString;
|
||||
|
||||
{:Full result of last IMAP operation.}
|
||||
property FullResult: TStringList read FFullResult;
|
||||
|
||||
{:List of server capabilites.}
|
||||
property IMAPcap: TStringList read FIMAPcap;
|
||||
|
||||
{:Authorization is successful done.}
|
||||
property AuthDone: Boolean read FAuthDone;
|
||||
|
||||
{:Turn on or off usage of UID (unicate identificator) of messages instead
|
||||
only sequence numbers.}
|
||||
property UID: Boolean read FUID Write FUID;
|
||||
|
||||
{:Name of currently selected folder.}
|
||||
property SelectedFolder: string read FSelectedFolder;
|
||||
|
||||
{:Count of messages in currently selected folder.}
|
||||
property SelectedCount: integer read FSelectedCount;
|
||||
|
||||
{:Count of not-visited messages in currently selected folder.}
|
||||
property SelectedRecent: integer read FSelectedRecent;
|
||||
|
||||
{:This number with name of folder is unique indentificator of folder.
|
||||
(If someone delete folder and next create new folder with exactly same name
|
||||
of folder, this number is must be different!)}
|
||||
property SelectedUIDvalidity: integer read FSelectedUIDvalidity;
|
||||
|
||||
{:If is set to true, then upgrade to SSL/TLS mode if remote server support it.}
|
||||
property AutoTLS: Boolean read FAutoTLS Write FAutoTLS;
|
||||
|
||||
{:SSL/TLS mode is used from first contact to server. Servers with full
|
||||
SSL/TLS mode usualy using non-standard TCP port!}
|
||||
property FullSSL: Boolean read FFullSSL Write FFullSSL;
|
||||
|
||||
{:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.}
|
||||
property Sock: TTCPBlockSocket read FSock;
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
constructor TIMAPSend.Create;
|
||||
begin
|
||||
inherited Create;
|
||||
FFullResult := TStringList.Create;
|
||||
FIMAPcap := TStringList.Create;
|
||||
FSock := TTCPBlockSocket.Create;
|
||||
FSock.Owner := self;
|
||||
FSock.ConvertLineEnd := True;
|
||||
FSock.SizeRecvBuffer := 32768;
|
||||
FSock.SizeSendBuffer := 32768;
|
||||
FTimeout := 60000;
|
||||
FTargetPort := cIMAPProtocol;
|
||||
FTagCommand := 0;
|
||||
FSelectedFolder := '';
|
||||
FSelectedCount := 0;
|
||||
FSelectedRecent := 0;
|
||||
FSelectedUIDvalidity := 0;
|
||||
FUID := False;
|
||||
FAutoTLS := False;
|
||||
FFullSSL := False;
|
||||
end;
|
||||
|
||||
destructor TIMAPSend.Destroy;
|
||||
begin
|
||||
FSock.Free;
|
||||
FIMAPcap.Free;
|
||||
FFullResult.Free;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
|
||||
function TIMAPSend.ReadResult: string;
|
||||
var
|
||||
s: string;
|
||||
x, l: integer;
|
||||
begin
|
||||
Result := '';
|
||||
FFullResult.Clear;
|
||||
FResultString := '';
|
||||
repeat
|
||||
s := FSock.RecvString(FTimeout);
|
||||
if Pos('S' + IntToStr(FTagCommand) + ' ', s) = 1 then
|
||||
begin
|
||||
FResultString := s;
|
||||
break;
|
||||
end
|
||||
else
|
||||
FFullResult.Add(s);
|
||||
if (s <> '') and (s[Length(s)]='}') then
|
||||
begin
|
||||
s := Copy(s, 1, Length(s) - 1);
|
||||
x := RPos('{', s);
|
||||
s := Copy(s, x + 1, Length(s) - x);
|
||||
l := StrToIntDef(s, -1);
|
||||
if l <> -1 then
|
||||
begin
|
||||
s := FSock.RecvBufferStr(l, FTimeout);
|
||||
FFullResult.Add(s);
|
||||
end;
|
||||
end;
|
||||
until FSock.LastError <> 0;
|
||||
s := Trim(separateright(FResultString, ' '));
|
||||
Result:=uppercase(Trim(separateleft(s, ' ')));
|
||||
end;
|
||||
|
||||
procedure TIMAPSend.ProcessLiterals;
|
||||
var
|
||||
l: TStringList;
|
||||
n, x: integer;
|
||||
b: integer;
|
||||
s: string;
|
||||
begin
|
||||
l := TStringList.Create;
|
||||
try
|
||||
l.Assign(FFullResult);
|
||||
FFullResult.Clear;
|
||||
b := 0;
|
||||
for n := 0 to l.Count - 1 do
|
||||
begin
|
||||
s := l[n];
|
||||
if b > 0 then
|
||||
begin
|
||||
FFullResult[FFullresult.Count - 1] :=
|
||||
FFullResult[FFullresult.Count - 1] + s;
|
||||
inc(b);
|
||||
if b > 2 then
|
||||
b := 0;
|
||||
end
|
||||
else
|
||||
begin
|
||||
if (s <> '') and (s[Length(s)]='}') then
|
||||
begin
|
||||
x := RPos('{', s);
|
||||
Delete(s, x, Length(s) - x + 1);
|
||||
b := 1;
|
||||
end
|
||||
else
|
||||
b := 0;
|
||||
FFullResult.Add(s);
|
||||
end;
|
||||
end;
|
||||
finally
|
||||
l.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TIMAPSend.IMAPcommand(Value: string): string;
|
||||
begin
|
||||
Inc(FTagCommand);
|
||||
FSock.SendString('S' + IntToStr(FTagCommand) + ' ' + Value + CRLF);
|
||||
Result := ReadResult;
|
||||
end;
|
||||
|
||||
function TIMAPSend.IMAPuploadCommand(Value: string; const Data:TStrings): string;
|
||||
var
|
||||
l: integer;
|
||||
begin
|
||||
Inc(FTagCommand);
|
||||
l := Length(Data.Text);
|
||||
FSock.SendString('S' + IntToStr(FTagCommand) + ' ' + Value + ' {'+ IntToStr(l) + '}' + CRLF);
|
||||
FSock.RecvString(FTimeout);
|
||||
FSock.SendString(Data.Text + CRLF);
|
||||
Result := ReadResult;
|
||||
end;
|
||||
|
||||
procedure TIMAPSend.ParseMess(Value:TStrings);
|
||||
var
|
||||
n: integer;
|
||||
begin
|
||||
Value.Clear;
|
||||
for n := 0 to FFullResult.Count - 2 do
|
||||
if (length(FFullResult[n]) > 0) and (FFullResult[n][Length(FFullResult[n])] = '}') then
|
||||
begin
|
||||
Value.Text := FFullResult[n + 1];
|
||||
Break;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TIMAPSend.ParseFolderList(Value:TStrings);
|
||||
var
|
||||
n, x: integer;
|
||||
s: string;
|
||||
begin
|
||||
ProcessLiterals;
|
||||
Value.Clear;
|
||||
for n := 0 to FFullResult.Count - 1 do
|
||||
begin
|
||||
s := FFullResult[n];
|
||||
if (s <> '') and (Pos('\NOSELECT', UpperCase(s)) = 0) then
|
||||
begin
|
||||
if s[Length(s)] = '"' then
|
||||
begin
|
||||
Delete(s, Length(s), 1);
|
||||
x := RPos('"', s);
|
||||
end
|
||||
else
|
||||
x := RPos(' ', s);
|
||||
if (x > 0) then
|
||||
Value.Add(Copy(s, x + 1, Length(s) - x));
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TIMAPSend.ParseSelect;
|
||||
var
|
||||
n: integer;
|
||||
s, t: string;
|
||||
begin
|
||||
ProcessLiterals;
|
||||
FSelectedCount := 0;
|
||||
FSelectedRecent := 0;
|
||||
FSelectedUIDvalidity := 0;
|
||||
for n := 0 to FFullResult.Count - 1 do
|
||||
begin
|
||||
s := uppercase(FFullResult[n]);
|
||||
if Pos(' EXISTS', s) > 0 then
|
||||
begin
|
||||
t := Trim(separateleft(s, ' EXISTS'));
|
||||
t := Trim(separateright(t, '* '));
|
||||
FSelectedCount := StrToIntDef(t, 0);
|
||||
end;
|
||||
if Pos(' RECENT', s) > 0 then
|
||||
begin
|
||||
t := Trim(separateleft(s, ' RECENT'));
|
||||
t := Trim(separateright(t, '* '));
|
||||
FSelectedRecent := StrToIntDef(t, 0);
|
||||
end;
|
||||
if Pos('UIDVALIDITY', s) > 0 then
|
||||
begin
|
||||
t := Trim(separateright(s, 'UIDVALIDITY '));
|
||||
t := Trim(separateleft(t, ']'));
|
||||
FSelectedUIDvalidity := StrToIntDef(t, 0);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TIMAPSend.ParseSearch(Value:TStrings);
|
||||
var
|
||||
n: integer;
|
||||
s: string;
|
||||
begin
|
||||
ProcessLiterals;
|
||||
Value.Clear;
|
||||
for n := 0 to FFullResult.Count - 1 do
|
||||
begin
|
||||
s := uppercase(FFullResult[n]);
|
||||
if Pos('* SEARCH', s) = 1 then
|
||||
begin
|
||||
s := Trim(SeparateRight(s, '* SEARCH'));
|
||||
while s <> '' do
|
||||
Value.Add(Fetch(s, ' '));
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TIMAPSend.FindCap(const Value: string): string;
|
||||
var
|
||||
n: Integer;
|
||||
s: string;
|
||||
begin
|
||||
s := UpperCase(Value);
|
||||
Result := '';
|
||||
for n := 0 to FIMAPcap.Count - 1 do
|
||||
if Pos(s, UpperCase(FIMAPcap[n])) = 1 then
|
||||
begin
|
||||
Result := FIMAPcap[n];
|
||||
Break;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TIMAPSend.AuthLogin: Boolean;
|
||||
begin
|
||||
Result := IMAPcommand('LOGIN "' + FUsername + '" "' + FPassword + '"') = 'OK';
|
||||
end;
|
||||
|
||||
function TIMAPSend.Connect: Boolean;
|
||||
begin
|
||||
FSock.CloseSocket;
|
||||
FSock.Bind(FIPInterface, cAnyPort);
|
||||
if FSock.LastError = 0 then
|
||||
FSock.Connect(FTargetHost, FTargetPort);
|
||||
if FSock.LastError = 0 then
|
||||
if FFullSSL then
|
||||
FSock.SSLDoConnect;
|
||||
Result := FSock.LastError = 0;
|
||||
end;
|
||||
|
||||
function TIMAPSend.Capability: Boolean;
|
||||
var
|
||||
n: Integer;
|
||||
s, t: string;
|
||||
begin
|
||||
Result := False;
|
||||
FIMAPcap.Clear;
|
||||
s := IMAPcommand('CAPABILITY');
|
||||
if s = 'OK' then
|
||||
begin
|
||||
ProcessLiterals;
|
||||
for n := 0 to FFullResult.Count - 1 do
|
||||
if Pos('* CAPABILITY ', FFullResult[n]) = 1 then
|
||||
begin
|
||||
s := Trim(SeparateRight(FFullResult[n], '* CAPABILITY '));
|
||||
while not (s = '') do
|
||||
begin
|
||||
t := Trim(separateleft(s, ' '));
|
||||
s := Trim(separateright(s, ' '));
|
||||
if s = t then
|
||||
s := '';
|
||||
FIMAPcap.Add(t);
|
||||
end;
|
||||
end;
|
||||
Result := True;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TIMAPSend.Login: Boolean;
|
||||
var
|
||||
s: string;
|
||||
begin
|
||||
FSelectedFolder := '';
|
||||
FSelectedCount := 0;
|
||||
FSelectedRecent := 0;
|
||||
FSelectedUIDvalidity := 0;
|
||||
Result := False;
|
||||
FAuthDone := False;
|
||||
if not Connect then
|
||||
Exit;
|
||||
s := FSock.RecvString(FTimeout);
|
||||
if Pos('* PREAUTH', s) = 1 then
|
||||
FAuthDone := True
|
||||
else
|
||||
if Pos('* OK', s) = 1 then
|
||||
FAuthDone := False
|
||||
else
|
||||
Exit;
|
||||
if Capability then
|
||||
begin
|
||||
if Findcap('IMAP4rev1') = '' then
|
||||
Exit;
|
||||
if FAutoTLS and (Findcap('STARTTLS') <> '') then
|
||||
if StartTLS then
|
||||
Capability;
|
||||
end;
|
||||
Result := AuthLogin;
|
||||
end;
|
||||
|
||||
function TIMAPSend.Logout: Boolean;
|
||||
begin
|
||||
Result := IMAPcommand('LOGOUT') = 'OK';
|
||||
FSelectedFolder := '';
|
||||
FSock.CloseSocket;
|
||||
end;
|
||||
|
||||
function TIMAPSend.NoOp: Boolean;
|
||||
begin
|
||||
Result := IMAPcommand('NOOP') = 'OK';
|
||||
end;
|
||||
|
||||
function TIMAPSend.List(FromFolder: string; const FolderList: TStrings): Boolean;
|
||||
begin
|
||||
Result := IMAPcommand('LIST "' + FromFolder + '" *') = 'OK';
|
||||
ParseFolderList(FolderList);
|
||||
end;
|
||||
|
||||
function TIMAPSend.ListSearch(FromFolder, Search: string; const FolderList: TStrings): Boolean;
|
||||
begin
|
||||
Result := IMAPcommand('LIST "' + FromFolder + '" "' + Search +'"') = 'OK';
|
||||
ParseFolderList(FolderList);
|
||||
end;
|
||||
|
||||
function TIMAPSend.ListSubscribed(FromFolder: string; const FolderList: TStrings): Boolean;
|
||||
begin
|
||||
Result := IMAPcommand('LSUB "' + FromFolder + '" *') = 'OK';
|
||||
ParseFolderList(FolderList);
|
||||
end;
|
||||
|
||||
function TIMAPSend.ListSearchSubscribed(FromFolder, Search: string; const FolderList: TStrings): Boolean;
|
||||
begin
|
||||
Result := IMAPcommand('LSUB "' + FromFolder + '" "' + Search +'"') = 'OK';
|
||||
ParseFolderList(FolderList);
|
||||
end;
|
||||
|
||||
function TIMAPSend.CreateFolder(FolderName: string): Boolean;
|
||||
begin
|
||||
Result := IMAPcommand('CREATE "' + FolderName + '"') = 'OK';
|
||||
end;
|
||||
|
||||
function TIMAPSend.DeleteFolder(FolderName: string): Boolean;
|
||||
begin
|
||||
Result := IMAPcommand('DELETE "' + FolderName + '"') = 'OK';
|
||||
end;
|
||||
|
||||
function TIMAPSend.RenameFolder(FolderName, NewFolderName: string): Boolean;
|
||||
begin
|
||||
Result := IMAPcommand('RENAME "' + FolderName + '" "' + NewFolderName + '"') = 'OK';
|
||||
end;
|
||||
|
||||
function TIMAPSend.SubscribeFolder(FolderName: string): Boolean;
|
||||
begin
|
||||
Result := IMAPcommand('SUBSCRIBE "' + FolderName + '"') = 'OK';
|
||||
end;
|
||||
|
||||
function TIMAPSend.UnsubscribeFolder(FolderName: string): Boolean;
|
||||
begin
|
||||
Result := IMAPcommand('UNSUBSCRIBE "' + FolderName + '"') = 'OK';
|
||||
end;
|
||||
|
||||
function TIMAPSend.SelectFolder(FolderName: string): Boolean;
|
||||
begin
|
||||
Result := IMAPcommand('SELECT "' + FolderName + '"') = 'OK';
|
||||
FSelectedFolder := FolderName;
|
||||
ParseSelect;
|
||||
end;
|
||||
|
||||
function TIMAPSend.SelectROFolder(FolderName: string): Boolean;
|
||||
begin
|
||||
Result := IMAPcommand('EXAMINE "' + FolderName + '"') = 'OK';
|
||||
FSelectedFolder := FolderName;
|
||||
ParseSelect;
|
||||
end;
|
||||
|
||||
function TIMAPSend.CloseFolder: Boolean;
|
||||
begin
|
||||
Result := IMAPcommand('CLOSE') = 'OK';
|
||||
FSelectedFolder := '';
|
||||
end;
|
||||
|
||||
function TIMAPSend.StatusFolder(FolderName, Value: string): integer;
|
||||
var
|
||||
n: integer;
|
||||
s, t: string;
|
||||
begin
|
||||
Result := -1;
|
||||
Value := Uppercase(Value);
|
||||
if IMAPcommand('STATUS "' + FolderName + '" (' + Value + ')' ) = 'OK' then
|
||||
begin
|
||||
ProcessLiterals;
|
||||
for n := 0 to FFullResult.Count - 1 do
|
||||
begin
|
||||
s := FFullResult[n];
|
||||
// s := UpperCase(FFullResult[n]);
|
||||
if (Pos('* ', s) = 1) and (Pos(FolderName, s) >= 1) and (Pos(Value, s) > 0 ) then
|
||||
begin
|
||||
t := SeparateRight(s, Value);
|
||||
t := SeparateLeft(t, ')');
|
||||
t := trim(t);
|
||||
Result := StrToIntDef(t, -1);
|
||||
Break;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TIMAPSend.ExpungeFolder: Boolean;
|
||||
begin
|
||||
Result := IMAPcommand('EXPUNGE') = 'OK';
|
||||
end;
|
||||
|
||||
function TIMAPSend.CheckFolder: Boolean;
|
||||
begin
|
||||
Result := IMAPcommand('CHECK') = 'OK';
|
||||
end;
|
||||
|
||||
function TIMAPSend.AppendMess(ToFolder: string; const Mess: TStrings): Boolean;
|
||||
begin
|
||||
Result := IMAPuploadCommand('APPEND "' + ToFolder + '"', Mess) = 'OK';
|
||||
end;
|
||||
|
||||
function TIMAPSend.DeleteMess(MessID: integer): boolean;
|
||||
var
|
||||
s: string;
|
||||
begin
|
||||
s := 'STORE ' + IntToStr(MessID) + ' +FLAGS.SILENT (\Deleted)';
|
||||
if FUID then
|
||||
s := 'UID ' + s;
|
||||
Result := IMAPcommand(s) = 'OK';
|
||||
end;
|
||||
|
||||
function TIMAPSend.FetchMess(MessID: integer; const Mess: TStrings): Boolean;
|
||||
var
|
||||
s: string;
|
||||
begin
|
||||
s := 'FETCH ' + IntToStr(MessID) + ' (RFC822)';
|
||||
if FUID then
|
||||
s := 'UID ' + s;
|
||||
Result := IMAPcommand(s) = 'OK';
|
||||
ParseMess(Mess);
|
||||
end;
|
||||
|
||||
function TIMAPSend.FetchHeader(MessID: integer; const Headers: TStrings): Boolean;
|
||||
var
|
||||
s: string;
|
||||
begin
|
||||
s := 'FETCH ' + IntToStr(MessID) + ' (RFC822.HEADER)';
|
||||
if FUID then
|
||||
s := 'UID ' + s;
|
||||
Result := IMAPcommand(s) = 'OK';
|
||||
ParseMess(Headers);
|
||||
end;
|
||||
|
||||
function TIMAPSend.MessageSize(MessID: integer): integer;
|
||||
var
|
||||
n: integer;
|
||||
s, t: string;
|
||||
begin
|
||||
Result := -1;
|
||||
s := 'FETCH ' + IntToStr(MessID) + ' (RFC822.SIZE)';
|
||||
if FUID then
|
||||
s := 'UID ' + s;
|
||||
if IMAPcommand(s) = 'OK' then
|
||||
begin
|
||||
ProcessLiterals;
|
||||
for n := 0 to FFullResult.Count - 1 do
|
||||
begin
|
||||
s := UpperCase(FFullResult[n]);
|
||||
if (Pos('* ', s) = 1) and (Pos('RFC822.SIZE', s) > 0 ) then
|
||||
begin
|
||||
t := SeparateRight(s, 'RFC822.SIZE ');
|
||||
t := Trim(SeparateLeft(t, ')'));
|
||||
t := Trim(SeparateLeft(t, ' '));
|
||||
Result := StrToIntDef(t, -1);
|
||||
Break;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TIMAPSend.CopyMess(MessID: integer; ToFolder: string): Boolean;
|
||||
var
|
||||
s: string;
|
||||
begin
|
||||
s := 'COPY ' + IntToStr(MessID) + ' "' + ToFolder + '"';
|
||||
if FUID then
|
||||
s := 'UID ' + s;
|
||||
Result := IMAPcommand(s) = 'OK';
|
||||
end;
|
||||
|
||||
function TIMAPSend.SearchMess(Criteria: string; const FoundMess: TStrings): Boolean;
|
||||
var
|
||||
s: string;
|
||||
begin
|
||||
s := 'SEARCH ' + Criteria;
|
||||
if FUID then
|
||||
s := 'UID ' + s;
|
||||
Result := IMAPcommand(s) = 'OK';
|
||||
ParseSearch(FoundMess);
|
||||
end;
|
||||
|
||||
function TIMAPSend.SetFlagsMess(MessID: integer; Flags: string): Boolean;
|
||||
var
|
||||
s: string;
|
||||
begin
|
||||
s := 'STORE ' + IntToStr(MessID) + ' FLAGS.SILENT (' + Flags + ')';
|
||||
if FUID then
|
||||
s := 'UID ' + s;
|
||||
Result := IMAPcommand(s) = 'OK';
|
||||
end;
|
||||
|
||||
function TIMAPSend.AddFlagsMess(MessID: integer; Flags: string): Boolean;
|
||||
var
|
||||
s: string;
|
||||
begin
|
||||
s := 'STORE ' + IntToStr(MessID) + ' +FLAGS.SILENT (' + Flags + ')';
|
||||
if FUID then
|
||||
s := 'UID ' + s;
|
||||
Result := IMAPcommand(s) = 'OK';
|
||||
end;
|
||||
|
||||
function TIMAPSend.DelFlagsMess(MessID: integer; Flags: string): Boolean;
|
||||
var
|
||||
s: string;
|
||||
begin
|
||||
s := 'STORE ' + IntToStr(MessID) + ' -FLAGS.SILENT (' + Flags + ')';
|
||||
if FUID then
|
||||
s := 'UID ' + s;
|
||||
Result := IMAPcommand(s) = 'OK';
|
||||
end;
|
||||
|
||||
function TIMAPSend.GetFlagsMess(MessID: integer; var Flags: string): Boolean;
|
||||
var
|
||||
s: string;
|
||||
n: integer;
|
||||
begin
|
||||
Flags := '';
|
||||
s := 'FETCH ' + IntToStr(MessID) + ' (FLAGS)';
|
||||
if FUID then
|
||||
s := 'UID ' + s;
|
||||
Result := IMAPcommand(s) = 'OK';
|
||||
ProcessLiterals;
|
||||
for n := 0 to FFullResult.Count - 1 do
|
||||
begin
|
||||
s := uppercase(FFullResult[n]);
|
||||
if (Pos('* ', s) = 1) and (Pos('FLAGS', s) > 0 ) then
|
||||
begin
|
||||
s := SeparateRight(s, 'FLAGS');
|
||||
s := Separateright(s, '(');
|
||||
Flags := Trim(SeparateLeft(s, ')'));
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TIMAPSend.StartTLS: Boolean;
|
||||
begin
|
||||
Result := False;
|
||||
if FindCap('STARTTLS') <> '' then
|
||||
begin
|
||||
if IMAPcommand('STARTTLS') = 'OK' then
|
||||
begin
|
||||
Fsock.SSLDoConnect;
|
||||
Result := FSock.LastError = 0;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
//Paul Buskermolen <p.buskermolen@pinkroccade.com>
|
||||
function TIMAPSend.GetUID(MessID: integer; var UID : Integer): boolean;
|
||||
var
|
||||
s, sUid: string;
|
||||
n: integer;
|
||||
begin
|
||||
sUID := '';
|
||||
s := 'FETCH ' + IntToStr(MessID) + ' UID';
|
||||
Result := IMAPcommand(s) = 'OK';
|
||||
ProcessLiterals;
|
||||
for n := 0 to FFullResult.Count - 1 do
|
||||
begin
|
||||
s := uppercase(FFullResult[n]);
|
||||
if Pos('FETCH (UID', s) >= 1 then
|
||||
begin
|
||||
s := Separateright(s, '(UID ');
|
||||
sUID := Trim(SeparateLeft(s, ')'));
|
||||
end;
|
||||
end;
|
||||
UID := StrToIntDef(sUID, 0);
|
||||
end;
|
||||
|
||||
{==============================================================================}
|
||||
|
||||
end.
|
170
synapse/laz_synapse.lpk
Normal file
170
synapse/laz_synapse.lpk
Normal file
@ -0,0 +1,170 @@
|
||||
<?xml version="1.0"?>
|
||||
<CONFIG>
|
||||
<Package Version="3">
|
||||
<Name Value="laz_synapse"/>
|
||||
<CompilerOptions>
|
||||
<Version Value="8"/>
|
||||
<SearchPaths>
|
||||
<UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)/"/>
|
||||
</SearchPaths>
|
||||
<Parsing>
|
||||
<SyntaxOptions>
|
||||
<UseAnsiStrings Value="True"/>
|
||||
</SyntaxOptions>
|
||||
</Parsing>
|
||||
<Other>
|
||||
<CompilerPath Value="$(CompPath)"/>
|
||||
</Other>
|
||||
</CompilerOptions>
|
||||
<Files Count="33">
|
||||
<Item1>
|
||||
<Filename Value="asn1util.pas"/>
|
||||
<UnitName Value="asn1util"/>
|
||||
</Item1>
|
||||
<Item2>
|
||||
<Filename Value="blcksock.pas"/>
|
||||
<UnitName Value="blcksock"/>
|
||||
</Item2>
|
||||
<Item3>
|
||||
<Filename Value="clamsend.pas"/>
|
||||
<UnitName Value="clamsend"/>
|
||||
</Item3>
|
||||
<Item4>
|
||||
<Filename Value="dnssend.pas"/>
|
||||
<UnitName Value="dnssend"/>
|
||||
</Item4>
|
||||
<Item5>
|
||||
<Filename Value="ftpsend.pas"/>
|
||||
<UnitName Value="ftpsend"/>
|
||||
</Item5>
|
||||
<Item6>
|
||||
<Filename Value="ftptsend.pas"/>
|
||||
<UnitName Value="ftptsend"/>
|
||||
</Item6>
|
||||
<Item7>
|
||||
<Filename Value="httpsend.pas"/>
|
||||
<UnitName Value="httpsend"/>
|
||||
</Item7>
|
||||
<Item8>
|
||||
<Filename Value="imapsend.pas"/>
|
||||
<UnitName Value="imapsend"/>
|
||||
</Item8>
|
||||
<Item9>
|
||||
<Filename Value="ldapsend.pas"/>
|
||||
<UnitName Value="ldapsend"/>
|
||||
</Item9>
|
||||
<Item10>
|
||||
<Filename Value="mimeinln.pas"/>
|
||||
<UnitName Value="mimeinln"/>
|
||||
</Item10>
|
||||
<Item11>
|
||||
<Filename Value="mimemess.pas"/>
|
||||
<UnitName Value="mimemess"/>
|
||||
</Item11>
|
||||
<Item12>
|
||||
<Filename Value="mimepart.pas"/>
|
||||
<UnitName Value="mimepart"/>
|
||||
</Item12>
|
||||
<Item13>
|
||||
<Filename Value="nntpsend.pas"/>
|
||||
<UnitName Value="nntpsend"/>
|
||||
</Item13>
|
||||
<Item14>
|
||||
<Filename Value="pingsend.pas"/>
|
||||
<UnitName Value="pingsend"/>
|
||||
</Item14>
|
||||
<Item15>
|
||||
<Filename Value="pop3send.pas"/>
|
||||
<UnitName Value="pop3send"/>
|
||||
</Item15>
|
||||
<Item16>
|
||||
<Filename Value="slogsend.pas"/>
|
||||
<UnitName Value="slogsend"/>
|
||||
</Item16>
|
||||
<Item17>
|
||||
<Filename Value="smtpsend.pas"/>
|
||||
<UnitName Value="smtpsend"/>
|
||||
</Item17>
|
||||
<Item18>
|
||||
<Filename Value="snmpsend.pas"/>
|
||||
<UnitName Value="snmpsend"/>
|
||||
</Item18>
|
||||
<Item19>
|
||||
<Filename Value="sntpsend.pas"/>
|
||||
<UnitName Value="sntpsend"/>
|
||||
</Item19>
|
||||
<Item20>
|
||||
<Filename Value="ssfpc.pas"/>
|
||||
<AddToUsesPkgSection Value="False"/>
|
||||
<UnitName Value="ssfpc"/>
|
||||
</Item20>
|
||||
<Item21>
|
||||
<Filename Value="sswin32.pas"/>
|
||||
<AddToUsesPkgSection Value="False"/>
|
||||
<UnitName Value="sswin32"/>
|
||||
</Item21>
|
||||
<Item22>
|
||||
<Filename Value="synachar.pas"/>
|
||||
<UnitName Value="synachar"/>
|
||||
</Item22>
|
||||
<Item23>
|
||||
<Filename Value="synacode.pas"/>
|
||||
<UnitName Value="synacode"/>
|
||||
</Item23>
|
||||
<Item24>
|
||||
<Filename Value="synacrypt.pas"/>
|
||||
<UnitName Value="synacrypt"/>
|
||||
</Item24>
|
||||
<Item25>
|
||||
<Filename Value="synadbg.pas"/>
|
||||
<UnitName Value="synadbg"/>
|
||||
</Item25>
|
||||
<Item26>
|
||||
<Filename Value="synafpc.pas"/>
|
||||
<UnitName Value="synafpc"/>
|
||||
</Item26>
|
||||
<Item27>
|
||||
<Filename Value="synaicnv.pas"/>
|
||||
<UnitName Value="synaicnv"/>
|
||||
</Item27>
|
||||
<Item28>
|
||||
<Filename Value="synaip.pas"/>
|
||||
<UnitName Value="synaip"/>
|
||||
</Item28>
|
||||
<Item29>
|
||||
<Filename Value="synamisc.pas"/>
|
||||
<UnitName Value="synamisc"/>
|
||||
</Item29>
|
||||
<Item30>
|
||||
<Filename Value="synaser.pas"/>
|
||||
<UnitName Value="synaser"/>
|
||||
</Item30>
|
||||
<Item31>
|
||||
<Filename Value="synautil.pas"/>
|
||||
<UnitName Value="synautil"/>
|
||||
</Item31>
|
||||
<Item32>
|
||||
<Filename Value="synsock.pas"/>
|
||||
<UnitName Value="synsock"/>
|
||||
</Item32>
|
||||
<Item33>
|
||||
<Filename Value="tlntsend.pas"/>
|
||||
<UnitName Value="tlntsend"/>
|
||||
</Item33>
|
||||
</Files>
|
||||
<Type Value="RunAndDesignTime"/>
|
||||
<RequiredPkgs Count="1">
|
||||
<Item1>
|
||||
<PackageName Value="FCL"/>
|
||||
<MinVersion Major="1" Valid="True"/>
|
||||
</Item1>
|
||||
</RequiredPkgs>
|
||||
<UsageOptions>
|
||||
<UnitPath Value="$(PkgOutDir)"/>
|
||||
</UsageOptions>
|
||||
<PublishOptions>
|
||||
<Version Value="2"/>
|
||||
<IgnoreBinaries Value="False"/>
|
||||
</PublishOptions>
|
||||
</Package>
|
||||
</CONFIG>
|
24
synapse/laz_synapse.pas
Normal file
24
synapse/laz_synapse.pas
Normal file
@ -0,0 +1,24 @@
|
||||
{ This file was automatically created by Lazarus. Do not edit!
|
||||
This source is only used to compile and install the package.
|
||||
}
|
||||
|
||||
unit laz_synapse;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
asn1util, blcksock, clamsend, dnssend, ftpsend, ftptsend, httpsend,
|
||||
imapsend, ldapsend, mimeinln, mimemess, mimepart, nntpsend, pingsend,
|
||||
pop3send, slogsend, smtpsend, snmpsend, sntpsend, synachar, synacode,
|
||||
synacrypt, synadbg, synafpc, synaicnv, synaip, synamisc, synaser, synautil,
|
||||
synsock, tlntsend, LazarusPackageIntf;
|
||||
|
||||
implementation
|
||||
|
||||
procedure Register;
|
||||
begin
|
||||
end;
|
||||
|
||||
initialization
|
||||
RegisterPackage('laz_synapse', @Register);
|
||||
end.
|
1208
synapse/ldapsend.pas
Normal file
1208
synapse/ldapsend.pas
Normal file
File diff suppressed because it is too large
Load Diff
28
synapse/licence.txt
Normal file
28
synapse/licence.txt
Normal file
@ -0,0 +1,28 @@
|
||||
Copyright (c)1999-2002, Lukas Gebauer
|
||||
All rights reserved.
|
||||
|
||||
Redistribution and use in source and binary forms, with or without
|
||||
modification, are permitted provided that the following conditions are met:
|
||||
|
||||
Redistributions of source code must retain the above copyright notice, this
|
||||
list of conditions and the following disclaimer.
|
||||
|
||||
Redistributions in binary form must reproduce the above copyright notice,
|
||||
this list of conditions and the following disclaimer in the documentation
|
||||
and/or other materials provided with the distribution.
|
||||
|
||||
Neither the name of Lukas Gebauer nor the names of its contributors may
|
||||
be used to endorse or promote products derived from this software without
|
||||
specific prior written permission.
|
||||
|
||||
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
|
||||
AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
|
||||
IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
|
||||
ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR
|
||||
ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
|
||||
DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
|
||||
SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
|
||||
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
|
||||
LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
|
||||
OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
|
||||
DAMAGE.
|
263
synapse/mimeinln.pas
Normal file
263
synapse/mimeinln.pas
Normal file
@ -0,0 +1,263 @@
|
||||
{==============================================================================|
|
||||
| Project : Ararat Synapse | 001.001.011 |
|
||||
|==============================================================================|
|
||||
| Content: Inline MIME support procedures and functions |
|
||||
|==============================================================================|
|
||||
| Copyright (c)1999-2006, Lukas Gebauer |
|
||||
| All rights reserved. |
|
||||
| |
|
||||
| Redistribution and use in source and binary forms, with or without |
|
||||
| modification, are permitted provided that the following conditions are met: |
|
||||
| |
|
||||
| Redistributions of source code must retain the above copyright notice, this |
|
||||
| list of conditions and the following disclaimer. |
|
||||
| |
|
||||
| Redistributions in binary form must reproduce the above copyright notice, |
|
||||
| this list of conditions and the following disclaimer in the documentation |
|
||||
| and/or other materials provided with the distribution. |
|
||||
| |
|
||||
| Neither the name of Lukas Gebauer nor the names of its contributors may |
|
||||
| be used to endorse or promote products derived from this software without |
|
||||
| specific prior written permission. |
|
||||
| |
|
||||
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
|
||||
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
|
||||
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
|
||||
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
|
||||
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
|
||||
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
|
||||
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
|
||||
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
|
||||
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
|
||||
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
|
||||
| DAMAGE. |
|
||||
|==============================================================================|
|
||||
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
|
||||
| Portions created by Lukas Gebauer are Copyright (c)2000-2006. |
|
||||
| All Rights Reserved. |
|
||||
|==============================================================================|
|
||||
| Contributor(s): |
|
||||
|==============================================================================|
|
||||
| History: see HISTORY.HTM from distribution package |
|
||||
| (Found at URL: http://www.ararat.cz/synapse/) |
|
||||
|==============================================================================}
|
||||
|
||||
{:@abstract(Utilities for inline MIME)
|
||||
Support for Inline MIME encoding and decoding.
|
||||
|
||||
Used RFC: RFC-2047, RFC-2231
|
||||
}
|
||||
|
||||
{$IFDEF FPC}
|
||||
{$MODE DELPHI}
|
||||
{$ENDIF}
|
||||
{$H+}
|
||||
|
||||
{$IFDEF UNICODE}
|
||||
{$WARN IMPLICIT_STRING_CAST OFF}
|
||||
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
|
||||
{$ENDIF}
|
||||
|
||||
unit mimeinln;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
SysUtils, Classes,
|
||||
synachar, synacode, synautil;
|
||||
|
||||
{:Decodes mime inline encoding (i.e. in headers) uses target characterset "CP".}
|
||||
function InlineDecode(const Value: string; CP: TMimeChar): string;
|
||||
|
||||
{:Encodes string to MIME inline encoding. The source characterset is "CP", and
|
||||
the target charset is "MimeP".}
|
||||
function InlineEncode(const Value: string; CP, MimeP: TMimeChar): string;
|
||||
|
||||
{:Returns @true, if "Value" contains characters needed for inline coding.}
|
||||
function NeedInline(const Value: AnsiString): boolean;
|
||||
|
||||
{:Inline mime encoding similar to @link(InlineEncode), but you can specify
|
||||
source charset, and the target characterset is automatically assigned.}
|
||||
function InlineCodeEx(const Value: string; FromCP: TMimeChar): string;
|
||||
|
||||
{:Inline MIME encoding similar to @link(InlineEncode), but the source charset
|
||||
is automatically set to the system default charset, and the target charset is
|
||||
automatically assigned from set of allowed encoding for MIME.}
|
||||
function InlineCode(const Value: string): string;
|
||||
|
||||
{:Converts e-mail address to canonical mime form. You can specify source charset.}
|
||||
function InlineEmailEx(const Value: string; FromCP: TMimeChar): string;
|
||||
|
||||
{:Converts e-mail address to canonical mime form. Source charser it system
|
||||
default charset.}
|
||||
function InlineEmail(const Value: string): string;
|
||||
|
||||
implementation
|
||||
|
||||
{==============================================================================}
|
||||
|
||||
function InlineDecode(const Value: string; CP: TMimeChar): string;
|
||||
var
|
||||
s, su, v: string;
|
||||
x, y, z, n: Integer;
|
||||
ichar: TMimeChar;
|
||||
c: Char;
|
||||
|
||||
function SearchEndInline(const Value: string; be: Integer): Integer;
|
||||
var
|
||||
n, q: Integer;
|
||||
begin
|
||||
q := 0;
|
||||
Result := 0;
|
||||
for n := be + 2 to Length(Value) - 1 do
|
||||
if Value[n] = '?' then
|
||||
begin
|
||||
Inc(q);
|
||||
if (q > 2) and (Value[n + 1] = '=') then
|
||||
begin
|
||||
Result := n;
|
||||
Break;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
begin
|
||||
Result := '';
|
||||
v := Value;
|
||||
x := Pos('=?', v);
|
||||
y := SearchEndInline(v, x);
|
||||
//fix for broken coding with begin, but not with end.
|
||||
if (x > 0) and (y <= 0) then
|
||||
y := Length(Result);
|
||||
while (y > x) and (x > 0) do
|
||||
begin
|
||||
s := Copy(v, 1, x - 1);
|
||||
if Trim(s) <> '' then
|
||||
Result := Result + s;
|
||||
s := Copy(v, x, y - x + 2);
|
||||
Delete(v, 1, y + 1);
|
||||
su := Copy(s, 3, Length(s) - 4);
|
||||
z := Pos('?', su);
|
||||
if (Length(su) >= (z + 2)) and (su[z + 2] = '?') then
|
||||
begin
|
||||
ichar := GetCPFromID(SeparateLeft(Copy(su, 1, z - 1), '*'));
|
||||
c := UpperCase(su)[z + 1];
|
||||
su := Copy(su, z + 3, Length(su) - z - 2);
|
||||
if c = 'B' then
|
||||
begin
|
||||
s := DecodeBase64(su);
|
||||
s := CharsetConversion(s, ichar, CP);
|
||||
end;
|
||||
if c = 'Q' then
|
||||
begin
|
||||
s := '';
|
||||
for n := 1 to Length(su) do
|
||||
if su[n] = '_' then
|
||||
s := s + ' '
|
||||
else
|
||||
s := s + su[n];
|
||||
s := DecodeQuotedPrintable(s);
|
||||
s := CharsetConversion(s, ichar, CP);
|
||||
end;
|
||||
end;
|
||||
Result := Result + s;
|
||||
x := Pos('=?', v);
|
||||
y := SearchEndInline(v, x);
|
||||
end;
|
||||
Result := Result + v;
|
||||
end;
|
||||
|
||||
{==============================================================================}
|
||||
|
||||
function InlineEncode(const Value: string; CP, MimeP: TMimeChar): string;
|
||||
var
|
||||
s, s1, e: string;
|
||||
n: Integer;
|
||||
begin
|
||||
s := CharsetConversion(Value, CP, MimeP);
|
||||
s := EncodeSafeQuotedPrintable(s);
|
||||
e := GetIdFromCP(MimeP);
|
||||
s1 := '';
|
||||
Result := '';
|
||||
for n := 1 to Length(s) do
|
||||
if s[n] = ' ' then
|
||||
begin
|
||||
// s1 := s1 + '=20';
|
||||
s1 := s1 + '_';
|
||||
if Length(s1) > 32 then
|
||||
begin
|
||||
if Result <> '' then
|
||||
Result := Result + ' ';
|
||||
Result := Result + '=?' + e + '?Q?' + s1 + '?=';
|
||||
s1 := '';
|
||||
end;
|
||||
end
|
||||
else
|
||||
s1 := s1 + s[n];
|
||||
if s1 <> '' then
|
||||
begin
|
||||
if Result <> '' then
|
||||
Result := Result + ' ';
|
||||
Result := Result + '=?' + e + '?Q?' + s1 + '?=';
|
||||
end;
|
||||
end;
|
||||
|
||||
{==============================================================================}
|
||||
|
||||
function NeedInline(const Value: AnsiString): boolean;
|
||||
var
|
||||
n: Integer;
|
||||
begin
|
||||
Result := False;
|
||||
for n := 1 to Length(Value) do
|
||||
if Value[n] in (SpecialChar + NonAsciiChar - ['_']) then
|
||||
begin
|
||||
Result := True;
|
||||
Break;
|
||||
end;
|
||||
end;
|
||||
|
||||
{==============================================================================}
|
||||
|
||||
function InlineCodeEx(const Value: string; FromCP: TMimeChar): string;
|
||||
var
|
||||
c: TMimeChar;
|
||||
begin
|
||||
if NeedInline(Value) then
|
||||
begin
|
||||
c := IdealCharsetCoding(Value, FromCP, IdealCharsets);
|
||||
Result := InlineEncode(Value, FromCP, c);
|
||||
end
|
||||
else
|
||||
Result := Value;
|
||||
end;
|
||||
|
||||
{==============================================================================}
|
||||
|
||||
function InlineCode(const Value: string): string;
|
||||
begin
|
||||
Result := InlineCodeEx(Value, GetCurCP);
|
||||
end;
|
||||
|
||||
{==============================================================================}
|
||||
|
||||
function InlineEmailEx(const Value: string; FromCP: TMimeChar): string;
|
||||
var
|
||||
sd, se: string;
|
||||
begin
|
||||
sd := GetEmailDesc(Value);
|
||||
se := GetEmailAddr(Value);
|
||||
if sd = '' then
|
||||
Result := se
|
||||
else
|
||||
Result := '"' + InlineCodeEx(sd, FromCP) + '" <' + se + '>';
|
||||
end;
|
||||
|
||||
{==============================================================================}
|
||||
|
||||
function InlineEmail(const Value: string): string;
|
||||
begin
|
||||
Result := InlineEmailEx(Value, GetCurCP);
|
||||
end;
|
||||
|
||||
end.
|
851
synapse/mimemess.pas
Normal file
851
synapse/mimemess.pas
Normal file
@ -0,0 +1,851 @@
|
||||
{==============================================================================|
|
||||
| Project : Ararat Synapse | 002.006.000 |
|
||||
|==============================================================================|
|
||||
| Content: MIME message object |
|
||||
|==============================================================================|
|
||||
| Copyright (c)1999-2012, Lukas Gebauer |
|
||||
| All rights reserved. |
|
||||
| |
|
||||
| Redistribution and use in source and binary forms, with or without |
|
||||
| modification, are permitted provided that the following conditions are met: |
|
||||
| |
|
||||
| Redistributions of source code must retain the above copyright notice, this |
|
||||
| list of conditions and the following disclaimer. |
|
||||
| |
|
||||
| Redistributions in binary form must reproduce the above copyright notice, |
|
||||
| this list of conditions and the following disclaimer in the documentation |
|
||||
| and/or other materials provided with the distribution. |
|
||||
| |
|
||||
| Neither the name of Lukas Gebauer nor the names of its contributors may |
|
||||
| be used to endorse or promote products derived from this software without |
|
||||
| specific prior written permission. |
|
||||
| |
|
||||
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
|
||||
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
|
||||
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
|
||||
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
|
||||
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
|
||||
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
|
||||
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
|
||||
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
|
||||
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
|
||||
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
|
||||
| DAMAGE. |
|
||||
|==============================================================================|
|
||||
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
|
||||
| Portions created by Lukas Gebauer are Copyright (c)2000-2012. |
|
||||
| Portions created by Petr Fejfar are Copyright (c)2011-2012. |
|
||||
| All Rights Reserved. |
|
||||
|==============================================================================|
|
||||
| Contributor(s): |
|
||||
|==============================================================================|
|
||||
| History: see HISTORY.HTM From distribution package |
|
||||
| (Found at URL: http://www.ararat.cz/synapse/) |
|
||||
|==============================================================================}
|
||||
|
||||
{:@abstract(MIME message handling)
|
||||
Classes for easy handling with e-mail message.
|
||||
}
|
||||
|
||||
{$IFDEF FPC}
|
||||
{$MODE DELPHI}
|
||||
{$ENDIF}
|
||||
{$H+}
|
||||
{$M+}
|
||||
|
||||
unit mimemess;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils,
|
||||
mimepart, synachar, synautil, mimeinln;
|
||||
|
||||
type
|
||||
|
||||
{:Possible values for message priority}
|
||||
TMessPriority = (MP_unknown, MP_low, MP_normal, MP_high);
|
||||
|
||||
{:@abstract(Object for basic e-mail header fields.)}
|
||||
TMessHeader = class(TObject)
|
||||
private
|
||||
FFrom: string;
|
||||
FToList: TStringList;
|
||||
FCCList: TStringList;
|
||||
FSubject: string;
|
||||
FOrganization: string;
|
||||
FCustomHeaders: TStringList;
|
||||
FDate: TDateTime;
|
||||
FXMailer: string;
|
||||
FCharsetCode: TMimeChar;
|
||||
FReplyTo: string;
|
||||
FMessageID: string;
|
||||
FPriority: TMessPriority;
|
||||
Fpri: TMessPriority;
|
||||
Fxpri: TMessPriority;
|
||||
Fxmspri: TMessPriority;
|
||||
protected
|
||||
function ParsePriority(value: string): TMessPriority;
|
||||
function DecodeHeader(value: string): boolean; virtual;
|
||||
public
|
||||
constructor Create; virtual;
|
||||
destructor Destroy; override;
|
||||
|
||||
{:Clears all data fields.}
|
||||
procedure Clear; virtual;
|
||||
|
||||
{Add headers from from this object to Value.}
|
||||
procedure EncodeHeaders(const Value: TStrings); virtual;
|
||||
|
||||
{:Parse header from Value to this object.}
|
||||
procedure DecodeHeaders(const Value: TStrings);
|
||||
|
||||
{:Try find specific header in CustomHeader. Search is case insensitive.
|
||||
This is good for reading any non-parsed header.}
|
||||
function FindHeader(Value: string): string;
|
||||
|
||||
{:Try find specific headers in CustomHeader. This metod is for repeatly used
|
||||
headers like 'received' header, etc. Search is case insensitive.
|
||||
This is good for reading ano non-parsed header.}
|
||||
procedure FindHeaderList(Value: string; const HeaderList: TStrings);
|
||||
published
|
||||
{:Sender of message.}
|
||||
property From: string read FFrom Write FFrom;
|
||||
|
||||
{:Stringlist with receivers of message. (one per line)}
|
||||
property ToList: TStringList read FToList;
|
||||
|
||||
{:Stringlist with Carbon Copy receivers of message. (one per line)}
|
||||
property CCList: TStringList read FCCList;
|
||||
|
||||
{:Subject of message.}
|
||||
property Subject: string read FSubject Write FSubject;
|
||||
|
||||
{:Organization string.}
|
||||
property Organization: string read FOrganization Write FOrganization;
|
||||
|
||||
{:After decoding contains all headers lines witch not have parsed to any
|
||||
other structures in this object. It mean: this conatins all other headers
|
||||
except:
|
||||
|
||||
X-MAILER, FROM, SUBJECT, ORGANIZATION, TO, CC, DATE, MIME-VERSION,
|
||||
CONTENT-TYPE, CONTENT-DESCRIPTION, CONTENT-DISPOSITION, CONTENT-ID,
|
||||
CONTENT-TRANSFER-ENCODING, REPLY-TO, MESSAGE-ID, X-MSMAIL-PRIORITY,
|
||||
X-PRIORITY, PRIORITY
|
||||
|
||||
When you encode headers, all this lines is added as headers. Be carefull
|
||||
for duplicites!}
|
||||
property CustomHeaders: TStringList read FCustomHeaders;
|
||||
|
||||
{:Date and time of message.}
|
||||
property Date: TDateTime read FDate Write FDate;
|
||||
|
||||
{:Mailer identification.}
|
||||
property XMailer: string read FXMailer Write FXMailer;
|
||||
|
||||
{:Address for replies}
|
||||
property ReplyTo: string read FReplyTo Write FReplyTo;
|
||||
|
||||
{:message indetifier}
|
||||
property MessageID: string read FMessageID Write FMessageID;
|
||||
|
||||
{:message priority}
|
||||
property Priority: TMessPriority read FPriority Write FPriority;
|
||||
|
||||
{:Specify base charset. By default is used system charset.}
|
||||
property CharsetCode: TMimeChar read FCharsetCode Write FCharsetCode;
|
||||
end;
|
||||
|
||||
TMessHeaderClass = class of TMessHeader;
|
||||
|
||||
{:@abstract(Object for handling of e-mail message.)}
|
||||
TMimeMess = class(TObject)
|
||||
private
|
||||
FMessagePart: TMimePart;
|
||||
FLines: TStringList;
|
||||
FHeader: TMessHeader;
|
||||
public
|
||||
constructor Create;
|
||||
{:create this object and assign your own descendant of @link(TMessHeader)
|
||||
object to @link(header) property. So, you can create your own message
|
||||
headers parser and use it by this object.}
|
||||
constructor CreateAltHeaders(HeadClass: TMessHeaderClass);
|
||||
destructor Destroy; override;
|
||||
|
||||
{:Reset component to default state.}
|
||||
procedure Clear; virtual;
|
||||
|
||||
{:Add MIME part as subpart of PartParent. If you need set root MIME part,
|
||||
then set as PartParent @NIL value. If you need set more then one subpart,
|
||||
you must have PartParent of multipart type!}
|
||||
function AddPart(const PartParent: TMimePart): TMimePart;
|
||||
|
||||
{:Add MIME part as subpart of PartParent. If you need set root MIME part,
|
||||
then set as PartParent @NIL value. If you need set more then 1 subpart, you
|
||||
must have PartParent of multipart type!
|
||||
|
||||
This part is marked as multipart with secondary MIME type specified by
|
||||
MultipartType parameter. (typical value is 'mixed')
|
||||
|
||||
This part can be used as PartParent for another parts (include next
|
||||
multipart). If you need only one part, then you not need Multipart part.}
|
||||
function AddPartMultipart(const MultipartType: String; const PartParent: TMimePart): TMimePart;
|
||||
|
||||
{:Add MIME part as subpart of PartParent. If you need set root MIME part,
|
||||
then set as PartParent @NIL value. If you need set more then 1 subpart, you
|
||||
must have PartParent of multipart type!
|
||||
|
||||
After creation of part set type to text part and set all necessary
|
||||
properties. Content of part is readed from value stringlist.}
|
||||
function AddPartText(const Value: TStrings; const PartParent: TMimePart): TMimepart;
|
||||
|
||||
{:Add MIME part as subpart of PartParent. If you need set root MIME part,
|
||||
then set as PartParent @NIL value. If you need set more then 1 subpart, you
|
||||
must have PartParent of multipart type!
|
||||
|
||||
After creation of part set type to text part and set all necessary
|
||||
properties. Content of part is readed from value stringlist. You can select
|
||||
your charset and your encoding type. If Raw is @true, then it not doing
|
||||
charset conversion!}
|
||||
function AddPartTextEx(const Value: TStrings; const PartParent: TMimePart;
|
||||
PartCharset: TMimeChar; Raw: Boolean; PartEncoding: TMimeEncoding): TMimepart;
|
||||
|
||||
{:Add MIME part as subpart of PartParent. If you need set root MIME part,
|
||||
then set as PartParent @NIL value. If you need set more then 1 subpart, you
|
||||
must have PartParent of multipart type!
|
||||
|
||||
After creation of part set type to text part to HTML type and set all
|
||||
necessary properties. Content of HTML part is readed from Value stringlist.}
|
||||
function AddPartHTML(const Value: TStrings; const PartParent: TMimePart): TMimepart;
|
||||
|
||||
{:Same as @link(AddPartText), but content is readed from file}
|
||||
function AddPartTextFromFile(const FileName: String; const PartParent: TMimePart): TMimepart;
|
||||
|
||||
{:Same as @link(AddPartHTML), but content is readed from file}
|
||||
function AddPartHTMLFromFile(const FileName: String; const PartParent: TMimePart): TMimepart;
|
||||
|
||||
{:Add MIME part as subpart of PartParent. If you need set root MIME part,
|
||||
then set as PartParent @NIL value. If you need set more then 1 subpart,
|
||||
you must have PartParent of multipart type!
|
||||
|
||||
After creation of part set type to binary and set all necessary properties.
|
||||
MIME primary and secondary types defined automaticly by filename extension.
|
||||
Content of binary part is readed from Stream. This binary part is encoded
|
||||
as file attachment.}
|
||||
function AddPartBinary(const Stream: TStream; const FileName: string; const PartParent: TMimePart): TMimepart;
|
||||
|
||||
{:Same as @link(AddPartBinary), but content is readed from file}
|
||||
function AddPartBinaryFromFile(const FileName: string; const PartParent: TMimePart): TMimepart;
|
||||
|
||||
{:Add MIME part as subpart of PartParent. If you need set root MIME part,
|
||||
then set as PartParent @NIL value. If you need set more then 1 subpart, you
|
||||
must have PartParent of multipart type!
|
||||
|
||||
After creation of part set type to binary and set all necessary properties.
|
||||
MIME primary and secondary types defined automaticly by filename extension.
|
||||
Content of binary part is readed from Stream.
|
||||
|
||||
This binary part is encoded as inline data with given Conten ID (cid).
|
||||
Content ID can be used as reference ID in HTML source in HTML part.}
|
||||
function AddPartHTMLBinary(const Stream: TStream; const FileName, Cid: string; const PartParent: TMimePart): TMimepart;
|
||||
|
||||
{:Same as @link(AddPartHTMLBinary), but content is readed from file}
|
||||
function AddPartHTMLBinaryFromFile(const FileName, Cid: string; const PartParent: TMimePart): TMimepart;
|
||||
|
||||
{:Add MIME part as subpart of PartParent. If you need set root MIME part,
|
||||
then set as PartParent @NIL value. If you need set more then 1 subpart, you
|
||||
must have PartParent of multipart type!
|
||||
|
||||
After creation of part set type to message and set all necessary properties.
|
||||
MIME primary and secondary types are setted to 'message/rfc822'.
|
||||
Content of raw RFC-822 message is readed from Stream.}
|
||||
function AddPartMess(const Value: TStrings; const PartParent: TMimePart): TMimepart;
|
||||
|
||||
{:Same as @link(AddPartMess), but content is readed from file}
|
||||
function AddPartMessFromFile(const FileName: string; const PartParent: TMimePart): TMimepart;
|
||||
|
||||
{:Compose message from @link(MessagePart) to @link(Lines). Headers from
|
||||
@link(Header) object is added also.}
|
||||
procedure EncodeMessage;
|
||||
|
||||
{:Decode message from @link(Lines) to @link(MessagePart). Massage headers
|
||||
are parsed into @link(Header) object.}
|
||||
procedure DecodeMessage;
|
||||
|
||||
{pf}
|
||||
{: HTTP message is received by @link(THTTPSend) component in two parts:
|
||||
headers are stored in @link(THTTPSend.Headers) and a body in memory stream
|
||||
@link(THTTPSend.Document).
|
||||
|
||||
On the top of it, HTTP connections are always 8-bit, hence data are
|
||||
transferred in native format i.e. no transfer encoding is applied.
|
||||
|
||||
This method operates the similiar way and produces the same
|
||||
result as @link(DecodeMessage).
|
||||
}
|
||||
procedure DecodeMessageBinary(AHeader:TStrings; AData:TMemoryStream);
|
||||
{/pf}
|
||||
published
|
||||
{:@link(TMimePart) object with decoded MIME message. This object can handle
|
||||
any number of nested @link(TMimePart) objects itself. It is used for handle
|
||||
any tree of MIME subparts.}
|
||||
property MessagePart: TMimePart read FMessagePart;
|
||||
|
||||
{:Raw MIME encoded message.}
|
||||
property Lines: TStringList read FLines;
|
||||
|
||||
{:Object for e-mail header fields. This object is created automaticly.
|
||||
Do not free this object!}
|
||||
property Header: TMessHeader read FHeader;
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
{==============================================================================}
|
||||
|
||||
constructor TMessHeader.Create;
|
||||
begin
|
||||
inherited Create;
|
||||
FToList := TStringList.Create;
|
||||
FCCList := TStringList.Create;
|
||||
FCustomHeaders := TStringList.Create;
|
||||
FCharsetCode := GetCurCP;
|
||||
end;
|
||||
|
||||
destructor TMessHeader.Destroy;
|
||||
begin
|
||||
FCustomHeaders.Free;
|
||||
FCCList.Free;
|
||||
FToList.Free;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
{==============================================================================}
|
||||
|
||||
procedure TMessHeader.Clear;
|
||||
begin
|
||||
FFrom := '';
|
||||
FToList.Clear;
|
||||
FCCList.Clear;
|
||||
FSubject := '';
|
||||
FOrganization := '';
|
||||
FCustomHeaders.Clear;
|
||||
FDate := 0;
|
||||
FXMailer := '';
|
||||
FReplyTo := '';
|
||||
FMessageID := '';
|
||||
FPriority := MP_unknown;
|
||||
end;
|
||||
|
||||
procedure TMessHeader.EncodeHeaders(const Value: TStrings);
|
||||
var
|
||||
n: Integer;
|
||||
s: string;
|
||||
begin
|
||||
if FDate = 0 then
|
||||
FDate := Now;
|
||||
for n := FCustomHeaders.Count - 1 downto 0 do
|
||||
if FCustomHeaders[n] <> '' then
|
||||
Value.Insert(0, FCustomHeaders[n]);
|
||||
if FPriority <> MP_unknown then
|
||||
case FPriority of
|
||||
MP_high:
|
||||
begin
|
||||
Value.Insert(0, 'X-MSMAIL-Priority: High');
|
||||
Value.Insert(0, 'X-Priority: 1');
|
||||
Value.Insert(0, 'Priority: urgent');
|
||||
end;
|
||||
MP_low:
|
||||
begin
|
||||
Value.Insert(0, 'X-MSMAIL-Priority: low');
|
||||
Value.Insert(0, 'X-Priority: 5');
|
||||
Value.Insert(0, 'Priority: non-urgent');
|
||||
end;
|
||||
end;
|
||||
if FReplyTo <> '' then
|
||||
Value.Insert(0, 'Reply-To: ' + GetEmailAddr(FReplyTo));
|
||||
if FMessageID <> '' then
|
||||
Value.Insert(0, 'Message-ID: <' + trim(FMessageID) + '>');
|
||||
if FXMailer = '' then
|
||||
Value.Insert(0, 'X-mailer: Synapse - Pascal TCP/IP library by Lukas Gebauer')
|
||||
else
|
||||
Value.Insert(0, 'X-mailer: ' + FXMailer);
|
||||
Value.Insert(0, 'MIME-Version: 1.0 (produced by Synapse)');
|
||||
if FOrganization <> '' then
|
||||
Value.Insert(0, 'Organization: ' + InlineCodeEx(FOrganization, FCharsetCode));
|
||||
s := '';
|
||||
for n := 0 to FCCList.Count - 1 do
|
||||
if s = '' then
|
||||
s := InlineEmailEx(FCCList[n], FCharsetCode)
|
||||
else
|
||||
s := s + ', ' + InlineEmailEx(FCCList[n], FCharsetCode);
|
||||
if s <> '' then
|
||||
Value.Insert(0, 'CC: ' + s);
|
||||
Value.Insert(0, 'Date: ' + Rfc822DateTime(FDate));
|
||||
if FSubject <> '' then
|
||||
Value.Insert(0, 'Subject: ' + InlineCodeEx(FSubject, FCharsetCode));
|
||||
s := '';
|
||||
for n := 0 to FToList.Count - 1 do
|
||||
if s = '' then
|
||||
s := InlineEmailEx(FToList[n], FCharsetCode)
|
||||
else
|
||||
s := s + ', ' + InlineEmailEx(FToList[n], FCharsetCode);
|
||||
if s <> '' then
|
||||
Value.Insert(0, 'To: ' + s);
|
||||
Value.Insert(0, 'From: ' + InlineEmailEx(FFrom, FCharsetCode));
|
||||
end;
|
||||
|
||||
function TMessHeader.ParsePriority(value: string): TMessPriority;
|
||||
var
|
||||
s: string;
|
||||
x: integer;
|
||||
begin
|
||||
Result := MP_unknown;
|
||||
s := Trim(separateright(value, ':'));
|
||||
s := Separateleft(s, ' ');
|
||||
x := StrToIntDef(s, -1);
|
||||
if x >= 0 then
|
||||
case x of
|
||||
1, 2:
|
||||
Result := MP_High;
|
||||
3:
|
||||
Result := MP_Normal;
|
||||
4, 5:
|
||||
Result := MP_Low;
|
||||
end
|
||||
else
|
||||
begin
|
||||
s := lowercase(s);
|
||||
if (s = 'urgent') or (s = 'high') or (s = 'highest') then
|
||||
Result := MP_High;
|
||||
if (s = 'normal') or (s = 'medium') then
|
||||
Result := MP_Normal;
|
||||
if (s = 'low') or (s = 'lowest')
|
||||
or (s = 'no-priority') or (s = 'non-urgent') then
|
||||
Result := MP_Low;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TMessHeader.DecodeHeader(value: string): boolean;
|
||||
var
|
||||
s, t: string;
|
||||
cp: TMimeChar;
|
||||
begin
|
||||
Result := True;
|
||||
cp := FCharsetCode;
|
||||
s := uppercase(value);
|
||||
if Pos('X-MAILER:', s) = 1 then
|
||||
begin
|
||||
FXMailer := Trim(SeparateRight(Value, ':'));
|
||||
Exit;
|
||||
end;
|
||||
if Pos('FROM:', s) = 1 then
|
||||
begin
|
||||
FFrom := InlineDecode(Trim(SeparateRight(Value, ':')), cp);
|
||||
Exit;
|
||||
end;
|
||||
if Pos('SUBJECT:', s) = 1 then
|
||||
begin
|
||||
FSubject := InlineDecode(Trim(SeparateRight(Value, ':')), cp);
|
||||
Exit;
|
||||
end;
|
||||
if Pos('ORGANIZATION:', s) = 1 then
|
||||
begin
|
||||
FOrganization := InlineDecode(Trim(SeparateRight(Value, ':')), cp);
|
||||
Exit;
|
||||
end;
|
||||
if Pos('TO:', s) = 1 then
|
||||
begin
|
||||
s := Trim(SeparateRight(Value, ':'));
|
||||
repeat
|
||||
t := InlineDecode(Trim(FetchEx(s, ',', '"')), cp);
|
||||
if t <> '' then
|
||||
FToList.Add(t);
|
||||
until s = '';
|
||||
Exit;
|
||||
end;
|
||||
if Pos('CC:', s) = 1 then
|
||||
begin
|
||||
s := Trim(SeparateRight(Value, ':'));
|
||||
repeat
|
||||
t := InlineDecode(Trim(FetchEx(s, ',', '"')), cp);
|
||||
if t <> '' then
|
||||
FCCList.Add(t);
|
||||
until s = '';
|
||||
Exit;
|
||||
end;
|
||||
if Pos('DATE:', s) = 1 then
|
||||
begin
|
||||
FDate := DecodeRfcDateTime(Trim(SeparateRight(Value, ':')));
|
||||
Exit;
|
||||
end;
|
||||
if Pos('REPLY-TO:', s) = 1 then
|
||||
begin
|
||||
FReplyTo := InlineDecode(Trim(SeparateRight(Value, ':')), cp);
|
||||
Exit;
|
||||
end;
|
||||
if Pos('MESSAGE-ID:', s) = 1 then
|
||||
begin
|
||||
FMessageID := GetEmailAddr(Trim(SeparateRight(Value, ':')));
|
||||
Exit;
|
||||
end;
|
||||
if Pos('PRIORITY:', s) = 1 then
|
||||
begin
|
||||
FPri := ParsePriority(value);
|
||||
Exit;
|
||||
end;
|
||||
if Pos('X-PRIORITY:', s) = 1 then
|
||||
begin
|
||||
FXPri := ParsePriority(value);
|
||||
Exit;
|
||||
end;
|
||||
if Pos('X-MSMAIL-PRIORITY:', s) = 1 then
|
||||
begin
|
||||
FXmsPri := ParsePriority(value);
|
||||
Exit;
|
||||
end;
|
||||
if Pos('MIME-VERSION:', s) = 1 then
|
||||
Exit;
|
||||
if Pos('CONTENT-TYPE:', s) = 1 then
|
||||
Exit;
|
||||
if Pos('CONTENT-DESCRIPTION:', s) = 1 then
|
||||
Exit;
|
||||
if Pos('CONTENT-DISPOSITION:', s) = 1 then
|
||||
Exit;
|
||||
if Pos('CONTENT-ID:', s) = 1 then
|
||||
Exit;
|
||||
if Pos('CONTENT-TRANSFER-ENCODING:', s) = 1 then
|
||||
Exit;
|
||||
Result := False;
|
||||
end;
|
||||
|
||||
procedure TMessHeader.DecodeHeaders(const Value: TStrings);
|
||||
var
|
||||
s: string;
|
||||
x: Integer;
|
||||
begin
|
||||
Clear;
|
||||
Fpri := MP_unknown;
|
||||
Fxpri := MP_unknown;
|
||||
Fxmspri := MP_unknown;
|
||||
x := 0;
|
||||
while Value.Count > x do
|
||||
begin
|
||||
s := NormalizeHeader(Value, x);
|
||||
if s = '' then
|
||||
Break;
|
||||
if not DecodeHeader(s) then
|
||||
FCustomHeaders.Add(s);
|
||||
end;
|
||||
if Fpri <> MP_unknown then
|
||||
FPriority := Fpri
|
||||
else
|
||||
if Fxpri <> MP_unknown then
|
||||
FPriority := Fxpri
|
||||
else
|
||||
if Fxmspri <> MP_unknown then
|
||||
FPriority := Fxmspri
|
||||
end;
|
||||
|
||||
function TMessHeader.FindHeader(Value: string): string;
|
||||
var
|
||||
n: integer;
|
||||
begin
|
||||
Result := '';
|
||||
for n := 0 to FCustomHeaders.Count - 1 do
|
||||
if Pos(UpperCase(Value), UpperCase(FCustomHeaders[n])) = 1 then
|
||||
begin
|
||||
Result := Trim(SeparateRight(FCustomHeaders[n], ':'));
|
||||
break;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TMessHeader.FindHeaderList(Value: string; const HeaderList: TStrings);
|
||||
var
|
||||
n: integer;
|
||||
begin
|
||||
HeaderList.Clear;
|
||||
for n := 0 to FCustomHeaders.Count - 1 do
|
||||
if Pos(UpperCase(Value), UpperCase(FCustomHeaders[n])) = 1 then
|
||||
begin
|
||||
HeaderList.Add(Trim(SeparateRight(FCustomHeaders[n], ':')));
|
||||
end;
|
||||
end;
|
||||
|
||||
{==============================================================================}
|
||||
|
||||
constructor TMimeMess.Create;
|
||||
begin
|
||||
CreateAltHeaders(TMessHeader);
|
||||
end;
|
||||
|
||||
constructor TMimeMess.CreateAltHeaders(HeadClass: TMessHeaderClass);
|
||||
begin
|
||||
inherited Create;
|
||||
FMessagePart := TMimePart.Create;
|
||||
FLines := TStringList.Create;
|
||||
FHeader := HeadClass.Create;
|
||||
end;
|
||||
|
||||
destructor TMimeMess.Destroy;
|
||||
begin
|
||||
FMessagePart.Free;
|
||||
FHeader.Free;
|
||||
FLines.Free;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
{==============================================================================}
|
||||
|
||||
procedure TMimeMess.Clear;
|
||||
begin
|
||||
FMessagePart.Clear;
|
||||
FLines.Clear;
|
||||
FHeader.Clear;
|
||||
end;
|
||||
|
||||
{==============================================================================}
|
||||
|
||||
function TMimeMess.AddPart(const PartParent: TMimePart): TMimePart;
|
||||
begin
|
||||
if PartParent = nil then
|
||||
Result := FMessagePart
|
||||
else
|
||||
Result := PartParent.AddSubPart;
|
||||
Result.Clear;
|
||||
end;
|
||||
|
||||
{==============================================================================}
|
||||
|
||||
function TMimeMess.AddPartMultipart(const MultipartType: String; const PartParent: TMimePart): TMimePart;
|
||||
begin
|
||||
Result := AddPart(PartParent);
|
||||
with Result do
|
||||
begin
|
||||
Primary := 'Multipart';
|
||||
Secondary := MultipartType;
|
||||
Description := 'Multipart message';
|
||||
Boundary := GenerateBoundary;
|
||||
EncodePartHeader;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TMimeMess.AddPartText(const Value: TStrings; const PartParent: TMimePart): TMimepart;
|
||||
begin
|
||||
Result := AddPart(PartParent);
|
||||
with Result do
|
||||
begin
|
||||
Value.SaveToStream(DecodedLines);
|
||||
Primary := 'text';
|
||||
Secondary := 'plain';
|
||||
Description := 'Message text';
|
||||
Disposition := 'inline';
|
||||
CharsetCode := IdealCharsetCoding(Value.Text, TargetCharset, IdealCharsets);
|
||||
EncodingCode := ME_QUOTED_PRINTABLE;
|
||||
EncodePart;
|
||||
EncodePartHeader;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TMimeMess.AddPartTextEx(const Value: TStrings; const PartParent: TMimePart;
|
||||
PartCharset: TMimeChar; Raw: Boolean; PartEncoding: TMimeEncoding): TMimepart;
|
||||
begin
|
||||
Result := AddPart(PartParent);
|
||||
with Result do
|
||||
begin
|
||||
Value.SaveToStream(DecodedLines);
|
||||
Primary := 'text';
|
||||
Secondary := 'plain';
|
||||
Description := 'Message text';
|
||||
Disposition := 'inline';
|
||||
CharsetCode := PartCharset;
|
||||
EncodingCode := PartEncoding;
|
||||
ConvertCharset := not Raw;
|
||||
EncodePart;
|
||||
EncodePartHeader;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TMimeMess.AddPartHTML(const Value: TStrings; const PartParent: TMimePart): TMimepart;
|
||||
begin
|
||||
Result := AddPart(PartParent);
|
||||
with Result do
|
||||
begin
|
||||
Value.SaveToStream(DecodedLines);
|
||||
Primary := 'text';
|
||||
Secondary := 'html';
|
||||
Description := 'HTML text';
|
||||
Disposition := 'inline';
|
||||
CharsetCode := UTF_8;
|
||||
EncodingCode := ME_QUOTED_PRINTABLE;
|
||||
EncodePart;
|
||||
EncodePartHeader;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TMimeMess.AddPartTextFromFile(const FileName: String; const PartParent: TMimePart): TMimepart;
|
||||
var
|
||||
tmp: TStrings;
|
||||
begin
|
||||
tmp := TStringList.Create;
|
||||
try
|
||||
tmp.LoadFromFile(FileName);
|
||||
Result := AddPartText(tmp, PartParent);
|
||||
Finally
|
||||
tmp.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TMimeMess.AddPartHTMLFromFile(const FileName: String; const PartParent: TMimePart): TMimepart;
|
||||
var
|
||||
tmp: TStrings;
|
||||
begin
|
||||
tmp := TStringList.Create;
|
||||
try
|
||||
tmp.LoadFromFile(FileName);
|
||||
Result := AddPartHTML(tmp, PartParent);
|
||||
Finally
|
||||
tmp.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TMimeMess.AddPartBinary(const Stream: TStream; const FileName: string; const PartParent: TMimePart): TMimepart;
|
||||
begin
|
||||
Result := AddPart(PartParent);
|
||||
Result.DecodedLines.LoadFromStream(Stream);
|
||||
Result.MimeTypeFromExt(FileName);
|
||||
Result.Description := 'Attached file: ' + FileName;
|
||||
Result.Disposition := 'attachment';
|
||||
Result.FileName := FileName;
|
||||
Result.EncodingCode := ME_BASE64;
|
||||
Result.EncodePart;
|
||||
Result.EncodePartHeader;
|
||||
end;
|
||||
|
||||
function TMimeMess.AddPartBinaryFromFile(const FileName: string; const PartParent: TMimePart): TMimepart;
|
||||
var
|
||||
tmp: TMemoryStream;
|
||||
begin
|
||||
tmp := TMemoryStream.Create;
|
||||
try
|
||||
tmp.LoadFromFile(FileName);
|
||||
Result := AddPartBinary(tmp, ExtractFileName(FileName), PartParent);
|
||||
finally
|
||||
tmp.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TMimeMess.AddPartHTMLBinary(const Stream: TStream; const FileName, Cid: string; const PartParent: TMimePart): TMimepart;
|
||||
begin
|
||||
Result := AddPart(PartParent);
|
||||
Result.DecodedLines.LoadFromStream(Stream);
|
||||
Result.MimeTypeFromExt(FileName);
|
||||
Result.Description := 'Included file: ' + FileName;
|
||||
Result.Disposition := 'inline';
|
||||
Result.ContentID := Cid;
|
||||
Result.FileName := FileName;
|
||||
Result.EncodingCode := ME_BASE64;
|
||||
Result.EncodePart;
|
||||
Result.EncodePartHeader;
|
||||
end;
|
||||
|
||||
function TMimeMess.AddPartHTMLBinaryFromFile(const FileName, Cid: string; const PartParent: TMimePart): TMimepart;
|
||||
var
|
||||
tmp: TMemoryStream;
|
||||
begin
|
||||
tmp := TMemoryStream.Create;
|
||||
try
|
||||
tmp.LoadFromFile(FileName);
|
||||
Result :=AddPartHTMLBinary(tmp, ExtractFileName(FileName), Cid, PartParent);
|
||||
finally
|
||||
tmp.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TMimeMess.AddPartMess(const Value: TStrings; const PartParent: TMimePart): TMimepart;
|
||||
var
|
||||
part: Tmimepart;
|
||||
begin
|
||||
Result := AddPart(PartParent);
|
||||
part := AddPart(result);
|
||||
part.lines.addstrings(Value);
|
||||
part.DecomposeParts;
|
||||
with Result do
|
||||
begin
|
||||
Primary := 'message';
|
||||
Secondary := 'rfc822';
|
||||
Description := 'E-mail Message';
|
||||
EncodePart;
|
||||
EncodePartHeader;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TMimeMess.AddPartMessFromFile(const FileName: String; const PartParent: TMimePart): TMimepart;
|
||||
var
|
||||
tmp: TStrings;
|
||||
begin
|
||||
tmp := TStringList.Create;
|
||||
try
|
||||
tmp.LoadFromFile(FileName);
|
||||
Result := AddPartMess(tmp, PartParent);
|
||||
Finally
|
||||
tmp.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
{==============================================================================}
|
||||
|
||||
procedure TMimeMess.EncodeMessage;
|
||||
var
|
||||
l: TStringList;
|
||||
x: integer;
|
||||
begin
|
||||
//merge headers from THeaders and header field from MessagePart
|
||||
l := TStringList.Create;
|
||||
try
|
||||
FHeader.EncodeHeaders(l);
|
||||
x := IndexByBegin('CONTENT-TYPE', FMessagePart.Headers);
|
||||
if x >= 0 then
|
||||
l.add(FMessagePart.Headers[x]);
|
||||
x := IndexByBegin('CONTENT-DESCRIPTION', FMessagePart.Headers);
|
||||
if x >= 0 then
|
||||
l.add(FMessagePart.Headers[x]);
|
||||
x := IndexByBegin('CONTENT-DISPOSITION', FMessagePart.Headers);
|
||||
if x >= 0 then
|
||||
l.add(FMessagePart.Headers[x]);
|
||||
x := IndexByBegin('CONTENT-ID', FMessagePart.Headers);
|
||||
if x >= 0 then
|
||||
l.add(FMessagePart.Headers[x]);
|
||||
x := IndexByBegin('CONTENT-TRANSFER-ENCODING', FMessagePart.Headers);
|
||||
if x >= 0 then
|
||||
l.add(FMessagePart.Headers[x]);
|
||||
FMessagePart.Headers.Assign(l);
|
||||
finally
|
||||
l.Free;
|
||||
end;
|
||||
FMessagePart.ComposeParts;
|
||||
FLines.Assign(FMessagePart.Lines);
|
||||
end;
|
||||
|
||||
{==============================================================================}
|
||||
|
||||
procedure TMimeMess.DecodeMessage;
|
||||
begin
|
||||
FHeader.Clear;
|
||||
FHeader.DecodeHeaders(FLines);
|
||||
FMessagePart.Lines.Assign(FLines);
|
||||
FMessagePart.DecomposeParts;
|
||||
end;
|
||||
|
||||
{pf}
|
||||
procedure TMimeMess.DecodeMessageBinary(AHeader:TStrings; AData:TMemoryStream);
|
||||
begin
|
||||
FHeader.Clear;
|
||||
FLines.Clear;
|
||||
FLines.Assign(AHeader);
|
||||
FHeader.DecodeHeaders(FLines);
|
||||
FMessagePart.DecomposePartsBinary(AHeader,PANSIChar(AData.Memory),PANSIChar(AData.Memory)+AData.Size);
|
||||
end;
|
||||
{/pf}
|
||||
|
||||
end.
|
1227
synapse/mimepart.pas
Normal file
1227
synapse/mimepart.pas
Normal file
File diff suppressed because it is too large
Load Diff
483
synapse/nntpsend.pas
Normal file
483
synapse/nntpsend.pas
Normal file
@ -0,0 +1,483 @@
|
||||
{==============================================================================|
|
||||
| Project : Ararat Synapse | 001.005.003 |
|
||||
|==============================================================================|
|
||||
| Content: NNTP client |
|
||||
|==============================================================================|
|
||||
| Copyright (c)1999-2011, Lukas Gebauer |
|
||||
| All rights reserved. |
|
||||
| |
|
||||
| Redistribution and use in source and binary forms, with or without |
|
||||
| modification, are permitted provided that the following conditions are met: |
|
||||
| |
|
||||
| Redistributions of source code must retain the above copyright notice, this |
|
||||
| list of conditions and the following disclaimer. |
|
||||
| |
|
||||
| Redistributions in binary form must reproduce the above copyright notice, |
|
||||
| this list of conditions and the following disclaimer in the documentation |
|
||||
| and/or other materials provided with the distribution. |
|
||||
| |
|
||||
| Neither the name of Lukas Gebauer nor the names of its contributors may |
|
||||
| be used to endorse or promote products derived from this software without |
|
||||
| specific prior written permission. |
|
||||
| |
|
||||
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
|
||||
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
|
||||
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
|
||||
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
|
||||
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
|
||||
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
|
||||
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
|
||||
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
|
||||
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
|
||||
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
|
||||
| DAMAGE. |
|
||||
|==============================================================================|
|
||||
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
|
||||
| Portions created by Lukas Gebauer are Copyright (c) 1999-2011. |
|
||||
| All Rights Reserved. |
|
||||
|==============================================================================|
|
||||
| Contributor(s): |
|
||||
|==============================================================================|
|
||||
| History: see HISTORY.HTM from distribution package |
|
||||
| (Found at URL: http://www.ararat.cz/synapse/) |
|
||||
|==============================================================================}
|
||||
|
||||
{:@abstract(NNTP client)
|
||||
NNTP (network news transfer protocol)
|
||||
|
||||
Used RFC: RFC-977, RFC-2980
|
||||
}
|
||||
|
||||
{$IFDEF FPC}
|
||||
{$MODE DELPHI}
|
||||
{$ENDIF}
|
||||
{$H+}
|
||||
|
||||
{$IFDEF UNICODE}
|
||||
{$WARN IMPLICIT_STRING_CAST OFF}
|
||||
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
|
||||
{$WARN SUSPICIOUS_TYPECAST OFF}
|
||||
{$ENDIF}
|
||||
|
||||
unit nntpsend;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
SysUtils, Classes,
|
||||
blcksock, synautil;
|
||||
|
||||
const
|
||||
cNNTPProtocol = '119';
|
||||
|
||||
type
|
||||
|
||||
{:abstract(Implementation of Network News Transfer Protocol.
|
||||
|
||||
Note: Are you missing properties for setting Username and Password? Look to
|
||||
parent @link(TSynaClient) object!
|
||||
|
||||
Are you missing properties for specify server address and port? Look to
|
||||
parent @link(TSynaClient) too!}
|
||||
TNNTPSend = class(TSynaClient)
|
||||
private
|
||||
FSock: TTCPBlockSocket;
|
||||
FResultCode: Integer;
|
||||
FResultString: string;
|
||||
FData: TStringList;
|
||||
FDataToSend: TStringList;
|
||||
FAutoTLS: Boolean;
|
||||
FFullSSL: Boolean;
|
||||
FNNTPcap: TStringList;
|
||||
function ReadResult: Integer;
|
||||
function ReadData: boolean;
|
||||
function SendData: boolean;
|
||||
function Connect: Boolean;
|
||||
public
|
||||
constructor Create;
|
||||
destructor Destroy; override;
|
||||
|
||||
{:Connects to NNTP server and begin session.}
|
||||
function Login: Boolean;
|
||||
|
||||
{:Logout from NNTP server and terminate session.}
|
||||
function Logout: Boolean;
|
||||
|
||||
{:By this you can call any NNTP command.}
|
||||
function DoCommand(const Command: string): boolean;
|
||||
|
||||
{:by this you can call any NNTP command. This variant is used for commands
|
||||
for download information from server.}
|
||||
function DoCommandRead(const Command: string): boolean;
|
||||
|
||||
{:by this you can call any NNTP command. This variant is used for commands
|
||||
for upload information to server.}
|
||||
function DoCommandWrite(const Command: string): boolean;
|
||||
|
||||
{:Download full message to @link(data) property. Value can be number of
|
||||
message or message-id (in brackets).}
|
||||
function GetArticle(const Value: string): Boolean;
|
||||
|
||||
{:Download only body of message to @link(data) property. Value can be number
|
||||
of message or message-id (in brackets).}
|
||||
function GetBody(const Value: string): Boolean;
|
||||
|
||||
{:Download only headers of message to @link(data) property. Value can be
|
||||
number of message or message-id (in brackets).}
|
||||
function GetHead(const Value: string): Boolean;
|
||||
|
||||
{:Get message status. Value can be number of message or message-id
|
||||
(in brackets).}
|
||||
function GetStat(const Value: string): Boolean;
|
||||
|
||||
{:Select given group.}
|
||||
function SelectGroup(const Value: string): Boolean;
|
||||
|
||||
{:Tell to server 'I have mesage with given message-ID.' If server need this
|
||||
message, message is uploaded to server.}
|
||||
function IHave(const MessID: string): Boolean;
|
||||
|
||||
{:Move message pointer to last item in group.}
|
||||
function GotoLast: Boolean;
|
||||
|
||||
{:Move message pointer to next item in group.}
|
||||
function GotoNext: Boolean;
|
||||
|
||||
{:Download to @link(data) property list of all groups on NNTP server.}
|
||||
function ListGroups: Boolean;
|
||||
|
||||
{:Download to @link(data) property list of all groups created after given time.}
|
||||
function ListNewGroups(Since: TDateTime): Boolean;
|
||||
|
||||
{:Download to @link(data) property list of message-ids in given group since
|
||||
given time.}
|
||||
function NewArticles(const Group: string; Since: TDateTime): Boolean;
|
||||
|
||||
{:Upload new article to server. (for new messages by you)}
|
||||
function PostArticle: Boolean;
|
||||
|
||||
{:Tells to remote NNTP server 'I am not NNTP client, but I am another NNTP
|
||||
server'.}
|
||||
function SwitchToSlave: Boolean;
|
||||
|
||||
{:Call NNTP XOVER command.}
|
||||
function Xover(xoStart, xoEnd: string): boolean;
|
||||
|
||||
{:Call STARTTLS command for upgrade connection to SSL/TLS mode.}
|
||||
function StartTLS: Boolean;
|
||||
|
||||
{:Try to find given capability in extension list. This list is getted after
|
||||
successful login to NNTP server. If extension capability is not found,
|
||||
then return is empty string.}
|
||||
function FindCap(const Value: string): string;
|
||||
|
||||
{:Try get list of server extensions. List is returned in @link(data) property.}
|
||||
function ListExtensions: Boolean;
|
||||
published
|
||||
{:Result code number of last operation.}
|
||||
property ResultCode: Integer read FResultCode;
|
||||
|
||||
{:String description of last result code from NNTP server.}
|
||||
property ResultString: string read FResultString;
|
||||
|
||||
{:Readed data. (message, etc.)}
|
||||
property Data: TStringList read FData;
|
||||
|
||||
{:If is set to @true, then upgrade to SSL/TLS mode after login if remote
|
||||
server support it.}
|
||||
property AutoTLS: Boolean read FAutoTLS Write FAutoTLS;
|
||||
|
||||
{:SSL/TLS mode is used from first contact to server. Servers with full
|
||||
SSL/TLS mode usualy using non-standard TCP port!}
|
||||
property FullSSL: Boolean read FFullSSL Write FFullSSL;
|
||||
|
||||
{:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.}
|
||||
property Sock: TTCPBlockSocket read FSock;
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
constructor TNNTPSend.Create;
|
||||
begin
|
||||
inherited Create;
|
||||
FSock := TTCPBlockSocket.Create;
|
||||
FSock.Owner := self;
|
||||
FData := TStringList.Create;
|
||||
FDataToSend := TStringList.Create;
|
||||
FNNTPcap := TStringList.Create;
|
||||
FSock.ConvertLineEnd := True;
|
||||
FTimeout := 60000;
|
||||
FTargetPort := cNNTPProtocol;
|
||||
FAutoTLS := False;
|
||||
FFullSSL := False;
|
||||
end;
|
||||
|
||||
destructor TNNTPSend.Destroy;
|
||||
begin
|
||||
FSock.Free;
|
||||
FDataToSend.Free;
|
||||
FData.Free;
|
||||
FNNTPcap.Free;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
function TNNTPSend.ReadResult: Integer;
|
||||
var
|
||||
s: string;
|
||||
begin
|
||||
Result := 0;
|
||||
FData.Clear;
|
||||
s := FSock.RecvString(FTimeout);
|
||||
FResultString := Copy(s, 5, Length(s) - 4);
|
||||
if FSock.LastError <> 0 then
|
||||
Exit;
|
||||
if Length(s) >= 3 then
|
||||
Result := StrToIntDef(Copy(s, 1, 3), 0);
|
||||
FResultCode := Result;
|
||||
end;
|
||||
|
||||
function TNNTPSend.ReadData: boolean;
|
||||
var
|
||||
s: string;
|
||||
begin
|
||||
repeat
|
||||
s := FSock.RecvString(FTimeout);
|
||||
if s = '.' then
|
||||
break;
|
||||
if (s <> '') and (s[1] = '.') then
|
||||
s := Copy(s, 2, Length(s) - 1);
|
||||
FData.Add(s);
|
||||
until FSock.LastError <> 0;
|
||||
Result := FSock.LastError = 0;
|
||||
end;
|
||||
|
||||
function TNNTPSend.SendData: boolean;
|
||||
var
|
||||
s: string;
|
||||
n: integer;
|
||||
begin
|
||||
for n := 0 to FDataToSend.Count - 1 do
|
||||
begin
|
||||
s := FDataToSend[n];
|
||||
if (s <> '') and (s[1] = '.') then
|
||||
s := s + '.';
|
||||
FSock.SendString(s + CRLF);
|
||||
if FSock.LastError <> 0 then
|
||||
break;
|
||||
end;
|
||||
if FDataToSend.Count = 0 then
|
||||
FSock.SendString(CRLF);
|
||||
if FSock.LastError = 0 then
|
||||
FSock.SendString('.' + CRLF);
|
||||
FDataToSend.Clear;
|
||||
Result := FSock.LastError = 0;
|
||||
end;
|
||||
|
||||
function TNNTPSend.Connect: Boolean;
|
||||
begin
|
||||
FSock.CloseSocket;
|
||||
FSock.Bind(FIPInterface, cAnyPort);
|
||||
if FSock.LastError = 0 then
|
||||
FSock.Connect(FTargetHost, FTargetPort);
|
||||
if FSock.LastError = 0 then
|
||||
if FFullSSL then
|
||||
FSock.SSLDoConnect;
|
||||
Result := FSock.LastError = 0;
|
||||
end;
|
||||
|
||||
function TNNTPSend.Login: Boolean;
|
||||
begin
|
||||
Result := False;
|
||||
FNNTPcap.Clear;
|
||||
if not Connect then
|
||||
Exit;
|
||||
Result := (ReadResult div 100) = 2;
|
||||
if Result then
|
||||
begin
|
||||
ListExtensions;
|
||||
FNNTPcap.Assign(Fdata);
|
||||
if (not FullSSL) and FAutoTLS and (FindCap('STARTTLS') <> '') then
|
||||
Result := StartTLS;
|
||||
end;
|
||||
if (FUsername <> '') and Result then
|
||||
begin
|
||||
FSock.SendString('AUTHINFO USER ' + FUsername + CRLF);
|
||||
if (ReadResult div 100) = 3 then
|
||||
begin
|
||||
FSock.SendString('AUTHINFO PASS ' + FPassword + CRLF);
|
||||
Result := (ReadResult div 100) = 2;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TNNTPSend.Logout: Boolean;
|
||||
begin
|
||||
FSock.SendString('QUIT' + CRLF);
|
||||
Result := (ReadResult div 100) = 2;
|
||||
FSock.CloseSocket;
|
||||
end;
|
||||
|
||||
function TNNTPSend.DoCommand(const Command: string): Boolean;
|
||||
begin
|
||||
FSock.SendString(Command + CRLF);
|
||||
Result := (ReadResult div 100) = 2;
|
||||
Result := Result and (FSock.LastError = 0);
|
||||
end;
|
||||
|
||||
function TNNTPSend.DoCommandRead(const Command: string): Boolean;
|
||||
begin
|
||||
Result := DoCommand(Command);
|
||||
if Result then
|
||||
begin
|
||||
Result := ReadData;
|
||||
Result := Result and (FSock.LastError = 0);
|
||||
end;
|
||||
end;
|
||||
|
||||
function TNNTPSend.DoCommandWrite(const Command: string): Boolean;
|
||||
var
|
||||
x: integer;
|
||||
begin
|
||||
FDataToSend.Assign(FData);
|
||||
FSock.SendString(Command + CRLF);
|
||||
x := (ReadResult div 100);
|
||||
if x = 3 then
|
||||
begin
|
||||
SendData;
|
||||
x := (ReadResult div 100);
|
||||
end;
|
||||
Result := x = 2;
|
||||
Result := Result and (FSock.LastError = 0);
|
||||
end;
|
||||
|
||||
function TNNTPSend.GetArticle(const Value: string): Boolean;
|
||||
var
|
||||
s: string;
|
||||
begin
|
||||
s := 'ARTICLE';
|
||||
if Value <> '' then
|
||||
s := s + ' ' + Value;
|
||||
Result := DoCommandRead(s);
|
||||
end;
|
||||
|
||||
function TNNTPSend.GetBody(const Value: string): Boolean;
|
||||
var
|
||||
s: string;
|
||||
begin
|
||||
s := 'BODY';
|
||||
if Value <> '' then
|
||||
s := s + ' ' + Value;
|
||||
Result := DoCommandRead(s);
|
||||
end;
|
||||
|
||||
function TNNTPSend.GetHead(const Value: string): Boolean;
|
||||
var
|
||||
s: string;
|
||||
begin
|
||||
s := 'HEAD';
|
||||
if Value <> '' then
|
||||
s := s + ' ' + Value;
|
||||
Result := DoCommandRead(s);
|
||||
end;
|
||||
|
||||
function TNNTPSend.GetStat(const Value: string): Boolean;
|
||||
var
|
||||
s: string;
|
||||
begin
|
||||
s := 'STAT';
|
||||
if Value <> '' then
|
||||
s := s + ' ' + Value;
|
||||
Result := DoCommand(s);
|
||||
end;
|
||||
|
||||
function TNNTPSend.SelectGroup(const Value: string): Boolean;
|
||||
begin
|
||||
Result := DoCommand('GROUP ' + Value);
|
||||
end;
|
||||
|
||||
function TNNTPSend.IHave(const MessID: string): Boolean;
|
||||
begin
|
||||
Result := DoCommandWrite('IHAVE ' + MessID);
|
||||
end;
|
||||
|
||||
function TNNTPSend.GotoLast: Boolean;
|
||||
begin
|
||||
Result := DoCommand('LAST');
|
||||
end;
|
||||
|
||||
function TNNTPSend.GotoNext: Boolean;
|
||||
begin
|
||||
Result := DoCommand('NEXT');
|
||||
end;
|
||||
|
||||
function TNNTPSend.ListGroups: Boolean;
|
||||
begin
|
||||
Result := DoCommandRead('LIST');
|
||||
end;
|
||||
|
||||
function TNNTPSend.ListNewGroups(Since: TDateTime): Boolean;
|
||||
begin
|
||||
Result := DoCommandRead('NEWGROUPS ' + SimpleDateTime(Since) + ' GMT');
|
||||
end;
|
||||
|
||||
function TNNTPSend.NewArticles(const Group: string; Since: TDateTime): Boolean;
|
||||
begin
|
||||
Result := DoCommandRead('NEWNEWS ' + Group + ' ' + SimpleDateTime(Since) + ' GMT');
|
||||
end;
|
||||
|
||||
function TNNTPSend.PostArticle: Boolean;
|
||||
begin
|
||||
Result := DoCommandWrite('POST');
|
||||
end;
|
||||
|
||||
function TNNTPSend.SwitchToSlave: Boolean;
|
||||
begin
|
||||
Result := DoCommand('SLAVE');
|
||||
end;
|
||||
|
||||
function TNNTPSend.Xover(xoStart, xoEnd: string): Boolean;
|
||||
var
|
||||
s: string;
|
||||
begin
|
||||
s := 'XOVER ' + xoStart;
|
||||
if xoEnd <> xoStart then
|
||||
s := s + '-' + xoEnd;
|
||||
Result := DoCommandRead(s);
|
||||
end;
|
||||
|
||||
function TNNTPSend.StartTLS: Boolean;
|
||||
begin
|
||||
Result := False;
|
||||
if FindCap('STARTTLS') <> '' then
|
||||
begin
|
||||
if DoCommand('STARTTLS') then
|
||||
begin
|
||||
Fsock.SSLDoConnect;
|
||||
Result := FSock.LastError = 0;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TNNTPSend.ListExtensions: Boolean;
|
||||
begin
|
||||
Result := DoCommandRead('LIST EXTENSIONS');
|
||||
end;
|
||||
|
||||
function TNNTPSend.FindCap(const Value: string): string;
|
||||
var
|
||||
n: Integer;
|
||||
s: string;
|
||||
begin
|
||||
s := UpperCase(Value);
|
||||
Result := '';
|
||||
for n := 0 to FNNTPcap.Count - 1 do
|
||||
if Pos(s, UpperCase(FNNTPcap[n])) = 1 then
|
||||
begin
|
||||
Result := FNNTPcap[n];
|
||||
Break;
|
||||
end;
|
||||
end;
|
||||
|
||||
{==============================================================================}
|
||||
|
||||
end.
|
720
synapse/pingsend.pas
Normal file
720
synapse/pingsend.pas
Normal file
@ -0,0 +1,720 @@
|
||||
{==============================================================================|
|
||||
| Project : Ararat Synapse | 004.000.002 |
|
||||
|==============================================================================|
|
||||
| Content: PING sender |
|
||||
|==============================================================================|
|
||||
| Copyright (c)1999-2010, Lukas Gebauer |
|
||||
| All rights reserved. |
|
||||
| |
|
||||
| Redistribution and use in source and binary forms, with or without |
|
||||
| modification, are permitted provided that the following conditions are met: |
|
||||
| |
|
||||
| Redistributions of source code must retain the above copyright notice, this |
|
||||
| list of conditions and the following disclaimer. |
|
||||
| |
|
||||
| Redistributions in binary form must reproduce the above copyright notice, |
|
||||
| this list of conditions and the following disclaimer in the documentation |
|
||||
| and/or other materials provided with the distribution. |
|
||||
| |
|
||||
| Neither the name of Lukas Gebauer nor the names of its contributors may |
|
||||
| be used to endorse or promote products derived from this software without |
|
||||
| specific prior written permission. |
|
||||
| |
|
||||
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
|
||||
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
|
||||
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
|
||||
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
|
||||
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
|
||||
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
|
||||
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
|
||||
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
|
||||
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
|
||||
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
|
||||
| DAMAGE. |
|
||||
|==============================================================================|
|
||||
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
|
||||
| Portions created by Lukas Gebauer are Copyright (c)2000-2010. |
|
||||
| All Rights Reserved. |
|
||||
|==============================================================================|
|
||||
| Contributor(s): |
|
||||
|==============================================================================|
|
||||
| History: see HISTORY.HTM from distribution package |
|
||||
| (Found at URL: http://www.ararat.cz/synapse/) |
|
||||
|==============================================================================}
|
||||
|
||||
{:@abstract(ICMP PING implementation.)
|
||||
Allows create PING and TRACEROUTE. Or you can diagnose your network.
|
||||
|
||||
This unit using IpHlpApi (on WinXP or higher) if available. Otherwise it trying
|
||||
to use RAW sockets.
|
||||
|
||||
Warning: For use of RAW sockets you must have some special rights on some
|
||||
systems. So, it working allways when you have administator/root rights.
|
||||
Otherwise you can have problems!
|
||||
|
||||
Note: This unit is NOT portable to .NET!
|
||||
Use native .NET classes for Ping instead.
|
||||
}
|
||||
|
||||
{$IFDEF FPC}
|
||||
{$MODE DELPHI}
|
||||
{$ENDIF}
|
||||
{$Q-}
|
||||
{$R-}
|
||||
{$H+}
|
||||
|
||||
{$IFDEF CIL}
|
||||
Sorry, this unit is not for .NET!
|
||||
{$ENDIF}
|
||||
//old Delphi does not have MSWINDOWS define.
|
||||
{$IFDEF WIN32}
|
||||
{$IFNDEF MSWINDOWS}
|
||||
{$DEFINE MSWINDOWS}
|
||||
{$ENDIF}
|
||||
{$ENDIF}
|
||||
|
||||
{$IFDEF UNICODE}
|
||||
{$WARN IMPLICIT_STRING_CAST OFF}
|
||||
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
|
||||
{$ENDIF}
|
||||
|
||||
unit pingsend;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
SysUtils,
|
||||
synsock, blcksock, synautil, synafpc, synaip
|
||||
{$IFDEF MSWINDOWS}
|
||||
, windows
|
||||
{$ENDIF}
|
||||
;
|
||||
|
||||
const
|
||||
ICMP_ECHO = 8;
|
||||
ICMP_ECHOREPLY = 0;
|
||||
ICMP_UNREACH = 3;
|
||||
ICMP_TIME_EXCEEDED = 11;
|
||||
//rfc-2292
|
||||
ICMP6_ECHO = 128;
|
||||
ICMP6_ECHOREPLY = 129;
|
||||
ICMP6_UNREACH = 1;
|
||||
ICMP6_TIME_EXCEEDED = 3;
|
||||
|
||||
type
|
||||
{:List of possible ICMP reply packet types.}
|
||||
TICMPError = (
|
||||
IE_NoError,
|
||||
IE_Other,
|
||||
IE_TTLExceed,
|
||||
IE_UnreachOther,
|
||||
IE_UnreachRoute,
|
||||
IE_UnreachAdmin,
|
||||
IE_UnreachAddr,
|
||||
IE_UnreachPort
|
||||
);
|
||||
|
||||
{:@abstract(Implementation of ICMP PING and ICMPv6 PING.)}
|
||||
TPINGSend = class(TSynaClient)
|
||||
private
|
||||
FSock: TICMPBlockSocket;
|
||||
FBuffer: Ansistring;
|
||||
FSeq: Integer;
|
||||
FId: Integer;
|
||||
FPacketSize: Integer;
|
||||
FPingTime: Integer;
|
||||
FIcmpEcho: Byte;
|
||||
FIcmpEchoReply: Byte;
|
||||
FIcmpUnreach: Byte;
|
||||
FReplyFrom: string;
|
||||
FReplyType: byte;
|
||||
FReplyCode: byte;
|
||||
FReplyError: TICMPError;
|
||||
FReplyErrorDesc: string;
|
||||
FTTL: Byte;
|
||||
Fsin: TVarSin;
|
||||
function Checksum(Value: AnsiString): Word;
|
||||
function Checksum6(Value: AnsiString): Word;
|
||||
function ReadPacket: Boolean;
|
||||
procedure TranslateError;
|
||||
procedure TranslateErrorIpHlp(value: integer);
|
||||
function InternalPing(const Host: string): Boolean;
|
||||
function InternalPingIpHlp(const Host: string): Boolean;
|
||||
function IsHostIP6(const Host: string): Boolean;
|
||||
procedure GenErrorDesc;
|
||||
public
|
||||
{:Send ICMP ping to host and count @link(pingtime). If ping OK, result is
|
||||
@true.}
|
||||
function Ping(const Host: string): Boolean;
|
||||
constructor Create;
|
||||
destructor Destroy; override;
|
||||
published
|
||||
{:Size of PING packet. Default size is 32 bytes.}
|
||||
property PacketSize: Integer read FPacketSize Write FPacketSize;
|
||||
|
||||
{:Time between request and reply.}
|
||||
property PingTime: Integer read FPingTime;
|
||||
|
||||
{:From this address is sended reply for your PING request. It maybe not your
|
||||
requested destination, when some error occured!}
|
||||
property ReplyFrom: string read FReplyFrom;
|
||||
|
||||
{:ICMP type of PING reply. Each protocol using another values! For IPv4 and
|
||||
IPv6 are used different values!}
|
||||
property ReplyType: byte read FReplyType;
|
||||
|
||||
{:ICMP code of PING reply. Each protocol using another values! For IPv4 and
|
||||
IPv6 are used different values! For protocol independent value look to
|
||||
@link(ReplyError)}
|
||||
property ReplyCode: byte read FReplyCode;
|
||||
|
||||
{:Return type of returned ICMP message. This value is independent on used
|
||||
protocol!}
|
||||
property ReplyError: TICMPError read FReplyError;
|
||||
|
||||
{:Return human readable description of returned packet type.}
|
||||
property ReplyErrorDesc: string read FReplyErrorDesc;
|
||||
|
||||
{:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.}
|
||||
property Sock: TICMPBlockSocket read FSock;
|
||||
|
||||
{:TTL value for ICMP query}
|
||||
property TTL: byte read FTTL write FTTL;
|
||||
end;
|
||||
|
||||
{:A very useful function and example of its use would be found in the TPINGSend
|
||||
object. Use it to ping to any host. If successful, returns the ping time in
|
||||
milliseconds. Returns -1 if an error occurred.}
|
||||
function PingHost(const Host: string): Integer;
|
||||
|
||||
{:A very useful function and example of its use would be found in the TPINGSend
|
||||
object. Use it to TraceRoute to any host.}
|
||||
function TraceRouteHost(const Host: string): string;
|
||||
|
||||
implementation
|
||||
|
||||
type
|
||||
{:Record for ICMP ECHO packet header.}
|
||||
TIcmpEchoHeader = packed record
|
||||
i_type: Byte;
|
||||
i_code: Byte;
|
||||
i_checkSum: Word;
|
||||
i_Id: Word;
|
||||
i_seq: Word;
|
||||
TimeStamp: integer;
|
||||
end;
|
||||
|
||||
{:record used internally by TPingSend for compute checksum of ICMPv6 packet
|
||||
pseudoheader.}
|
||||
TICMP6Packet = packed record
|
||||
in_source: TInAddr6;
|
||||
in_dest: TInAddr6;
|
||||
Length: integer;
|
||||
free0: Byte;
|
||||
free1: Byte;
|
||||
free2: Byte;
|
||||
proto: Byte;
|
||||
end;
|
||||
|
||||
{$IFDEF MSWINDOWS}
|
||||
const
|
||||
DLLIcmpName = 'iphlpapi.dll';
|
||||
type
|
||||
TIP_OPTION_INFORMATION = record
|
||||
TTL: Byte;
|
||||
TOS: Byte;
|
||||
Flags: Byte;
|
||||
OptionsSize: Byte;
|
||||
OptionsData: PAnsiChar;
|
||||
end;
|
||||
PIP_OPTION_INFORMATION = ^TIP_OPTION_INFORMATION;
|
||||
|
||||
TICMP_ECHO_REPLY = record
|
||||
Address: TInAddr;
|
||||
Status: integer;
|
||||
RoundTripTime: integer;
|
||||
DataSize: Word;
|
||||
Reserved: Word;
|
||||
Data: pointer;
|
||||
Options: TIP_OPTION_INFORMATION;
|
||||
end;
|
||||
PICMP_ECHO_REPLY = ^TICMP_ECHO_REPLY;
|
||||
|
||||
TICMPV6_ECHO_REPLY = record
|
||||
Address: TSockAddrIn6;
|
||||
Status: integer;
|
||||
RoundTripTime: integer;
|
||||
end;
|
||||
PICMPV6_ECHO_REPLY = ^TICMPV6_ECHO_REPLY;
|
||||
|
||||
TIcmpCreateFile = function: integer; stdcall;
|
||||
TIcmpCloseHandle = function(handle: integer): boolean; stdcall;
|
||||
TIcmpSendEcho2 = function(handle: integer; Event: pointer; ApcRoutine: pointer;
|
||||
ApcContext: pointer; DestinationAddress: TInAddr; RequestData: pointer;
|
||||
RequestSize: integer; RequestOptions: PIP_OPTION_INFORMATION;
|
||||
ReplyBuffer: pointer; ReplySize: integer; Timeout: Integer): integer; stdcall;
|
||||
TIcmp6CreateFile = function: integer; stdcall;
|
||||
TIcmp6SendEcho2 = function(handle: integer; Event: pointer; ApcRoutine: pointer;
|
||||
ApcContext: pointer; SourceAddress: PSockAddrIn6; DestinationAddress: PSockAddrIn6;
|
||||
RequestData: pointer; RequestSize: integer; RequestOptions: PIP_OPTION_INFORMATION;
|
||||
ReplyBuffer: pointer; ReplySize: integer; Timeout: Integer): integer; stdcall;
|
||||
|
||||
var
|
||||
IcmpDllHandle: TLibHandle = 0;
|
||||
IcmpHelper4: boolean = false;
|
||||
IcmpHelper6: boolean = false;
|
||||
IcmpCreateFile: TIcmpCreateFile = nil;
|
||||
IcmpCloseHandle: TIcmpCloseHandle = nil;
|
||||
IcmpSendEcho2: TIcmpSendEcho2 = nil;
|
||||
Icmp6CreateFile: TIcmp6CreateFile = nil;
|
||||
Icmp6SendEcho2: TIcmp6SendEcho2 = nil;
|
||||
{$ENDIF}
|
||||
{==============================================================================}
|
||||
|
||||
constructor TPINGSend.Create;
|
||||
begin
|
||||
inherited Create;
|
||||
FSock := TICMPBlockSocket.Create;
|
||||
FSock.Owner := self;
|
||||
FTimeout := 5000;
|
||||
FPacketSize := 32;
|
||||
FSeq := 0;
|
||||
Randomize;
|
||||
FTTL := 128;
|
||||
end;
|
||||
|
||||
destructor TPINGSend.Destroy;
|
||||
begin
|
||||
FSock.Free;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
function TPINGSend.ReadPacket: Boolean;
|
||||
begin
|
||||
FBuffer := FSock.RecvPacket(Ftimeout);
|
||||
Result := FSock.LastError = 0;
|
||||
end;
|
||||
|
||||
procedure TPINGSend.GenErrorDesc;
|
||||
begin
|
||||
case FReplyError of
|
||||
IE_NoError:
|
||||
FReplyErrorDesc := '';
|
||||
IE_Other:
|
||||
FReplyErrorDesc := 'Unknown error';
|
||||
IE_TTLExceed:
|
||||
FReplyErrorDesc := 'TTL Exceeded';
|
||||
IE_UnreachOther:
|
||||
FReplyErrorDesc := 'Unknown unreachable';
|
||||
IE_UnreachRoute:
|
||||
FReplyErrorDesc := 'No route to destination';
|
||||
IE_UnreachAdmin:
|
||||
FReplyErrorDesc := 'Administratively prohibited';
|
||||
IE_UnreachAddr:
|
||||
FReplyErrorDesc := 'Address unreachable';
|
||||
IE_UnreachPort:
|
||||
FReplyErrorDesc := 'Port unreachable';
|
||||
end;
|
||||
end;
|
||||
|
||||
function TPINGSend.IsHostIP6(const Host: string): Boolean;
|
||||
var
|
||||
f: integer;
|
||||
begin
|
||||
f := AF_UNSPEC;
|
||||
if IsIp(Host) then
|
||||
f := AF_INET
|
||||
else
|
||||
if IsIp6(Host) then
|
||||
f := AF_INET6;
|
||||
synsock.SetVarSin(Fsin, host, '0', f,
|
||||
IPPROTO_UDP, SOCK_DGRAM, Fsock.PreferIP4);
|
||||
result := Fsin.sin_family = AF_INET6;
|
||||
end;
|
||||
|
||||
function TPINGSend.Ping(const Host: string): Boolean;
|
||||
var
|
||||
b: boolean;
|
||||
begin
|
||||
FPingTime := -1;
|
||||
FReplyFrom := '';
|
||||
FReplyType := 0;
|
||||
FReplyCode := 0;
|
||||
FReplyError := IE_Other;
|
||||
GenErrorDesc;
|
||||
FBuffer := StringOfChar(#55, SizeOf(TICMPEchoHeader) + FPacketSize);
|
||||
{$IFDEF MSWINDOWS}
|
||||
b := IsHostIP6(host);
|
||||
if not(b) and IcmpHelper4 then
|
||||
result := InternalPingIpHlp(host)
|
||||
else
|
||||
if b and IcmpHelper6 then
|
||||
result := InternalPingIpHlp(host)
|
||||
else
|
||||
result := InternalPing(host);
|
||||
{$ELSE}
|
||||
result := InternalPing(host);
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
function TPINGSend.InternalPing(const Host: string): Boolean;
|
||||
var
|
||||
IPHeadPtr: ^TIPHeader;
|
||||
IpHdrLen: Integer;
|
||||
IcmpEchoHeaderPtr: ^TICMPEchoHeader;
|
||||
t: Boolean;
|
||||
x: cardinal;
|
||||
IcmpReqHead: string;
|
||||
begin
|
||||
Result := False;
|
||||
FSock.TTL := FTTL;
|
||||
FSock.Bind(FIPInterface, cAnyPort);
|
||||
FSock.Connect(Host, '0');
|
||||
if FSock.LastError <> 0 then
|
||||
Exit;
|
||||
FSock.SizeRecvBuffer := 60 * 1024;
|
||||
if FSock.IP6used then
|
||||
begin
|
||||
FIcmpEcho := ICMP6_ECHO;
|
||||
FIcmpEchoReply := ICMP6_ECHOREPLY;
|
||||
FIcmpUnreach := ICMP6_UNREACH;
|
||||
end
|
||||
else
|
||||
begin
|
||||
FIcmpEcho := ICMP_ECHO;
|
||||
FIcmpEchoReply := ICMP_ECHOREPLY;
|
||||
FIcmpUnreach := ICMP_UNREACH;
|
||||
end;
|
||||
IcmpEchoHeaderPtr := Pointer(FBuffer);
|
||||
with IcmpEchoHeaderPtr^ do
|
||||
begin
|
||||
i_type := FIcmpEcho;
|
||||
i_code := 0;
|
||||
i_CheckSum := 0;
|
||||
FId := System.Random(32767);
|
||||
i_Id := FId;
|
||||
TimeStamp := GetTick;
|
||||
Inc(FSeq);
|
||||
i_Seq := FSeq;
|
||||
if fSock.IP6used then
|
||||
i_CheckSum := CheckSum6(FBuffer)
|
||||
else
|
||||
i_CheckSum := CheckSum(FBuffer);
|
||||
end;
|
||||
FSock.SendString(FBuffer);
|
||||
// remember first 8 bytes of ICMP packet
|
||||
IcmpReqHead := Copy(FBuffer, 1, 8);
|
||||
x := GetTick;
|
||||
repeat
|
||||
t := ReadPacket;
|
||||
if not t then
|
||||
break;
|
||||
if fSock.IP6used then
|
||||
begin
|
||||
{$IFNDEF MSWINDOWS}
|
||||
IcmpEchoHeaderPtr := Pointer(FBuffer);
|
||||
{$ELSE}
|
||||
//WinXP SP1 with networking update doing this think by another way ;-O
|
||||
// FBuffer := StringOfChar(#0, 4) + FBuffer;
|
||||
IcmpEchoHeaderPtr := Pointer(FBuffer);
|
||||
// IcmpEchoHeaderPtr^.i_type := FIcmpEchoReply;
|
||||
{$ENDIF}
|
||||
end
|
||||
else
|
||||
begin
|
||||
IPHeadPtr := Pointer(FBuffer);
|
||||
IpHdrLen := (IPHeadPtr^.VerLen and $0F) * 4;
|
||||
IcmpEchoHeaderPtr := @FBuffer[IpHdrLen + 1];
|
||||
end;
|
||||
//check for timeout
|
||||
if TickDelta(x, GetTick) > FTimeout then
|
||||
begin
|
||||
t := false;
|
||||
Break;
|
||||
end;
|
||||
//it discard sometimes possible 'echoes' of previosly sended packet
|
||||
//or other unwanted ICMP packets...
|
||||
until (IcmpEchoHeaderPtr^.i_type <> FIcmpEcho)
|
||||
and ((IcmpEchoHeaderPtr^.i_id = FId)
|
||||
or (Pos(IcmpReqHead, FBuffer) > 0));
|
||||
if t then
|
||||
begin
|
||||
FPingTime := TickDelta(x, GetTick);
|
||||
FReplyFrom := FSock.GetRemoteSinIP;
|
||||
FReplyType := IcmpEchoHeaderPtr^.i_type;
|
||||
FReplyCode := IcmpEchoHeaderPtr^.i_code;
|
||||
TranslateError;
|
||||
Result := True;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TPINGSend.Checksum(Value: AnsiString): Word;
|
||||
var
|
||||
CkSum: integer;
|
||||
Num, Remain: Integer;
|
||||
n, i: Integer;
|
||||
begin
|
||||
Num := Length(Value) div 2;
|
||||
Remain := Length(Value) mod 2;
|
||||
CkSum := 0;
|
||||
i := 1;
|
||||
for n := 0 to Num - 1 do
|
||||
begin
|
||||
CkSum := CkSum + Synsock.HtoNs(DecodeInt(Value, i));
|
||||
inc(i, 2);
|
||||
end;
|
||||
if Remain <> 0 then
|
||||
CkSum := CkSum + Ord(Value[Length(Value)]);
|
||||
CkSum := (CkSum shr 16) + (CkSum and $FFFF);
|
||||
CkSum := CkSum + (CkSum shr 16);
|
||||
Result := Word(not CkSum);
|
||||
end;
|
||||
|
||||
function TPINGSend.Checksum6(Value: AnsiString): Word;
|
||||
const
|
||||
IOC_OUT = $40000000;
|
||||
IOC_IN = $80000000;
|
||||
IOC_INOUT = (IOC_IN or IOC_OUT);
|
||||
IOC_WS2 = $08000000;
|
||||
SIO_ROUTING_INTERFACE_QUERY = 20 or IOC_WS2 or IOC_INOUT;
|
||||
var
|
||||
ICMP6Ptr: ^TICMP6Packet;
|
||||
s: AnsiString;
|
||||
b: integer;
|
||||
ip6: TSockAddrIn6;
|
||||
x: integer;
|
||||
begin
|
||||
Result := 0;
|
||||
{$IFDEF MSWINDOWS}
|
||||
s := StringOfChar(#0, SizeOf(TICMP6Packet)) + Value;
|
||||
ICMP6Ptr := Pointer(s);
|
||||
x := synsock.WSAIoctl(FSock.Socket, SIO_ROUTING_INTERFACE_QUERY,
|
||||
@FSock.RemoteSin, SizeOf(FSock.RemoteSin),
|
||||
@ip6, SizeOf(ip6), @b, nil, nil);
|
||||
if x <> -1 then
|
||||
ICMP6Ptr^.in_dest := ip6.sin6_addr
|
||||
else
|
||||
ICMP6Ptr^.in_dest := FSock.LocalSin.sin6_addr;
|
||||
ICMP6Ptr^.in_source := FSock.RemoteSin.sin6_addr;
|
||||
ICMP6Ptr^.Length := synsock.htonl(Length(Value));
|
||||
ICMP6Ptr^.proto := IPPROTO_ICMPV6;
|
||||
Result := Checksum(s);
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
procedure TPINGSend.TranslateError;
|
||||
begin
|
||||
if fSock.IP6used then
|
||||
begin
|
||||
case FReplyType of
|
||||
ICMP6_ECHOREPLY:
|
||||
FReplyError := IE_NoError;
|
||||
ICMP6_TIME_EXCEEDED:
|
||||
FReplyError := IE_TTLExceed;
|
||||
ICMP6_UNREACH:
|
||||
case FReplyCode of
|
||||
0:
|
||||
FReplyError := IE_UnreachRoute;
|
||||
3:
|
||||
FReplyError := IE_UnreachAddr;
|
||||
4:
|
||||
FReplyError := IE_UnreachPort;
|
||||
1:
|
||||
FReplyError := IE_UnreachAdmin;
|
||||
else
|
||||
FReplyError := IE_UnreachOther;
|
||||
end;
|
||||
else
|
||||
FReplyError := IE_Other;
|
||||
end;
|
||||
end
|
||||
else
|
||||
begin
|
||||
case FReplyType of
|
||||
ICMP_ECHOREPLY:
|
||||
FReplyError := IE_NoError;
|
||||
ICMP_TIME_EXCEEDED:
|
||||
FReplyError := IE_TTLExceed;
|
||||
ICMP_UNREACH:
|
||||
case FReplyCode of
|
||||
0:
|
||||
FReplyError := IE_UnreachRoute;
|
||||
1:
|
||||
FReplyError := IE_UnreachAddr;
|
||||
3:
|
||||
FReplyError := IE_UnreachPort;
|
||||
13:
|
||||
FReplyError := IE_UnreachAdmin;
|
||||
else
|
||||
FReplyError := IE_UnreachOther;
|
||||
end;
|
||||
else
|
||||
FReplyError := IE_Other;
|
||||
end;
|
||||
end;
|
||||
GenErrorDesc;
|
||||
end;
|
||||
|
||||
procedure TPINGSend.TranslateErrorIpHlp(value: integer);
|
||||
begin
|
||||
case value of
|
||||
11000, 0:
|
||||
FReplyError := IE_NoError;
|
||||
11013:
|
||||
FReplyError := IE_TTLExceed;
|
||||
11002:
|
||||
FReplyError := IE_UnreachRoute;
|
||||
11003:
|
||||
FReplyError := IE_UnreachAddr;
|
||||
11005:
|
||||
FReplyError := IE_UnreachPort;
|
||||
11004:
|
||||
FReplyError := IE_UnreachAdmin;
|
||||
else
|
||||
FReplyError := IE_Other;
|
||||
end;
|
||||
GenErrorDesc;
|
||||
end;
|
||||
|
||||
function TPINGSend.InternalPingIpHlp(const Host: string): Boolean |