From c128b16996e8e32d99c8caf817b9b2d98bfa2366 Mon Sep 17 00:00:00 2001 From: Andreas Schneider Date: Thu, 17 Sep 2015 11:47:04 +0200 Subject: [PATCH] Initial commit --- LICENSE | 674 ++++++ jtemplate/LICENSE | 28 + jtemplate/jtemplate.pas | 496 ++++ restemplate.lpi | 64 + restemplate.lpr | 127 + synapse/asn1util.pas | 510 +++++ synapse/blcksock.pas | 4333 +++++++++++++++++++++++++++++++++++ synapse/clamsend.pas | 277 +++ synapse/dnssend.pas | 603 +++++ synapse/ftpsend.pas | 1964 ++++++++++++++++ synapse/ftptsend.pas | 403 ++++ synapse/httpsend.pas | 845 +++++++ synapse/imapsend.pas | 869 +++++++ synapse/laz_synapse.lpk | 170 ++ synapse/laz_synapse.pas | 24 + synapse/ldapsend.pas | 1208 ++++++++++ synapse/licence.txt | 28 + synapse/mimeinln.pas | 263 +++ synapse/mimemess.pas | 851 +++++++ synapse/mimepart.pas | 1227 ++++++++++ synapse/nntpsend.pas | 483 ++++ synapse/pingsend.pas | 720 ++++++ synapse/pop3send.pas | 483 ++++ synapse/slogsend.pas | 320 +++ synapse/smtpsend.pas | 724 ++++++ synapse/snmpsend.pas | 1266 ++++++++++ synapse/sntpsend.pas | 374 +++ synapse/ssdotnet.inc | 1099 +++++++++ synapse/ssfpc.inc | 909 ++++++++ synapse/ssl_cryptlib.pas | 677 ++++++ synapse/ssl_openssl.pas | 896 ++++++++ synapse/ssl_openssl_lib.pas | 2138 +++++++++++++++++ synapse/ssl_sbb.pas | 697 ++++++ synapse/ssl_streamsec.pas | 539 +++++ synapse/sslinux.inc | 1314 +++++++++++ synapse/sswin32.inc | 1615 +++++++++++++ synapse/synachar.pas | 2035 ++++++++++++++++ synapse/synacode.pas | 1461 ++++++++++++ synapse/synacrypt.pas | 2412 +++++++++++++++++++ synapse/synadbg.pas | 156 ++ synapse/synafpc.pas | 141 ++ synapse/synaicnv.pas | 363 +++ synapse/synaip.pas | 422 ++++ synapse/synamisc.pas | 406 ++++ synapse/synaser.pas | 2339 +++++++++++++++++++ synapse/synautil.pas | 2065 +++++++++++++++++ synapse/synsock.pas | 77 + synapse/tlntsend.pas | 364 +++ 48 files changed, 41459 insertions(+) create mode 100644 LICENSE create mode 100644 jtemplate/LICENSE create mode 100644 jtemplate/jtemplate.pas create mode 100644 restemplate.lpi create mode 100644 restemplate.lpr create mode 100644 synapse/asn1util.pas create mode 100644 synapse/blcksock.pas create mode 100644 synapse/clamsend.pas create mode 100644 synapse/dnssend.pas create mode 100644 synapse/ftpsend.pas create mode 100644 synapse/ftptsend.pas create mode 100644 synapse/httpsend.pas create mode 100644 synapse/imapsend.pas create mode 100644 synapse/laz_synapse.lpk create mode 100644 synapse/laz_synapse.pas create mode 100644 synapse/ldapsend.pas create mode 100644 synapse/licence.txt create mode 100644 synapse/mimeinln.pas create mode 100644 synapse/mimemess.pas create mode 100644 synapse/mimepart.pas create mode 100644 synapse/nntpsend.pas create mode 100644 synapse/pingsend.pas create mode 100644 synapse/pop3send.pas create mode 100644 synapse/slogsend.pas create mode 100644 synapse/smtpsend.pas create mode 100644 synapse/snmpsend.pas create mode 100644 synapse/sntpsend.pas create mode 100644 synapse/ssdotnet.inc create mode 100644 synapse/ssfpc.inc create mode 100644 synapse/ssl_cryptlib.pas create mode 100644 synapse/ssl_openssl.pas create mode 100644 synapse/ssl_openssl_lib.pas create mode 100644 synapse/ssl_sbb.pas create mode 100644 synapse/ssl_streamsec.pas create mode 100644 synapse/sslinux.inc create mode 100644 synapse/sswin32.inc create mode 100644 synapse/synachar.pas create mode 100644 synapse/synacode.pas create mode 100644 synapse/synacrypt.pas create mode 100644 synapse/synadbg.pas create mode 100644 synapse/synafpc.pas create mode 100644 synapse/synaicnv.pas create mode 100644 synapse/synaip.pas create mode 100644 synapse/synamisc.pas create mode 100644 synapse/synaser.pas create mode 100644 synapse/synautil.pas create mode 100644 synapse/synsock.pas create mode 100644 synapse/tlntsend.pas diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..94a9ed0 --- /dev/null +++ b/LICENSE @@ -0,0 +1,674 @@ + GNU GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + 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. + + + Copyright (C) + + 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 . + +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: + + Copyright (C) + 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 +. + + 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 +. diff --git a/jtemplate/LICENSE b/jtemplate/LICENSE new file mode 100644 index 0000000..a59c14f --- /dev/null +++ b/jtemplate/LICENSE @@ -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. \ No newline at end of file diff --git a/jtemplate/jtemplate.pas b/jtemplate/jtemplate.pas new file mode 100644 index 0000000..c5691f8 --- /dev/null +++ b/jtemplate/jtemplate.pas @@ -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. diff --git a/restemplate.lpi b/restemplate.lpi new file mode 100644 index 0000000..0c29171 --- /dev/null +++ b/restemplate.lpi @@ -0,0 +1,64 @@ + + + + + + + + + + + + + <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> diff --git a/restemplate.lpr b/restemplate.lpr new file mode 100644 index 0000000..d789a4c --- /dev/null +++ b/restemplate.lpr @@ -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. + diff --git a/synapse/asn1util.pas b/synapse/asn1util.pas new file mode 100644 index 0000000..e0419c7 --- /dev/null +++ b/synapse/asn1util.pas @@ -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. diff --git a/synapse/blcksock.pas b/synapse/blcksock.pas new file mode 100644 index 0000000..38d300d --- /dev/null +++ b/synapse/blcksock.pas @@ -0,0 +1,4333 @@ +{==============================================================================| +| Project : Ararat Synapse | 009.008.005 | +|==============================================================================| +| Content: Library base | +|==============================================================================| +| 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)1999-2012. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +{ +Special thanks to Gregor Ibic <gregor.ibic@intelicom.si> + (Intelicom d.o.o., http://www.intelicom.si) + for good inspiration about SSL programming. +} + +{$DEFINE ONCEWINSOCK} +{Note about define ONCEWINSOCK: +If you remove this compiler directive, then socket interface is loaded and +initialized on constructor of TBlockSocket class for each socket separately. +Socket interface is used only if your need it. + +If you leave this directive here, then socket interface is loaded and +initialized only once at start of your program! It boost performace on high +count of created and destroyed sockets. It eliminate possible small resource +leak on Windows systems too. +} + +//{$DEFINE RAISEEXCEPT} +{When you enable this define, then is Raiseexcept property is on by default +} + +{:@abstract(Synapse's library core) + +Core with implementation basic socket classes. +} + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$IFDEF VER125} + {$DEFINE BCB} +{$ENDIF} +{$IFDEF BCB} + {$ObjExportAll On} +{$ENDIF} +{$Q-} +{$H+} +{$M+} +{$TYPEDADDRESS OFF} + + +//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 blcksock; + +interface + +uses + SysUtils, Classes, + synafpc, + synsock, synautil, synacode, synaip +{$IFDEF CIL} + ,System.Net + ,System.Net.Sockets + ,System.Text +{$ENDIF} + ; + +const + + SynapseRelease = '38'; + + cLocalhost = '127.0.0.1'; + cAnyHost = '0.0.0.0'; + cBroadcast = '255.255.255.255'; + c6Localhost = '::1'; + c6AnyHost = '::0'; + c6Broadcast = 'ffff::1'; + cAnyPort = '0'; + CR = #$0d; + LF = #$0a; + CRLF = CR + LF; + c64k = 65536; + +type + + {:@abstract(Exception clas used by Synapse) + When you enable generating of exceptions, this exception is raised by + Synapse's units.} + ESynapseError = class(Exception) + private + FErrorCode: Integer; + FErrorMessage: string; + published + {:Code of error. Value depending on used operating system} + property ErrorCode: Integer read FErrorCode Write FErrorCode; + {:Human readable description of error.} + property ErrorMessage: string read FErrorMessage Write FErrorMessage; + end; + + {:Types of OnStatus events} + THookSocketReason = ( + {:Resolving is begin. Resolved IP and port is in parameter in format like: + 'localhost.somewhere.com:25'.} + HR_ResolvingBegin, + {:Resolving is done. Resolved IP and port is in parameter in format like: + 'localhost.somewhere.com:25'. It is always same as in HR_ResolvingBegin!} + HR_ResolvingEnd, + {:Socket created by CreateSocket method. It reporting Family of created + socket too!} + HR_SocketCreate, + {:Socket closed by CloseSocket method.} + HR_SocketClose, + {:Socket binded to IP and Port. Binded IP and Port is in parameter in format + like: 'localhost.somewhere.com:25'.} + HR_Bind, + {:Socket connected to IP and Port. Connected IP and Port is in parameter in + format like: 'localhost.somewhere.com:25'.} + HR_Connect, + {:Called when CanRead method is used with @True result.} + HR_CanRead, + {:Called when CanWrite method is used with @True result.} + HR_CanWrite, + {:Socket is swithed to Listen mode. (TCP socket only)} + HR_Listen, + {:Socket Accepting client connection. (TCP socket only)} + HR_Accept, + {:report count of bytes readed from socket. Number is in parameter string. + If you need is in integer, you must use StrToInt function!} + HR_ReadCount, + {:report count of bytes writed to socket. Number is in parameter string. If + you need is in integer, you must use StrToInt function!} + HR_WriteCount, + {:If is limiting of bandwidth on, then this reason is called when sending or + receiving is stopped for satisfy bandwidth limit. Parameter is count of + waiting milliseconds.} + HR_Wait, + {:report situation where communication error occured. When raiseexcept is + @true, then exception is called after this Hook reason.} + HR_Error + ); + + {:Procedural type for OnStatus event. Sender is calling TBlockSocket object, + Reason is one of set Status events and value is optional data.} + THookSocketStatus = procedure(Sender: TObject; Reason: THookSocketReason; + const Value: String) of object; + + {:This procedural type is used for DataFilter hooks.} + THookDataFilter = procedure(Sender: TObject; var Value: AnsiString) of object; + + {:This procedural type is used for hook OnCreateSocket. By this hook you can + insert your code after initialisation of socket. (you can set special socket + options, etc.)} + THookCreateSocket = procedure(Sender: TObject) of object; + + {:This procedural type is used for monitoring of communication.} + THookMonitor = procedure(Sender: TObject; Writing: Boolean; + const Buffer: TMemory; Len: Integer) of object; + + {:This procedural type is used for hook OnAfterConnect. By this hook you can + insert your code after TCP socket has been sucessfully connected.} + THookAfterConnect = procedure(Sender: TObject) of object; + + {:This procedural type is used for hook OnVerifyCert. By this hook you can + insert your additional certificate verification code. Usefull to verify server + CN against URL. } + + THookVerifyCert = function(Sender: TObject):boolean of object; + + {:This procedural type is used for hook OnHeartbeat. By this hook you can + call your code repeately during long socket operations. + You must enable heartbeats by @Link(HeartbeatRate) property!} + THookHeartbeat = procedure(Sender: TObject) of object; + + {:Specify family of socket.} + TSocketFamily = ( + {:Default mode. Socket family is defined by target address for connection. + It allows instant access to IPv4 and IPv6 nodes. When you need IPv6 address + as destination, then is used IPv6 mode. othervise is used IPv4 mode. + However this mode not working properly with preliminary IPv6 supports!} + SF_Any, + {:Turn this class to pure IPv4 mode. This mode is totally compatible with + previous Synapse releases.} + SF_IP4, + {:Turn to only IPv6 mode.} + SF_IP6 + ); + + {:specify possible values of SOCKS modes.} + TSocksType = ( + ST_Socks5, + ST_Socks4 + ); + + {:Specify requested SSL/TLS version for secure connection.} + TSSLType = ( + LT_all, + LT_SSLv2, + LT_SSLv3, + LT_TLSv1, + LT_TLSv1_1, + LT_SSHv2 + ); + + {:Specify type of socket delayed option.} + TSynaOptionType = ( + SOT_Linger, + SOT_RecvBuff, + SOT_SendBuff, + SOT_NonBlock, + SOT_RecvTimeout, + SOT_SendTimeout, + SOT_Reuse, + SOT_TTL, + SOT_Broadcast, + SOT_MulticastTTL, + SOT_MulticastLoop + ); + + {:@abstract(this object is used for remember delayed socket option set.)} + TSynaOption = class(TObject) + public + Option: TSynaOptionType; + Enabled: Boolean; + Value: Integer; + end; + + TCustomSSL = class; + TSSLClass = class of TCustomSSL; + + {:@abstract(Basic IP object.) + This is parent class for other class with protocol implementations. Do not + use this class directly! Use @link(TICMPBlockSocket), @link(TRAWBlockSocket), + @link(TTCPBlockSocket) or @link(TUDPBlockSocket) instead.} + TBlockSocket = class(TObject) + private + FOnStatus: THookSocketStatus; + FOnReadFilter: THookDataFilter; + FOnCreateSocket: THookCreateSocket; + FOnMonitor: THookMonitor; + FOnHeartbeat: THookHeartbeat; + FLocalSin: TVarSin; + FRemoteSin: TVarSin; + FTag: integer; + FBuffer: AnsiString; + FRaiseExcept: Boolean; + FNonBlockMode: Boolean; + FMaxLineLength: Integer; + FMaxSendBandwidth: Integer; + FNextSend: LongWord; + FMaxRecvBandwidth: Integer; + FNextRecv: LongWord; + FConvertLineEnd: Boolean; + FLastCR: Boolean; + FLastLF: Boolean; + FBinded: Boolean; + FFamily: TSocketFamily; + FFamilySave: TSocketFamily; + FIP6used: Boolean; + FPreferIP4: Boolean; + FDelayedOptions: TList; + FInterPacketTimeout: Boolean; + {$IFNDEF CIL} + FFDSet: TFDSet; + {$ENDIF} + FRecvCounter: Integer; + FSendCounter: Integer; + FSendMaxChunk: Integer; + FStopFlag: Boolean; + FNonblockSendTimeout: Integer; + FHeartbeatRate: integer; + {$IFNDEF ONCEWINSOCK} + FWsaDataOnce: TWSADATA; + {$ENDIF} + function GetSizeRecvBuffer: Integer; + procedure SetSizeRecvBuffer(Size: Integer); + function GetSizeSendBuffer: Integer; + procedure SetSizeSendBuffer(Size: Integer); + procedure SetNonBlockMode(Value: Boolean); + procedure SetTTL(TTL: integer); + function GetTTL:integer; + procedure SetFamily(Value: TSocketFamily); virtual; + procedure SetSocket(Value: TSocket); virtual; + function GetWsaData: TWSAData; + function FamilyToAF(f: TSocketFamily): TAddrFamily; + protected + FSocket: TSocket; + FLastError: Integer; + FLastErrorDesc: string; + FOwner: TObject; + procedure SetDelayedOption(const Value: TSynaOption); + procedure DelayedOption(const Value: TSynaOption); + procedure ProcessDelayedOptions; + procedure InternalCreateSocket(Sin: TVarSin); + procedure SetSin(var Sin: TVarSin; IP, Port: string); + function GetSinIP(Sin: TVarSin): string; + function GetSinPort(Sin: TVarSin): Integer; + procedure DoStatus(Reason: THookSocketReason; const Value: string); + procedure DoReadFilter(Buffer: TMemory; var Len: Integer); + procedure DoMonitor(Writing: Boolean; const Buffer: TMemory; Len: Integer); + procedure DoCreateSocket; + procedure DoHeartbeat; + procedure LimitBandwidth(Length: Integer; MaxB: integer; var Next: LongWord); + procedure SetBandwidth(Value: Integer); + function TestStopFlag: Boolean; + procedure InternalSendStream(const Stream: TStream; WithSize, Indy: boolean); virtual; + function InternalCanRead(Timeout: Integer): Boolean; virtual; + public + constructor Create; + + {:Create object and load all necessary socket library. What library is + loaded is described by STUB parameter. If STUB is empty string, then is + loaded default libraries.} + constructor CreateAlternate(Stub: string); + destructor Destroy; override; + + {:If @link(family) is not SF_Any, then create socket with type defined in + @link(Family) property. If family is SF_Any, then do nothing! (socket is + created automaticly when you know what type of socket you need to create. + (i.e. inside @link(Connect) or @link(Bind) call.) When socket is created, + then is aplyed all stored delayed socket options.} + procedure CreateSocket; + + {:It create socket. Address resolving of Value tells what type of socket is + created. If Value is resolved as IPv4 IP, then is created IPv4 socket. If + value is resolved as IPv6 address, then is created IPv6 socket.} + procedure CreateSocketByName(const Value: String); + + {:Destroy socket in use. This method is also automatically called from + object destructor.} + procedure CloseSocket; virtual; + + {:Abort any work on Socket and destroy them.} + procedure AbortSocket; virtual; + + {:Connects socket to local IP address and PORT. IP address may be numeric or + symbolic ('192.168.74.50', 'cosi.nekde.cz', 'ff08::1'). The same for PORT + - it may be number or mnemonic port ('23', 'telnet'). + + If port value is '0', system chooses itself and conects unused port in the + range 1024 to 4096 (this depending by operating system!). Structure + LocalSin is filled after calling this method. + + Note: If you call this on non-created socket, then socket is created + automaticly. + + Warning: when you call : Bind('0.0.0.0','0'); then is nothing done! In this + case is used implicit system bind instead.} + procedure Bind(IP, Port: string); + + {:Connects socket to remote IP address and PORT. The same rules as with + @link(BIND) method are valid. The only exception is that PORT with 0 value + will not be connected! + + Structures LocalSin and RemoteSin will be filled with valid values. + + When you call this on non-created socket, then socket is created + automaticly. Type of created socket is by @link(Family) property. If is + used SF_IP4, then is created socket for IPv4. If is used SF_IP6, then is + created socket for IPv6. When you have family on SF_Any (default!), then + type of created socket is determined by address resolving of destination + address. (Not work properly on prilimitary winsock IPv6 support!)} + procedure Connect(IP, Port: string); virtual; + + {:Sets socket to receive mode for new incoming connections. It is necessary + to use @link(TBlockSocket.BIND) function call before this method to select + receiving port!} + procedure Listen; virtual; + + {:Waits until new incoming connection comes. After it comes a new socket is + automatically created (socket handler is returned by this function as + result).} + function Accept: TSocket; virtual; + + {:Sends data of LENGTH from BUFFER address via connected socket. System + automatically splits data to packets.} + function SendBuffer(Buffer: Tmemory; Length: Integer): Integer; virtual; + + {:One data BYTE is sent via connected socket.} + procedure SendByte(Data: Byte); virtual; + + {:Send data string via connected socket. Any terminator is not added! If you + need send true string with CR-LF termination, you must add CR-LF characters + to sended string! Because any termination is not added automaticly, you can + use this function for sending any binary data in binary string.} + procedure SendString(Data: AnsiString); virtual; + + {:Send integer as four bytes to socket.} + procedure SendInteger(Data: integer); virtual; + + {:Send data as one block to socket. Each block begin with 4 bytes with + length of data in block. This 4 bytes is added automaticly by this + function.} + procedure SendBlock(const Data: AnsiString); virtual; + + {:Send data from stream to socket.} + procedure SendStreamRaw(const Stream: TStream); virtual; + + {:Send content of stream to socket. It using @link(SendBlock) method} + procedure SendStream(const Stream: TStream); virtual; + + {:Send content of stream to socket. It using @link(SendBlock) method and + this is compatible with streams in Indy library.} + procedure SendStreamIndy(const Stream: TStream); virtual; + + {:Note: This is low-level receive function. You must be sure if data is + waiting for read before call this function for avoid deadlock! + + Waits until allocated buffer is filled by received data. Returns number of + data received, which equals to LENGTH value under normal operation. If it + is not equal the communication channel is possibly broken. + + On stream oriented sockets if is received 0 bytes, it mean 'socket is + closed!" + + On datagram socket is readed first waiting datagram.} + function RecvBuffer(Buffer: TMemory; Length: Integer): Integer; virtual; + + {:Note: This is high-level receive function. It using internal + @link(LineBuffer) and you can combine this function freely with other + high-level functions! + + Method waits until data is received. If no data is received within TIMEOUT + (in milliseconds) period, @link(LastError) is set to WSAETIMEDOUT. Methods + serves for reading any size of data (i.e. one megabyte...). This method is + preffered for reading from stream sockets (like TCP).} + function RecvBufferEx(Buffer: Tmemory; Len: Integer; + Timeout: Integer): Integer; virtual; + + {:Similar to @link(RecvBufferEx), but readed data is stored in binary + string, not in memory buffer.} + function RecvBufferStr(Len: Integer; Timeout: Integer): AnsiString; virtual; + + {:Note: This is high-level receive function. It using internal + @link(LineBuffer) and you can combine this function freely with other + high-level functions. + + Waits until one data byte is received which is also returned as function + result. If no data is received within TIMEOUT (in milliseconds)period, + @link(LastError) is set to WSAETIMEDOUT and result have value 0.} + function RecvByte(Timeout: Integer): Byte; virtual; + + {:Note: This is high-level receive function. It using internal + @link(LineBuffer) and you can combine this function freely with other + high-level functions. + + Waits until one four bytes are received and return it as one Ineger Value. + If no data is received within TIMEOUT (in milliseconds)period, + @link(LastError) is set to WSAETIMEDOUT and result have value 0.} + function RecvInteger(Timeout: Integer): Integer; virtual; + + {:Note: This is high-level receive function. It using internal + @link(LineBuffer) and you can combine this function freely with other + high-level functions. + + Method waits until data string is received. This string is terminated by + CR-LF characters. The resulting string is returned without this termination + (CR-LF)! If @link(ConvertLineEnd) is used, then CR-LF sequence may not be + exactly CR-LF. See @link(ConvertLineEnd) description. If no data is + received within TIMEOUT (in milliseconds) period, @link(LastError) is set + to WSAETIMEDOUT. You may also specify maximum length of reading data by + @link(MaxLineLength) property.} + function RecvString(Timeout: Integer): AnsiString; virtual; + + {:Note: This is high-level receive function. It using internal + @link(LineBuffer) and you can combine this function freely with other + high-level functions. + + Method waits until data string is received. This string is terminated by + Terminator string. The resulting string is returned without this + termination. If no data is received within TIMEOUT (in milliseconds) + period, @link(LastError) is set to WSAETIMEDOUT. You may also specify + maximum length of reading data by @link(MaxLineLength) property.} + function RecvTerminated(Timeout: Integer; const Terminator: AnsiString): AnsiString; virtual; + + {:Note: This is high-level receive function. It using internal + @link(LineBuffer) and you can combine this function freely with other + high-level functions. + + Method reads all data waiting for read. If no data is received within + TIMEOUT (in milliseconds) period, @link(LastError) is set to WSAETIMEDOUT. + Methods serves for reading unknown size of data. Because before call this + function you don't know size of received data, returned data is stored in + dynamic size binary string. This method is preffered for reading from + stream sockets (like TCP). It is very goot for receiving datagrams too! + (UDP protocol)} + function RecvPacket(Timeout: Integer): AnsiString; virtual; + + {:Read one block of data from socket. Each block begin with 4 bytes with + length of data in block. This function read first 4 bytes for get lenght, + then it wait for reported count of bytes.} + function RecvBlock(Timeout: Integer): AnsiString; virtual; + + {:Read all data from socket to stream until socket is closed (or any error + occured.)} + procedure RecvStreamRaw(const Stream: TStream; Timeout: Integer); virtual; + {:Read requested count of bytes from socket to stream.} + procedure RecvStreamSize(const Stream: TStream; Timeout: Integer; Size: Integer); + + {:Receive data to stream. It using @link(RecvBlock) method.} + procedure RecvStream(const Stream: TStream; Timeout: Integer); virtual; + + {:Receive data to stream. This function is compatible with similar function + in Indy library. It using @link(RecvBlock) method.} + procedure RecvStreamIndy(const Stream: TStream; Timeout: Integer); virtual; + + {:Same as @link(RecvBuffer), but readed data stays in system input buffer. + Warning: this function not respect data in @link(LineBuffer)! Is not + recommended to use this function!} + function PeekBuffer(Buffer: TMemory; Length: Integer): Integer; virtual; + + {:Same as @link(RecvByte), but readed data stays in input system buffer. + Warning: this function not respect data in @link(LineBuffer)! Is not + recommended to use this function!} + function PeekByte(Timeout: Integer): Byte; virtual; + + {:On stream sockets it returns number of received bytes waiting for picking. + 0 is returned when there is no such data. On datagram socket it returns + length of the first waiting datagram. Returns 0 if no datagram is waiting.} + function WaitingData: Integer; virtual; + + {:Same as @link(WaitingData), but if exists some of data in @link(Linebuffer), + return their length instead.} + function WaitingDataEx: Integer; + + {:Clear all waiting data for read from buffers.} + procedure Purge; + + {:Sets linger. Enabled linger means that the system waits another LINGER + (in milliseconds) time for delivery of sent data. This function is only for + stream type of socket! (TCP)} + procedure SetLinger(Enable: Boolean; Linger: Integer); + + {:Actualize values in @link(LocalSin).} + procedure GetSinLocal; + + {:Actualize values in @link(RemoteSin).} + procedure GetSinRemote; + + {:Actualize values in @link(LocalSin) and @link(RemoteSin).} + procedure GetSins; + + {:Reset @link(LastError) and @link(LastErrorDesc) to non-error state.} + procedure ResetLastError; + + {:If you "manually" call Socket API functions, forward their return code as + parameter to this function, which evaluates it, eventually calls + GetLastError and found error code returns and stores to @link(LastError).} + function SockCheck(SockResult: Integer): Integer; virtual; + + {:If @link(LastError) contains some error code and @link(RaiseExcept) + property is @true, raise adequate exception.} + procedure ExceptCheck; + + {:Returns local computer name as numerical or symbolic value. It try get + fully qualified domain name. Name is returned in the format acceptable by + functions demanding IP as input parameter.} + function LocalName: string; + + {:Try resolve name to all possible IP address. i.e. If you pass as name + result of @link(LocalName) method, you get all IP addresses used by local + system.} + procedure ResolveNameToIP(Name: string; const IPList: TStrings); + + {:Try resolve name to primary IP address. i.e. If you pass as name result of + @link(LocalName) method, you get primary IP addresses used by local system.} + function ResolveName(Name: string): string; + + {:Try resolve IP to their primary domain name. If IP not have domain name, + then is returned original IP.} + function ResolveIPToName(IP: string): string; + + {:Try resolve symbolic port name to port number. (i.e. 'Echo' to 8)} + function ResolvePort(Port: string): Word; + + {:Set information about remote side socket. It is good for seting remote + side for sending UDP packet, etc.} + procedure SetRemoteSin(IP, Port: string); + + {:Picks IP socket address from @link(LocalSin).} + function GetLocalSinIP: string; virtual; + + {:Picks IP socket address from @link(RemoteSin).} + function GetRemoteSinIP: string; virtual; + + {:Picks socket PORT number from @link(LocalSin).} + function GetLocalSinPort: Integer; virtual; + + {:Picks socket PORT number from @link(RemoteSin).} + function GetRemoteSinPort: Integer; virtual; + + {:Return @TRUE, if you can read any data from socket or is incoming + connection on TCP based socket. Status is tested for time Timeout (in + milliseconds). If value in Timeout is 0, status is only tested and + continue. If value in Timeout is -1, run is breaked and waiting for read + data maybe forever. + + This function is need only on special cases, when you need use + @link(RecvBuffer) function directly! read functioms what have timeout as + calling parameter, calling this function internally.} + function CanRead(Timeout: Integer): Boolean; virtual; + + {:Same as @link(CanRead), but additionally return @TRUE if is some data in + @link(LineBuffer).} + function CanReadEx(Timeout: Integer): Boolean; virtual; + + {:Return @TRUE, if you can to socket write any data (not full sending + buffer). Status is tested for time Timeout (in milliseconds). If value in + Timeout is 0, status is only tested and continue. If value in Timeout is + -1, run is breaked and waiting for write data maybe forever. + + This function is need only on special cases!} + function CanWrite(Timeout: Integer): Boolean; virtual; + + {:Same as @link(SendBuffer), but send datagram to address from + @link(RemoteSin). Usefull for sending reply to datagram received by + function @link(RecvBufferFrom).} + function SendBufferTo(Buffer: TMemory; Length: Integer): Integer; virtual; + + {:Note: This is low-lever receive function. You must be sure if data is + waiting for read before call this function for avoid deadlock! + + Receives first waiting datagram to allocated buffer. If there is no waiting + one, then waits until one comes. Returns length of datagram stored in + BUFFER. If length exceeds buffer datagram is truncated. After this + @link(RemoteSin) structure contains information about sender of UDP packet.} + function RecvBufferFrom(Buffer: TMemory; Length: Integer): Integer; virtual; +{$IFNDEF CIL} + {:This function is for check for incoming data on set of sockets. Whitch + sockets is checked is decribed by SocketList Tlist with TBlockSocket + objects. TList may have maximal number of objects defined by FD_SETSIZE + constant. Return @TRUE, if you can from some socket read any data or is + incoming connection on TCP based socket. Status is tested for time Timeout + (in milliseconds). If value in Timeout is 0, status is only tested and + continue. If value in Timeout is -1, run is breaked and waiting for read + data maybe forever. If is returned @TRUE, CanReadList TList is filled by all + TBlockSocket objects what waiting for read.} + function GroupCanRead(const SocketList: TList; Timeout: Integer; + const CanReadList: TList): Boolean; +{$ENDIF} + {:By this method you may turn address reuse mode for local @link(bind). It + is good specially for UDP protocol. Using this with TCP protocol is + hazardous!} + procedure EnableReuse(Value: Boolean); + + {:Try set timeout for all sending and receiving operations, if socket + provider can do it. (It not supported by all socket providers!)} + procedure SetTimeout(Timeout: Integer); + + {:Try set timeout for all sending operations, if socket provider can do it. + (It not supported by all socket providers!)} + procedure SetSendTimeout(Timeout: Integer); + + {:Try set timeout for all receiving operations, if socket provider can do + it. (It not supported by all socket providers!)} + procedure SetRecvTimeout(Timeout: Integer); + + {:Return value of socket type.} + function GetSocketType: integer; Virtual; + + {:Return value of protocol type for socket creation.} + function GetSocketProtocol: integer; Virtual; + + {:WSA structure with information about socket provider. On non-windows + platforms this structure is simulated!} + property WSAData: TWSADATA read GetWsaData; + + {:FDset structure prepared for usage with this socket.} + property FDset: TFDSet read FFDset; + + {:Structure describing local socket side.} + property LocalSin: TVarSin read FLocalSin write FLocalSin; + + {:Structure describing remote socket side.} + property RemoteSin: TVarSin read FRemoteSin write FRemoteSin; + + {:Socket handler. Suitable for "manual" calls to socket API or manual + connection of socket to a previously created socket (i.e by Accept method + on TCP socket)} + property Socket: TSocket read FSocket write SetSocket; + + {:Last socket operation error code. Error codes are described in socket + documentation. Human readable error description is stored in + @link(LastErrorDesc) property.} + property LastError: Integer read FLastError; + + {:Human readable error description of @link(LastError) code.} + property LastErrorDesc: string read FLastErrorDesc; + + {:Buffer used by all high-level receiving functions. This buffer is used for + optimized reading of data from socket. In normal cases you not need access + to this buffer directly!} + property LineBuffer: AnsiString read FBuffer write FBuffer; + + {:Size of Winsock receive buffer. If it is not supported by socket provider, + it return as size one kilobyte.} + property SizeRecvBuffer: Integer read GetSizeRecvBuffer write SetSizeRecvBuffer; + + {:Size of Winsock send buffer. If it is not supported by socket provider, it + return as size one kilobyte.} + property SizeSendBuffer: Integer read GetSizeSendBuffer write SetSizeSendBuffer; + + {:If @True, turn class to non-blocking mode. Not all functions are working + properly in this mode, you must know exactly what you are doing! However + when you have big experience with non-blocking programming, then you can + optimise your program by non-block mode!} + property NonBlockMode: Boolean read FNonBlockMode Write SetNonBlockMode; + + {:Set Time-to-live value. (if system supporting it!)} + property TTL: Integer read GetTTL Write SetTTL; + + {:If is @true, then class in in IPv6 mode.} + property IP6used: Boolean read FIP6used; + + {:Return count of received bytes on this socket from begin of current + connection.} + property RecvCounter: Integer read FRecvCounter; + + {:Return count of sended bytes on this socket from begin of current + connection.} + property SendCounter: Integer read FSendCounter; + published + {:Return descriptive string for given error code. This is class function. + You may call it without created object!} + class function GetErrorDesc(ErrorCode: Integer): string; + + {:Return descriptive string for @link(LastError).} + function GetErrorDescEx: string; virtual; + + {:this value is for free use.} + property Tag: Integer read FTag write FTag; + + {:If @true, winsock errors raises exception. Otherwise is setted + @link(LastError) value only and you must check it from your program! Default + value is @false.} + property RaiseExcept: Boolean read FRaiseExcept write FRaiseExcept; + + {:Define maximum length in bytes of @link(LineBuffer) for high-level + receiving functions. If this functions try to read more data then this + limit, error is returned! If value is 0 (default), no limitation is used. + This is very good protection for stupid attacks to your server by sending + lot of data without proper terminator... until all your memory is allocated + by LineBuffer! + + Note: This maximum length is checked only in functions, what read unknown + number of bytes! (like @link(RecvString) or @link(RecvTerminated))} + property MaxLineLength: Integer read FMaxLineLength Write FMaxLineLength; + + {:Define maximal bandwidth for all sending operations in bytes per second. + If value is 0 (default), bandwidth limitation is not used.} + property MaxSendBandwidth: Integer read FMaxSendBandwidth Write FMaxSendBandwidth; + + {:Define maximal bandwidth for all receiving operations in bytes per second. + If value is 0 (default), bandwidth limitation is not used.} + property MaxRecvBandwidth: Integer read FMaxRecvBandwidth Write FMaxRecvBandwidth; + + {:Define maximal bandwidth for all sending and receiving operations in bytes + per second. If value is 0 (default), bandwidth limitation is not used.} + property MaxBandwidth: Integer Write SetBandwidth; + + {:Do a conversion of non-standard line terminators to CRLF. (Off by default) + If @True, then terminators like sigle CR, single LF or LFCR are converted + to CRLF internally. This have effect only in @link(RecvString) method!} + property ConvertLineEnd: Boolean read FConvertLineEnd Write FConvertLineEnd; + + {:Specified Family of this socket. When you are using Windows preliminary + support for IPv6, then I recommend to set this property!} + property Family: TSocketFamily read FFamily Write SetFamily; + + {:When resolving of domain name return both IPv4 and IPv6 addresses, then + specify if is used IPv4 (dafault - @true) or IPv6.} + property PreferIP4: Boolean read FPreferIP4 Write FPreferIP4; + + {:By default (@true) is all timeouts used as timeout between two packets in + reading operations. If you set this to @false, then Timeouts is for overall + reading operation!} + property InterPacketTimeout: Boolean read FInterPacketTimeout Write FInterPacketTimeout; + + {:All sended datas was splitted by this value.} + property SendMaxChunk: Integer read FSendMaxChunk Write FSendMaxChunk; + + {:By setting this property to @true you can stop any communication. You can + use this property for soft abort of communication.} + property StopFlag: Boolean read FStopFlag Write FStopFlag; + + {:Timeout for data sending by non-blocking socket mode.} + property NonblockSendTimeout: Integer read FNonblockSendTimeout Write FNonblockSendTimeout; + + {:This event is called by various reasons. It is good for monitoring socket, + create gauges for data transfers, etc.} + property OnStatus: THookSocketStatus read FOnStatus write FOnStatus; + + {:this event is good for some internal thinks about filtering readed datas. + It is used by telnet client by example.} + property OnReadFilter: THookDataFilter read FOnReadFilter write FOnReadFilter; + + {:This event is called after real socket creation for setting special socket + options, because you not know when socket is created. (it is depended on + Ipv4, IPv6 or automatic mode)} + property OnCreateSocket: THookCreateSocket read FOnCreateSocket write FOnCreateSocket; + + {:This event is good for monitoring content of readed or writed datas.} + property OnMonitor: THookMonitor read FOnMonitor write FOnMonitor; + + {:This event is good for calling your code during long socket operations. + (Example, for refresing UI if class in not called within the thread.) + Rate of heartbeats can be modified by @link(HeartbeatRate) property.} + property OnHeartbeat: THookHeartbeat read FOnHeartbeat write FOnHeartbeat; + + {:Specify typical rate of @link(OnHeartbeat) event and @link(StopFlag) testing. + Default value 0 disabling heartbeats! Value is in milliseconds. + Real rate can be higher or smaller then this value, because it depending + on real socket operations too! + Note: Each heartbeat slowing socket processing.} + property HeartbeatRate: integer read FHeartbeatRate Write FHeartbeatRate; + {:What class own this socket? Used by protocol implementation classes.} + property Owner: TObject read FOwner Write FOwner; + end; + + {:@abstract(Support for SOCKS4 and SOCKS5 proxy) + Layer with definition all necessary properties and functions for + implementation SOCKS proxy client. Do not use this class directly.} + TSocksBlockSocket = class(TBlockSocket) + protected + FSocksIP: string; + FSocksPort: string; + FSocksTimeout: integer; + FSocksUsername: string; + FSocksPassword: string; + FUsingSocks: Boolean; + FSocksResolver: Boolean; + FSocksLastError: integer; + FSocksResponseIP: string; + FSocksResponsePort: string; + FSocksLocalIP: string; + FSocksLocalPort: string; + FSocksRemoteIP: string; + FSocksRemotePort: string; + FBypassFlag: Boolean; + FSocksType: TSocksType; + function SocksCode(IP, Port: string): Ansistring; + function SocksDecode(Value: Ansistring): integer; + public + constructor Create; + + {:Open connection to SOCKS proxy and if @link(SocksUsername) is set, do + authorisation to proxy. This is needed only in special cases! (it is called + internally!)} + function SocksOpen: Boolean; + + {:Send specified request to SOCKS proxy. This is needed only in special + cases! (it is called internally!)} + function SocksRequest(Cmd: Byte; const IP, Port: string): Boolean; + + {:Receive response to previosly sended request. This is needed only in + special cases! (it is called internally!)} + function SocksResponse: Boolean; + + {:Is @True when class is using SOCKS proxy.} + property UsingSocks: Boolean read FUsingSocks; + + {:If SOCKS proxy failed, here is error code returned from SOCKS proxy.} + property SocksLastError: integer read FSocksLastError; + published + {:Address of SOCKS server. If value is empty string, SOCKS support is + disabled. Assingning any value to this property enable SOCKS mode. + Warning: You cannot combine this mode with HTTP-tunneling mode!} + property SocksIP: string read FSocksIP write FSocksIP; + + {:Port of SOCKS server. Default value is '1080'.} + property SocksPort: string read FSocksPort write FSocksPort; + + {:If you need authorisation on SOCKS server, set username here.} + property SocksUsername: string read FSocksUsername write FSocksUsername; + + {:If you need authorisation on SOCKS server, set password here.} + property SocksPassword: string read FSocksPassword write FSocksPassword; + + {:Specify timeout for communicatin with SOCKS server. Default is one minute.} + property SocksTimeout: integer read FSocksTimeout write FSocksTimeout; + + {:If @True, all symbolic names of target hosts is not translated to IP's + locally, but resolving is by SOCKS proxy. Default is @True.} + property SocksResolver: Boolean read FSocksResolver write FSocksResolver; + + {:Specify SOCKS type. By default is used SOCKS5, but you can use SOCKS4 too. + When you select SOCKS4, then if @link(SOCKSResolver) is enabled, then is + used SOCKS4a. Othervise is used pure SOCKS4.} + property SocksType: TSocksType read FSocksType write FSocksType; + end; + + {:@abstract(Implementation of TCP socket.) + Supported features: IPv4, IPv6, SSL/TLS or SSH (depending on used plugin), + SOCKS5 proxy (outgoing connections and limited incomming), SOCKS4/4a proxy + (outgoing connections and limited incomming), TCP through HTTP proxy tunnel.} + TTCPBlockSocket = class(TSocksBlockSocket) + protected + FOnAfterConnect: THookAfterConnect; + FSSL: TCustomSSL; + FHTTPTunnelIP: string; + FHTTPTunnelPort: string; + FHTTPTunnel: Boolean; + FHTTPTunnelRemoteIP: string; + FHTTPTunnelRemotePort: string; + FHTTPTunnelUser: string; + FHTTPTunnelPass: string; + FHTTPTunnelTimeout: integer; + procedure SocksDoConnect(IP, Port: string); + procedure HTTPTunnelDoConnect(IP, Port: string); + procedure DoAfterConnect; + public + {:Create TCP socket class with default plugin for SSL/TSL/SSH implementation + (see @link(SSLImplementation))} + constructor Create; + + {:Create TCP socket class with desired plugin for SSL/TSL/SSH implementation} + constructor CreateWithSSL(SSLPlugin: TSSLClass); + destructor Destroy; override; + + {:See @link(TBlockSocket.CloseSocket)} + procedure CloseSocket; override; + + {:See @link(TBlockSocket.WaitingData)} + function WaitingData: Integer; override; + + {:Sets socket to receive mode for new incoming connections. It is necessary + to use @link(TBlockSocket.BIND) function call before this method to select + receiving port! + + If you use SOCKS, activate incoming TCP connection by this proxy. (By BIND + method of SOCKS.)} + procedure Listen; override; + + {:Waits until new incoming connection comes. After it comes a new socket is + automatically created (socket handler is returned by this function as + result). + + If you use SOCKS, new socket is not created! In this case is used same + socket as socket for listening! So, you can accept only one connection in + SOCKS mode.} + function Accept: TSocket; override; + + {:Connects socket to remote IP address and PORT. The same rules as with + @link(TBlockSocket.BIND) method are valid. The only exception is that PORT + with 0 value will not be connected. After call to this method + a communication channel between local and remote socket is created. Local + socket is assigned automatically if not controlled by previous call to + @link(TBlockSocket.BIND) method. Structures @link(TBlockSocket.LocalSin) + and @link(TBlockSocket.RemoteSin) will be filled with valid values. + + If you use SOCKS, activate outgoing TCP connection by SOCKS proxy specified + in @link(TSocksBlockSocket.SocksIP). (By CONNECT method of SOCKS.) + + If you use HTTP-tunnel mode, activate outgoing TCP connection by HTTP + tunnel specified in @link(HTTPTunnelIP). (By CONNECT method of HTTP + protocol.) + + Note: If you call this on non-created socket, then socket is created + automaticly.} + procedure Connect(IP, Port: string); override; + + {:If you need upgrade existing TCP connection to SSL/TLS (or SSH2, if plugin + allows it) mode, then call this method. This method switch this class to + SSL mode and do SSL/TSL handshake.} + procedure SSLDoConnect; + + {:By this method you can downgrade existing SSL/TLS connection to normal TCP + connection.} + procedure SSLDoShutdown; + + {:If you need use this component as SSL/TLS TCP server, then after accepting + of inbound connection you need start SSL/TLS session by this method. Before + call this function, you must have assigned all neeeded certificates and + keys!} + function SSLAcceptConnection: Boolean; + + {:See @link(TBlockSocket.GetLocalSinIP)} + function GetLocalSinIP: string; override; + + {:See @link(TBlockSocket.GetRemoteSinIP)} + function GetRemoteSinIP: string; override; + + {:See @link(TBlockSocket.GetLocalSinPort)} + function GetLocalSinPort: Integer; override; + + {:See @link(TBlockSocket.GetRemoteSinPort)} + function GetRemoteSinPort: Integer; override; + + {:See @link(TBlockSocket.SendBuffer)} + function SendBuffer(Buffer: TMemory; Length: Integer): Integer; override; + + {:See @link(TBlockSocket.RecvBuffer)} + function RecvBuffer(Buffer: TMemory; Len: Integer): Integer; override; + + {:Return value of socket type. For TCP return SOCK_STREAM.} + function GetSocketType: integer; override; + + {:Return value of protocol type for socket creation. For TCP return + IPPROTO_TCP.} + function GetSocketProtocol: integer; override; + + {:Class implementing SSL/TLS support. It is allways some descendant + of @link(TCustomSSL) class. When programmer not select some SSL plugin + class, then is used @link(TSSLNone)} + property SSL: TCustomSSL read FSSL; + + {:@True if is used HTTP tunnel mode.} + property HTTPTunnel: Boolean read FHTTPTunnel; + published + {:Return descriptive string for @link(LastError). On case of error + in SSL/TLS subsystem, it returns right error description.} + function GetErrorDescEx: string; override; + + {:Specify IP address of HTTP proxy. Assingning non-empty value to this + property enable HTTP-tunnel mode. This mode is for tunnelling any outgoing + TCP connection through HTTP proxy server. (If policy on HTTP proxy server + allow this!) Warning: You cannot combine this mode with SOCK5 mode!} + property HTTPTunnelIP: string read FHTTPTunnelIP Write FHTTPTunnelIP; + + {:Specify port of HTTP proxy for HTTP-tunneling.} + property HTTPTunnelPort: string read FHTTPTunnelPort Write FHTTPTunnelPort; + + {:Specify authorisation username for access to HTTP proxy in HTTP-tunnel + mode. If you not need authorisation, then let this property empty.} + property HTTPTunnelUser: string read FHTTPTunnelUser Write FHTTPTunnelUser; + + {:Specify authorisation password for access to HTTP proxy in HTTP-tunnel + mode.} + property HTTPTunnelPass: string read FHTTPTunnelPass Write FHTTPTunnelPass; + + {:Specify timeout for communication with HTTP proxy in HTTPtunnel mode.} + property HTTPTunnelTimeout: integer read FHTTPTunnelTimeout Write FHTTPTunnelTimeout; + + {:This event is called after sucessful TCP socket connection.} + property OnAfterConnect: THookAfterConnect read FOnAfterConnect write FOnAfterConnect; + end; + + {:@abstract(Datagram based communication) + This class implementing datagram based communication instead default stream + based communication style.} + TDgramBlockSocket = class(TSocksBlockSocket) + public + {:Fill @link(TBlockSocket.RemoteSin) structure. This address is used for + sending data.} + procedure Connect(IP, Port: string); override; + + {:Silently redirected to @link(TBlockSocket.SendBufferTo).} + function SendBuffer(Buffer: TMemory; Length: Integer): Integer; override; + + {:Silently redirected to @link(TBlockSocket.RecvBufferFrom).} + function RecvBuffer(Buffer: TMemory; Length: Integer): Integer; override; + end; + + {:@abstract(Implementation of UDP socket.) + NOTE: in this class is all receiving redirected to RecvBufferFrom. You can + use for reading any receive function. Preffered is RecvPacket! Similary all + sending is redirected to SendbufferTo. You can use for sending UDP packet any + sending function, like SendString. + + Supported features: IPv4, IPv6, unicasts, broadcasts, multicasts, SOCKS5 + proxy (only unicasts! Outgoing and incomming.)} + TUDPBlockSocket = class(TDgramBlockSocket) + protected + FSocksControlSock: TTCPBlockSocket; + function UdpAssociation: Boolean; + procedure SetMulticastTTL(TTL: integer); + function GetMulticastTTL:integer; + public + destructor Destroy; override; + + {:Enable or disable sending of broadcasts. If seting OK, result is @true. + This method is not supported in SOCKS5 mode! IPv6 does not support + broadcasts! In this case you must use Multicasts instead.} + procedure EnableBroadcast(Value: Boolean); + + {:See @link(TBlockSocket.SendBufferTo)} + function SendBufferTo(Buffer: TMemory; Length: Integer): Integer; override; + + {:See @link(TBlockSocket.RecvBufferFrom)} + function RecvBufferFrom(Buffer: TMemory; Length: Integer): Integer; override; +{$IFNDEF CIL} + {:Add this socket to given multicast group. You cannot use Multicasts in + SOCKS mode!} + procedure AddMulticast(MCastIP:string); + + {:Remove this socket from given multicast group.} + procedure DropMulticast(MCastIP:string); +{$ENDIF} + {:All sended multicast datagrams is loopbacked to your interface too. (you + can read your sended datas.) You can disable this feature by this function. + This function not working on some Windows systems!} + procedure EnableMulticastLoop(Value: Boolean); + + {:Return value of socket type. For UDP return SOCK_DGRAM.} + function GetSocketType: integer; override; + + {:Return value of protocol type for socket creation. For UDP return + IPPROTO_UDP.} + function GetSocketProtocol: integer; override; + + {:Set Time-to-live value for multicasts packets. It define number of routers + for transfer of datas. If you set this to 1 (dafault system value), then + multicasts packet goes only to you local network. If you need transport + multicast packet to worldwide, then increase this value, but be carefull, + lot of routers on internet does not transport multicasts packets!} + property MulticastTTL: Integer read GetMulticastTTL Write SetMulticastTTL; + end; + + {:@abstract(Implementation of RAW ICMP socket.) + For this object you must have rights for creating RAW sockets!} + TICMPBlockSocket = class(TDgramBlockSocket) + public + {:Return value of socket type. For RAW and ICMP return SOCK_RAW.} + function GetSocketType: integer; override; + + {:Return value of protocol type for socket creation. For ICMP returns + IPPROTO_ICMP or IPPROTO_ICMPV6} + function GetSocketProtocol: integer; override; + end; + + {:@abstract(Implementation of RAW socket.) + For this object you must have rights for creating RAW sockets!} + TRAWBlockSocket = class(TBlockSocket) + public + {:Return value of socket type. For RAW and ICMP return SOCK_RAW.} + function GetSocketType: integer; override; + + {:Return value of protocol type for socket creation. For RAW returns + IPPROTO_RAW.} + function GetSocketProtocol: integer; override; + end; + + {:@abstract(Implementation of PGM-message socket.) + Not all systems supports this protocol!} + TPGMMessageBlockSocket = class(TBlockSocket) + public + {:Return value of socket type. For PGM-message return SOCK_RDM.} + function GetSocketType: integer; override; + + {:Return value of protocol type for socket creation. For PGM-message returns + IPPROTO_RM.} + function GetSocketProtocol: integer; override; + end; + + {:@abstract(Implementation of PGM-stream socket.) + Not all systems supports this protocol!} + TPGMStreamBlockSocket = class(TBlockSocket) + public + {:Return value of socket type. For PGM-stream return SOCK_STREAM.} + function GetSocketType: integer; override; + + {:Return value of protocol type for socket creation. For PGM-stream returns + IPPROTO_RM.} + function GetSocketProtocol: integer; override; + end; + + {:@abstract(Parent class for all SSL plugins.) + This is abstract class defining interface for other SSL plugins. + + Instance of this class will be created for each @link(TTCPBlockSocket). + + Warning: not all methods and propertis can work in all existing SSL plugins! + Please, read documentation of used SSL plugin.} + TCustomSSL = class(TObject) + private + protected + FOnVerifyCert: THookVerifyCert; + FSocket: TTCPBlockSocket; + FSSLEnabled: Boolean; + FLastError: integer; + FLastErrorDesc: string; + FSSLType: TSSLType; + FKeyPassword: string; + FCiphers: string; + FCertificateFile: string; + FPrivateKeyFile: string; + FCertificate: Ansistring; + FPrivateKey: Ansistring; + FPFX: Ansistring; + FPFXfile: string; + FCertCA: Ansistring; + FCertCAFile: string; + FTrustCertificate: Ansistring; + FTrustCertificateFile: string; + FVerifyCert: Boolean; + FUsername: string; + FPassword: string; + FSSHChannelType: string; + FSSHChannelArg1: string; + FSSHChannelArg2: string; + FCertComplianceLevel: integer; + FSNIHost: string; + procedure ReturnError; + procedure SetCertCAFile(const Value: string); virtual; + function DoVerifyCert:boolean; + function CreateSelfSignedCert(Host: string): Boolean; virtual; + public + {: Create plugin class. it is called internally from @link(TTCPBlockSocket)} + constructor Create(const Value: TTCPBlockSocket); virtual; + + {: Assign settings (certificates and configuration) from another SSL plugin + class.} + procedure Assign(const Value: TCustomSSL); virtual; + + {: return description of used plugin. It usually return name and version + of used SSL library.} + function LibVersion: String; virtual; + + {: return name of used plugin.} + function LibName: String; virtual; + + {: Do not call this directly. It is used internally by @link(TTCPBlockSocket)! + + Here is needed code for start SSL connection.} + function Connect: boolean; virtual; + + {: Do not call this directly. It is used internally by @link(TTCPBlockSocket)! + + Here is needed code for acept new SSL connection.} + function Accept: boolean; virtual; + + {: Do not call this directly. It is used internally by @link(TTCPBlockSocket)! + + Here is needed code for hard shutdown of SSL connection. (for example, + before socket is closed)} + function Shutdown: boolean; virtual; + + {: Do not call this directly. It is used internally by @link(TTCPBlockSocket)! + + Here is needed code for soft shutdown of SSL connection. (for example, + when you need to continue with unprotected connection.)} + function BiShutdown: boolean; virtual; + + {: Do not call this directly. It is used internally by @link(TTCPBlockSocket)! + + Here is needed code for sending some datas by SSL connection.} + function SendBuffer(Buffer: TMemory; Len: Integer): Integer; virtual; + + {: Do not call this directly. It is used internally by @link(TTCPBlockSocket)! + + Here is needed code for receiving some datas by SSL connection.} + function RecvBuffer(Buffer: TMemory; Len: Integer): Integer; virtual; + + {: Do not call this directly. It is used internally by @link(TTCPBlockSocket)! + + Here is needed code for getting count of datas what waiting for read. + If SSL plugin not allows this, then it should return 0.} + function WaitingData: Integer; virtual; + + {:Return string with identificator of SSL/TLS version of existing + connection.} + function GetSSLVersion: string; virtual; + + {:Return subject of remote SSL peer.} + function GetPeerSubject: string; virtual; + + {:Return Serial number if remote X509 certificate.} + function GetPeerSerialNo: integer; virtual; + + {:Return issuer certificate of remote SSL peer.} + function GetPeerIssuer: string; virtual; + + {:Return peer name from remote side certificate. This is good for verify, + if certificate is generated for remote side IP name.} + function GetPeerName: string; virtual; + + {:Returns has of peer name from remote side certificate. This is good + for fast remote side authentication.} + function GetPeerNameHash: cardinal; virtual; + + {:Return fingerprint of remote SSL peer.} + function GetPeerFingerprint: string; virtual; + + {:Return all detailed information about certificate from remote side of + SSL/TLS connection. Result string can be multilined! Each plugin can return + this informations in different format!} + function GetCertInfo: string; virtual; + + {:Return currently used Cipher.} + function GetCipherName: string; virtual; + + {:Return currently used number of bits in current Cipher algorythm.} + function GetCipherBits: integer; virtual; + + {:Return number of bits in current Cipher algorythm.} + function GetCipherAlgBits: integer; virtual; + + {:Return result value of verify remote side certificate. Look to OpenSSL + documentation for possible values. For example 0 is successfuly verified + certificate, or 18 is self-signed certificate.} + function GetVerifyCert: integer; virtual; + + {: Resurn @true if SSL mode is enabled on existing cvonnection.} + property SSLEnabled: Boolean read FSSLEnabled; + + {:Return error code of last SSL operation. 0 is OK.} + property LastError: integer read FLastError; + + {:Return error description of last SSL operation.} + property LastErrorDesc: string read FLastErrorDesc; + published + {:Here you can specify requested SSL/TLS mode. Default is autodetection, but + on some servers autodetection not working properly. In this case you must + specify requested SSL/TLS mode by your hand!} + property SSLType: TSSLType read FSSLType write FSSLType; + + {:Password for decrypting of encoded certificate or key.} + property KeyPassword: string read FKeyPassword write FKeyPassword; + + {:Username for possible credentials.} + property Username: string read FUsername write FUsername; + + {:password for possible credentials.} + property Password: string read FPassword write FPassword; + + {:By this property you can modify default set of SSL/TLS ciphers.} + property Ciphers: string read FCiphers write FCiphers; + + {:Used for loading certificate from disk file. See to plugin documentation + if this method is supported and how!} + property CertificateFile: string read FCertificateFile write FCertificateFile; + + {:Used for loading private key from disk file. See to plugin documentation + if this method is supported and how!} + property PrivateKeyFile: string read FPrivateKeyFile write FPrivateKeyFile; + + {:Used for loading certificate from binary string. See to plugin documentation + if this method is supported and how!} + property Certificate: Ansistring read FCertificate write FCertificate; + + {:Used for loading private key from binary string. See to plugin documentation + if this method is supported and how!} + property PrivateKey: Ansistring read FPrivateKey write FPrivateKey; + + {:Used for loading PFX from binary string. See to plugin documentation + if this method is supported and how!} + property PFX: Ansistring read FPFX write FPFX; + + {:Used for loading PFX from disk file. See to plugin documentation + if this method is supported and how!} + property PFXfile: string read FPFXfile write FPFXfile; + + {:Used for loading trusted certificates from disk file. See to plugin documentation + if this method is supported and how!} + property TrustCertificateFile: string read FTrustCertificateFile write FTrustCertificateFile; + + {:Used for loading trusted certificates from binary string. See to plugin documentation + if this method is supported and how!} + property TrustCertificate: Ansistring read FTrustCertificate write FTrustCertificate; + + {:Used for loading CA certificates from binary string. See to plugin documentation + if this method is supported and how!} + property CertCA: Ansistring read FCertCA write FCertCA; + + {:Used for loading CA certificates from disk file. See to plugin documentation + if this method is supported and how!} + property CertCAFile: string read FCertCAFile write SetCertCAFile; + + {:If @true, then is verified client certificate. (it is good for writing + SSL/TLS servers.) When you are not server, but you are client, then if this + property is @true, verify servers certificate.} + property VerifyCert: Boolean read FVerifyCert write FVerifyCert; + + {:channel type for possible SSH connections} + property SSHChannelType: string read FSSHChannelType write FSSHChannelType; + + {:First argument of channel type for possible SSH connections} + property SSHChannelArg1: string read FSSHChannelArg1 write FSSHChannelArg1; + + {:Second argument of channel type for possible SSH connections} + property SSHChannelArg2: string read FSSHChannelArg2 write FSSHChannelArg2; + + {: Level of standards compliance level + (CryptLib: values in cryptlib.pas, -1: use default value ) } + property CertComplianceLevel:integer read FCertComplianceLevel write FCertComplianceLevel; + + {:This event is called when verifying the server certificate immediatally after + a successfull verification in the ssl library.} + property OnVerifyCert: THookVerifyCert read FOnVerifyCert write FOnVerifyCert; + + {: Server Name Identification. Host name to send to server. If empty the host name + found in URL will be used, which should be the normal use (http Header Host = SNI Host). + The value is cleared after the connection is established. + (SNI support requires OpenSSL 0.9.8k or later. Cryptlib not supported, yet ) } + property SNIHost:string read FSNIHost write FSNIHost; + end; + + {:@abstract(Default SSL plugin with no SSL support.) + Dummy SSL plugin implementation for applications without SSL/TLS support.} + TSSLNone = class (TCustomSSL) + public + {:See @inherited} + function LibVersion: String; override; + {:See @inherited} + function LibName: String; override; + end; + + {:@abstract(Record with definition of IP packet header.) + For reading data from ICMP or RAW sockets.} + TIPHeader = record + VerLen: Byte; + TOS: Byte; + TotalLen: Word; + Identifer: Word; + FragOffsets: Word; + TTL: Byte; + Protocol: Byte; + CheckSum: Word; + SourceIp: LongWord; + DestIp: LongWord; + Options: LongWord; + end; + + {:@abstract(Parent class of application protocol implementations.) + By this class is defined common properties.} + TSynaClient = Class(TObject) + protected + FTargetHost: string; + FTargetPort: string; + FIPInterface: string; + FTimeout: integer; + FUserName: string; + FPassword: string; + public + constructor Create; + published + {:Specify terget server IP (or symbolic name). Default is 'localhost'.} + property TargetHost: string read FTargetHost Write FTargetHost; + + {:Specify terget server port (or symbolic name).} + property TargetPort: string read FTargetPort Write FTargetPort; + + {:Defined local socket address. (outgoing IP address). By default is used + '0.0.0.0' as wildcard for default IP.} + property IPInterface: string read FIPInterface Write FIPInterface; + + {:Specify default timeout for socket operations.} + property Timeout: integer read FTimeout Write FTimeout; + + {:If protocol need user authorization, then fill here username.} + property UserName: string read FUserName Write FUserName; + + {:If protocol need user authorization, then fill here password.} + property Password: string read FPassword Write FPassword; + end; + +var + {:Selected SSL plugin. Default is @link(TSSLNone). + + Do not change this value directly!!! + + Just add your plugin unit to your project uses instead. Each plugin unit have + initialization code what modify this variable.} + SSLImplementation: TSSLClass = TSSLNone; + +implementation + +{$IFDEF ONCEWINSOCK} +var + WsaDataOnce: TWSADATA; + e: ESynapseError; +{$ENDIF} + + +constructor TBlockSocket.Create; +begin + CreateAlternate(''); +end; + +constructor TBlockSocket.CreateAlternate(Stub: string); +{$IFNDEF ONCEWINSOCK} +var + e: ESynapseError; +{$ENDIF} +begin + inherited Create; + FDelayedOptions := TList.Create; + FRaiseExcept := False; +{$IFDEF RAISEEXCEPT} + FRaiseExcept := True; +{$ENDIF} + FSocket := INVALID_SOCKET; + FBuffer := ''; + FLastCR := False; + FLastLF := False; + FBinded := False; + FNonBlockMode := False; + FMaxLineLength := 0; + FMaxSendBandwidth := 0; + FNextSend := 0; + FMaxRecvBandwidth := 0; + FNextRecv := 0; + FConvertLineEnd := False; + FFamily := SF_Any; + FFamilySave := SF_Any; + FIP6used := False; + FPreferIP4 := True; + FInterPacketTimeout := True; + FRecvCounter := 0; + FSendCounter := 0; + FSendMaxChunk := c64k; + FStopFlag := False; + FNonblockSendTimeout := 15000; + FHeartbeatRate := 0; + FOwner := nil; +{$IFNDEF ONCEWINSOCK} + if Stub = '' then + Stub := DLLStackName; + if not InitSocketInterface(Stub) then + begin + e := ESynapseError.Create('Error loading Socket interface (' + Stub + ')!'); + e.ErrorCode := 0; + e.ErrorMessage := 'Error loading Socket interface (' + Stub + ')!'; + raise e; + end; + SockCheck(synsock.WSAStartup(WinsockLevel, FWsaDataOnce)); + ExceptCheck; +{$ENDIF} +end; + +destructor TBlockSocket.Destroy; +var + n: integer; + p: TSynaOption; +begin + CloseSocket; +{$IFNDEF ONCEWINSOCK} + synsock.WSACleanup; + DestroySocketInterface; +{$ENDIF} + for n := FDelayedOptions.Count - 1 downto 0 do + begin + p := TSynaOption(FDelayedOptions[n]); + p.Free; + end; + FDelayedOptions.Free; + inherited Destroy; +end; + +function TBlockSocket.FamilyToAF(f: TSocketFamily): TAddrFamily; +begin + case f of + SF_ip4: + Result := AF_INET; + SF_ip6: + Result := AF_INET6; + else + Result := AF_UNSPEC; + end; +end; + +procedure TBlockSocket.SetDelayedOption(const Value: TSynaOption); +var + li: TLinger; + x: integer; + buf: TMemory; +{$IFNDEF MSWINDOWS} + timeval: TTimeval; +{$ENDIF} +begin + case value.Option of + SOT_Linger: + begin + {$IFDEF CIL} + li := TLinger.Create(Value.Enabled, Value.Value div 1000); + synsock.SetSockOptObj(FSocket, integer(SOL_SOCKET), integer(SO_LINGER), li); + {$ELSE} + li.l_onoff := Ord(Value.Enabled); + li.l_linger := Value.Value div 1000; + buf := @li; + synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_LINGER), buf, SizeOf(li)); + {$ENDIF} + end; + SOT_RecvBuff: + begin + {$IFDEF CIL} + buf := System.BitConverter.GetBytes(value.Value); + {$ELSE} + buf := @Value.Value; + {$ENDIF} + synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_RCVBUF), + buf, SizeOf(Value.Value)); + end; + SOT_SendBuff: + begin + {$IFDEF CIL} + buf := System.BitConverter.GetBytes(value.Value); + {$ELSE} + buf := @Value.Value; + {$ENDIF} + synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_SNDBUF), + buf, SizeOf(Value.Value)); + end; + SOT_NonBlock: + begin + FNonBlockMode := Value.Enabled; + x := Ord(FNonBlockMode); + synsock.IoctlSocket(FSocket, FIONBIO, x); + end; + SOT_RecvTimeout: + begin + {$IFDEF CIL} + buf := System.BitConverter.GetBytes(value.Value); + synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_RCVTIMEO), + buf, SizeOf(Value.Value)); + {$ELSE} + {$IFDEF MSWINDOWS} + buf := @Value.Value; + synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_RCVTIMEO), + buf, SizeOf(Value.Value)); + {$ELSE} + timeval.tv_sec:=Value.Value div 1000; + timeval.tv_usec:=(Value.Value mod 1000) * 1000; + synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_RCVTIMEO), + @timeval, SizeOf(timeval)); + {$ENDIF} + {$ENDIF} + end; + SOT_SendTimeout: + begin + {$IFDEF CIL} + buf := System.BitConverter.GetBytes(value.Value); + {$ELSE} + {$IFDEF MSWINDOWS} + buf := @Value.Value; + synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_SNDTIMEO), + buf, SizeOf(Value.Value)); + {$ELSE} + timeval.tv_sec:=Value.Value div 1000; + timeval.tv_usec:=(Value.Value mod 1000) * 1000; + synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_SNDTIMEO), + @timeval, SizeOf(timeval)); + {$ENDIF} + {$ENDIF} + end; + SOT_Reuse: + begin + x := Ord(Value.Enabled); + {$IFDEF CIL} + buf := System.BitConverter.GetBytes(x); + {$ELSE} + buf := @x; + {$ENDIF} + synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_REUSEADDR), buf, SizeOf(x)); + end; + SOT_TTL: + begin + {$IFDEF CIL} + buf := System.BitConverter.GetBytes(value.Value); + {$ELSE} + buf := @Value.Value; + {$ENDIF} + if FIP6Used then + synsock.SetSockOpt(FSocket, integer(IPPROTO_IPV6), integer(IPV6_UNICAST_HOPS), + buf, SizeOf(Value.Value)) + else + synsock.SetSockOpt(FSocket, integer(IPPROTO_IP), integer(IP_TTL), + buf, SizeOf(Value.Value)); + end; + SOT_Broadcast: + begin +//#todo1 broadcasty na IP6 + x := Ord(Value.Enabled); + {$IFDEF CIL} + buf := System.BitConverter.GetBytes(x); + {$ELSE} + buf := @x; + {$ENDIF} + synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_BROADCAST), buf, SizeOf(x)); + end; + SOT_MulticastTTL: + begin + {$IFDEF CIL} + buf := System.BitConverter.GetBytes(value.Value); + {$ELSE} + buf := @Value.Value; + {$ENDIF} + if FIP6Used then + synsock.SetSockOpt(FSocket, integer(IPPROTO_IPV6), integer(IPV6_MULTICAST_HOPS), + buf, SizeOf(Value.Value)) + else + synsock.SetSockOpt(FSocket, integer(IPPROTO_IP), integer(IP_MULTICAST_TTL), + buf, SizeOf(Value.Value)); + end; + SOT_MulticastLoop: + begin + x := Ord(Value.Enabled); + {$IFDEF CIL} + buf := System.BitConverter.GetBytes(x); + {$ELSE} + buf := @x; + {$ENDIF} + if FIP6Used then + synsock.SetSockOpt(FSocket, integer(IPPROTO_IPV6), integer(IPV6_MULTICAST_LOOP), buf, SizeOf(x)) + else + synsock.SetSockOpt(FSocket, integer(IPPROTO_IP), integer(IP_MULTICAST_LOOP), buf, SizeOf(x)); + end; + end; + Value.free; +end; + +procedure TBlockSocket.DelayedOption(const Value: TSynaOption); +begin + if FSocket = INVALID_SOCKET then + begin + FDelayedOptions.Insert(0, Value); + end + else + SetDelayedOption(Value); +end; + +procedure TBlockSocket.ProcessDelayedOptions; +var + n: integer; + d: TSynaOption; +begin + for n := FDelayedOptions.Count - 1 downto 0 do + begin + d := TSynaOption(FDelayedOptions[n]); + SetDelayedOption(d); + end; + FDelayedOptions.Clear; +end; + +procedure TBlockSocket.SetSin(var Sin: TVarSin; IP, Port: string); +var + f: TSocketFamily; +begin + DoStatus(HR_ResolvingBegin, IP + ':' + Port); + ResetLastError; + //if socket exists, then use their type, else use users selection + f := SF_Any; + if (FSocket = INVALID_SOCKET) and (FFamily = SF_any) then + begin + if IsIP(IP) then + f := SF_IP4 + else + if IsIP6(IP) then + f := SF_IP6; + end + else + f := FFamily; + FLastError := synsock.SetVarSin(sin, ip, port, FamilyToAF(f), + GetSocketprotocol, GetSocketType, FPreferIP4); + DoStatus(HR_ResolvingEnd, GetSinIP(sin) + ':' + IntTostr(GetSinPort(sin))); +end; + +function TBlockSocket.GetSinIP(Sin: TVarSin): string; +begin + Result := synsock.GetSinIP(sin); +end; + +function TBlockSocket.GetSinPort(Sin: TVarSin): Integer; +begin + Result := synsock.GetSinPort(sin); +end; + +procedure TBlockSocket.CreateSocket; +var + sin: TVarSin; +begin + //dummy for SF_Any Family mode + ResetLastError; + if (FFamily <> SF_Any) and (FSocket = INVALID_SOCKET) then + begin + {$IFDEF CIL} + if FFamily = SF_IP6 then + sin := TVarSin.Create(IPAddress.Parse('::0'), 0) + else + sin := TVarSin.Create(IPAddress.Parse('0.0.0.0'), 0); + {$ELSE} + FillChar(Sin, Sizeof(Sin), 0); + if FFamily = SF_IP6 then + sin.sin_family := AF_INET6 + else + sin.sin_family := AF_INET; + {$ENDIF} + InternalCreateSocket(Sin); + end; +end; + +procedure TBlockSocket.CreateSocketByName(const Value: String); +var + sin: TVarSin; +begin + ResetLastError; + if FSocket = INVALID_SOCKET then + begin + SetSin(sin, value, '0'); + if FLastError = 0 then + InternalCreateSocket(Sin); + end; +end; + +procedure TBlockSocket.InternalCreateSocket(Sin: TVarSin); +begin + FStopFlag := False; + FRecvCounter := 0; + FSendCounter := 0; + ResetLastError; + if FSocket = INVALID_SOCKET then + begin + FBuffer := ''; + FBinded := False; + FIP6Used := Sin.AddressFamily = AF_INET6; + FSocket := synsock.Socket(integer(Sin.AddressFamily), GetSocketType, GetSocketProtocol); + if FSocket = INVALID_SOCKET then + FLastError := synsock.WSAGetLastError; + {$IFNDEF CIL} + FD_ZERO(FFDSet); + FD_SET(FSocket, FFDSet); + {$ENDIF} + ExceptCheck; + if FIP6used then + DoStatus(HR_SocketCreate, 'IPv6') + else + DoStatus(HR_SocketCreate, 'IPv4'); + ProcessDelayedOptions; + DoCreateSocket; + end; +end; + +procedure TBlockSocket.CloseSocket; +begin + AbortSocket; +end; + +procedure TBlockSocket.AbortSocket; +var + n: integer; + p: TSynaOption; +begin + if FSocket <> INVALID_SOCKET then + synsock.CloseSocket(FSocket); + FSocket := INVALID_SOCKET; + for n := FDelayedOptions.Count - 1 downto 0 do + begin + p := TSynaOption(FDelayedOptions[n]); + p.Free; + end; + FDelayedOptions.Clear; + FFamily := FFamilySave; + DoStatus(HR_SocketClose, ''); +end; + +procedure TBlockSocket.Bind(IP, Port: string); +var + Sin: TVarSin; +begin + ResetLastError; + if (FSocket <> INVALID_SOCKET) + or not((FFamily = SF_ANY) and (IP = cAnyHost) and (Port = cAnyPort)) then + begin + SetSin(Sin, IP, Port); + if FLastError = 0 then + begin + if FSocket = INVALID_SOCKET then + InternalCreateSocket(Sin); + SockCheck(synsock.Bind(FSocket, Sin)); + GetSinLocal; + FBuffer := ''; + FBinded := True; + end; + ExceptCheck; + DoStatus(HR_Bind, IP + ':' + Port); + end; +end; + +procedure TBlockSocket.Connect(IP, Port: string); +var + Sin: TVarSin; +begin + SetSin(Sin, IP, Port); + if FLastError = 0 then + begin + if FSocket = INVALID_SOCKET then + InternalCreateSocket(Sin); + SockCheck(synsock.Connect(FSocket, Sin)); + if FLastError = 0 then + GetSins; + FBuffer := ''; + FLastCR := False; + FLastLF := False; + end; + ExceptCheck; + DoStatus(HR_Connect, IP + ':' + Port); +end; + +procedure TBlockSocket.Listen; +begin + SockCheck(synsock.Listen(FSocket, SOMAXCONN)); + GetSins; + ExceptCheck; + DoStatus(HR_Listen, ''); +end; + +function TBlockSocket.Accept: TSocket; +begin + Result := synsock.Accept(FSocket, FRemoteSin); +/// SockCheck(Result); + ExceptCheck; + DoStatus(HR_Accept, ''); +end; + +procedure TBlockSocket.GetSinLocal; +begin + synsock.GetSockName(FSocket, FLocalSin); +end; + +procedure TBlockSocket.GetSinRemote; +begin + synsock.GetPeerName(FSocket, FRemoteSin); +end; + +procedure TBlockSocket.GetSins; +begin + GetSinLocal; + GetSinRemote; +end; + +procedure TBlockSocket.SetBandwidth(Value: Integer); +begin + MaxSendBandwidth := Value; + MaxRecvBandwidth := Value; +end; + +procedure TBlockSocket.LimitBandwidth(Length: Integer; MaxB: integer; var Next: LongWord); +var + x: LongWord; + y: LongWord; + n: integer; +begin + if FStopFlag then + exit; + if MaxB > 0 then + begin + y := GetTick; + if Next > y then + begin + x := Next - y; + if x > 0 then + begin + DoStatus(HR_Wait, IntToStr(x)); + sleep(x mod 250); + for n := 1 to x div 250 do + if FStopFlag then + Break + else + sleep(250); + end; + end; + Next := GetTick + Trunc((Length / MaxB) * 1000); + end; +end; + +function TBlockSocket.TestStopFlag: Boolean; +begin + DoHeartbeat; + Result := FStopFlag; + if Result then + begin + FStopFlag := False; + FLastError := WSAECONNABORTED; + ExceptCheck; + end; +end; + + +function TBlockSocket.SendBuffer(Buffer: TMemory; Length: Integer): Integer; +{$IFNDEF CIL} +var + x, y: integer; + l, r: integer; + p: Pointer; +{$ENDIF} +begin + Result := 0; + if TestStopFlag then + Exit; + DoMonitor(True, Buffer, Length); +{$IFDEF CIL} + Result := synsock.Send(FSocket, Buffer, Length, 0); +{$ELSE} + l := Length; + x := 0; + while x < l do + begin + y := l - x; + if y > FSendMaxChunk then + y := FSendMaxChunk; + if y > 0 then + begin + LimitBandwidth(y, FMaxSendBandwidth, FNextsend); + p := IncPoint(Buffer, x); + r := synsock.Send(FSocket, p, y, MSG_NOSIGNAL); + SockCheck(r); + if FLastError = WSAEWOULDBLOCK then + begin + if CanWrite(FNonblockSendTimeout) then + begin + r := synsock.Send(FSocket, p, y, MSG_NOSIGNAL); + SockCheck(r); + end + else + FLastError := WSAETIMEDOUT; + end; + if FLastError <> 0 then + Break; + Inc(x, r); + Inc(Result, r); + Inc(FSendCounter, r); + DoStatus(HR_WriteCount, IntToStr(r)); + end + else + break; + end; +{$ENDIF} + ExceptCheck; +end; + +procedure TBlockSocket.SendByte(Data: Byte); +{$IFDEF CIL} +var + buf: TMemory; +{$ENDIF} +begin +{$IFDEF CIL} + setlength(buf, 1); + buf[0] := Data; + SendBuffer(buf, 1); +{$ELSE} + SendBuffer(@Data, 1); +{$ENDIF} +end; + +procedure TBlockSocket.SendString(Data: AnsiString); +var + buf: TMemory; +begin + {$IFDEF CIL} + buf := BytesOf(Data); + {$ELSE} + buf := Pointer(data); + {$ENDIF} + SendBuffer(buf, Length(Data)); +end; + +procedure TBlockSocket.SendInteger(Data: integer); +var + buf: TMemory; +begin + {$IFDEF CIL} + buf := System.BitConverter.GetBytes(Data); + {$ELSE} + buf := @Data; + {$ENDIF} + SendBuffer(buf, SizeOf(Data)); +end; + +procedure TBlockSocket.SendBlock(const Data: AnsiString); +var + i: integer; +begin + i := SwapBytes(Length(data)); + SendString(Codelongint(i) + Data); +end; + +procedure TBlockSocket.InternalSendStream(const Stream: TStream; WithSize, Indy: boolean); +var + l: integer; + yr: integer; + s: AnsiString; + b: boolean; +{$IFDEF CIL} + buf: TMemory; +{$ENDIF} +begin + b := true; + l := 0; + if WithSize then + begin + l := Stream.Size - Stream.Position;; + if not Indy then + l := synsock.HToNL(l); + end; + repeat + {$IFDEF CIL} + Setlength(buf, FSendMaxChunk); + yr := Stream.read(buf, FSendMaxChunk); + if yr > 0 then + begin + if WithSize and b then + begin + b := false; + SendString(CodeLongInt(l)); + end; + SendBuffer(buf, yr); + if FLastError <> 0 then + break; + end + {$ELSE} + Setlength(s, FSendMaxChunk); + yr := Stream.read(Pointer(s)^, FSendMaxChunk); + if yr > 0 then + begin + SetLength(s, yr); + if WithSize and b then + begin + b := false; + SendString(CodeLongInt(l) + s); + end + else + SendString(s); + if FLastError <> 0 then + break; + end + {$ENDIF} + until yr <= 0; +end; + +procedure TBlockSocket.SendStreamRaw(const Stream: TStream); +begin + InternalSendStream(Stream, false, false); +end; + +procedure TBlockSocket.SendStreamIndy(const Stream: TStream); +begin + InternalSendStream(Stream, true, true); +end; + +procedure TBlockSocket.SendStream(const Stream: TStream); +begin + InternalSendStream(Stream, true, false); +end; + +function TBlockSocket.RecvBuffer(Buffer: TMemory; Length: Integer): Integer; +begin + Result := 0; + if TestStopFlag then + Exit; + LimitBandwidth(Length, FMaxRecvBandwidth, FNextRecv); +// Result := synsock.Recv(FSocket, Buffer^, Length, MSG_NOSIGNAL); + Result := synsock.Recv(FSocket, Buffer, Length, MSG_NOSIGNAL); + if Result = 0 then + FLastError := WSAECONNRESET + else + SockCheck(Result); + ExceptCheck; + if Result > 0 then + begin + Inc(FRecvCounter, Result); + DoStatus(HR_ReadCount, IntToStr(Result)); + DoMonitor(False, Buffer, Result); + DoReadFilter(Buffer, Result); + end; +end; + +function TBlockSocket.RecvBufferEx(Buffer: TMemory; Len: Integer; + Timeout: Integer): Integer; +var + s: AnsiString; + rl, l: integer; + ti: LongWord; +{$IFDEF CIL} + n: integer; + b: TMemory; +{$ENDIF} +begin + ResetLastError; + Result := 0; + if Len > 0 then + begin + rl := 0; + repeat + ti := GetTick; + s := RecvPacket(Timeout); + l := Length(s); + if (rl + l) > Len then + l := Len - rl; + {$IFDEF CIL} + b := BytesOf(s); + for n := 0 to l do + Buffer[rl + n] := b[n]; + {$ELSE} + Move(Pointer(s)^, IncPoint(Buffer, rl)^, l); + {$ENDIF} + rl := rl + l; + if FLastError <> 0 then + Break; + if rl >= Len then + Break; + if not FInterPacketTimeout then + begin + Timeout := Timeout - integer(TickDelta(ti, GetTick)); + if Timeout <= 0 then + begin + FLastError := WSAETIMEDOUT; + Break; + end; + end; + until False; + delete(s, 1, l); + FBuffer := s; + Result := rl; + end; +end; + +function TBlockSocket.RecvBufferStr(Len: Integer; Timeout: Integer): AnsiString; +var + x: integer; +{$IFDEF CIL} + buf: Tmemory; +{$ENDIF} +begin + Result := ''; + if Len > 0 then + begin + {$IFDEF CIL} + Setlength(Buf, Len); + x := RecvBufferEx(buf, Len , Timeout); + if FLastError = 0 then + begin + SetLength(Buf, x); + Result := StringOf(buf); + end + else + Result := ''; + {$ELSE} + Setlength(Result, Len); + x := RecvBufferEx(Pointer(Result), Len , Timeout); + if FLastError = 0 then + SetLength(Result, x) + else + Result := ''; + {$ENDIF} + end; +end; + +function TBlockSocket.RecvPacket(Timeout: Integer): AnsiString; +var + x: integer; +{$IFDEF CIL} + buf: TMemory; +{$ENDIF} +begin + Result := ''; + ResetLastError; + if FBuffer <> '' then + begin + Result := FBuffer; + FBuffer := ''; + end + else + begin + {$IFDEF MSWINDOWS} + //not drain CPU on large downloads... + Sleep(0); + {$ENDIF} + x := WaitingData; + if x > 0 then + begin + {$IFDEF CIL} + SetLength(Buf, x); + x := RecvBuffer(Buf, x); + if x >= 0 then + begin + SetLength(Buf, x); + Result := StringOf(Buf); + end; + {$ELSE} + SetLength(Result, x); + x := RecvBuffer(Pointer(Result), x); + if x >= 0 then + SetLength(Result, x); + {$ENDIF} + end + else + begin + if CanRead(Timeout) then + begin + x := WaitingData; + if x = 0 then + FLastError := WSAECONNRESET; + if x > 0 then + begin + {$IFDEF CIL} + SetLength(Buf, x); + x := RecvBuffer(Buf, x); + if x >= 0 then + begin + SetLength(Buf, x); + result := StringOf(Buf); + end; + {$ELSE} + SetLength(Result, x); + x := RecvBuffer(Pointer(Result), x); + if x >= 0 then + SetLength(Result, x); + {$ENDIF} + end; + end + else + FLastError := WSAETIMEDOUT; + end; + end; + if FConvertLineEnd and (Result <> '') then + begin + if FLastCR and (Result[1] = LF) then + Delete(Result, 1, 1); + if FLastLF and (Result[1] = CR) then + Delete(Result, 1, 1); + FLastCR := False; + FLastLF := False; + end; + ExceptCheck; +end; + + +function TBlockSocket.RecvByte(Timeout: Integer): Byte; +begin + Result := 0; + ResetLastError; + if FBuffer = '' then + FBuffer := RecvPacket(Timeout); + if (FLastError = 0) and (FBuffer <> '') then + begin + Result := Ord(FBuffer[1]); + Delete(FBuffer, 1, 1); + end; + ExceptCheck; +end; + +function TBlockSocket.RecvInteger(Timeout: Integer): Integer; +var + s: AnsiString; +begin + Result := 0; + s := RecvBufferStr(4, Timeout); + if FLastError = 0 then + Result := (ord(s[1]) + ord(s[2]) * 256) + (ord(s[3]) + ord(s[4]) * 256) * 65536; +end; + +function TBlockSocket.RecvTerminated(Timeout: Integer; const Terminator: AnsiString): AnsiString; +var + x: Integer; + s: AnsiString; + l: Integer; + CorCRLF: Boolean; + t: AnsiString; + tl: integer; + ti: LongWord; +begin + ResetLastError; + Result := ''; + l := Length(Terminator); + if l = 0 then + Exit; + tl := l; + CorCRLF := FConvertLineEnd and (Terminator = CRLF); + s := ''; + x := 0; + repeat + //get rest of FBuffer or incomming new data... + ti := GetTick; + s := s + RecvPacket(Timeout); + if FLastError <> 0 then + Break; + x := 0; + if Length(s) > 0 then + if CorCRLF then + begin + t := ''; + x := PosCRLF(s, t); + tl := Length(t); + if t = CR then + FLastCR := True; + if t = LF then + FLastLF := True; + end + else + begin + x := pos(Terminator, s); + tl := l; + end; + if (FMaxLineLength <> 0) and (Length(s) > FMaxLineLength) then + begin + FLastError := WSAENOBUFS; + Break; + end; + if x > 0 then + Break; + if not FInterPacketTimeout then + begin + Timeout := Timeout - integer(TickDelta(ti, GetTick)); + if Timeout <= 0 then + begin + FLastError := WSAETIMEDOUT; + Break; + end; + end; + until False; + if x > 0 then + begin + Result := Copy(s, 1, x - 1); + Delete(s, 1, x + tl - 1); + end; + FBuffer := s; + ExceptCheck; +end; + +function TBlockSocket.RecvString(Timeout: Integer): AnsiString; +var + s: AnsiString; +begin + Result := ''; + s := RecvTerminated(Timeout, CRLF); + if FLastError = 0 then + Result := s; +end; + +function TBlockSocket.RecvBlock(Timeout: Integer): AnsiString; +var + x: integer; +begin + Result := ''; + x := RecvInteger(Timeout); + if FLastError = 0 then + Result := RecvBufferStr(x, Timeout); +end; + +procedure TBlockSocket.RecvStreamRaw(const Stream: TStream; Timeout: Integer); +var + s: AnsiString; +begin + repeat + s := RecvPacket(Timeout); + if FLastError = 0 then + WriteStrToStream(Stream, s); + until FLastError <> 0; +end; + +procedure TBlockSocket.RecvStreamSize(const Stream: TStream; Timeout: Integer; Size: Integer); +var + s: AnsiString; + n: integer; +{$IFDEF CIL} + buf: TMemory; +{$ENDIF} +begin + for n := 1 to (Size div FSendMaxChunk) do + begin + {$IFDEF CIL} + SetLength(buf, FSendMaxChunk); + RecvBufferEx(buf, FSendMaxChunk, Timeout); + if FLastError <> 0 then + Exit; + Stream.Write(buf, FSendMaxChunk); + {$ELSE} + s := RecvBufferStr(FSendMaxChunk, Timeout); + if FLastError <> 0 then + Exit; + WriteStrToStream(Stream, s); + {$ENDIF} + end; + n := Size mod FSendMaxChunk; + if n > 0 then + begin + {$IFDEF CIL} + SetLength(buf, n); + RecvBufferEx(buf, n, Timeout); + if FLastError <> 0 then + Exit; + Stream.Write(buf, n); + {$ELSE} + s := RecvBufferStr(n, Timeout); + if FLastError <> 0 then + Exit; + WriteStrToStream(Stream, s); + {$ENDIF} + end; +end; + +procedure TBlockSocket.RecvStreamIndy(const Stream: TStream; Timeout: Integer); +var + x: integer; +begin + x := RecvInteger(Timeout); + x := synsock.NToHL(x); + if FLastError = 0 then + RecvStreamSize(Stream, Timeout, x); +end; + +procedure TBlockSocket.RecvStream(const Stream: TStream; Timeout: Integer); +var + x: integer; +begin + x := RecvInteger(Timeout); + if FLastError = 0 then + RecvStreamSize(Stream, Timeout, x); +end; + +function TBlockSocket.PeekBuffer(Buffer: TMemory; Length: Integer): Integer; +begin + {$IFNDEF CIL} +// Result := synsock.Recv(FSocket, Buffer^, Length, MSG_PEEK + MSG_NOSIGNAL); + Result := synsock.Recv(FSocket, Buffer, Length, MSG_PEEK + MSG_NOSIGNAL); + SockCheck(Result); + ExceptCheck; + {$ENDIF} +end; + +function TBlockSocket.PeekByte(Timeout: Integer): Byte; +var + s: string; +begin + {$IFNDEF CIL} + Result := 0; + if CanRead(Timeout) then + begin + SetLength(s, 1); + PeekBuffer(Pointer(s), 1); + if s <> '' then + Result := Ord(s[1]); + end + else + FLastError := WSAETIMEDOUT; + ExceptCheck; + {$ENDIF} +end; + +procedure TBlockSocket.ResetLastError; +begin + FLastError := 0; + FLastErrorDesc := ''; +end; + +function TBlockSocket.SockCheck(SockResult: Integer): Integer; +begin + ResetLastError; + if SockResult = integer(SOCKET_ERROR) then + begin + FLastError := synsock.WSAGetLastError; + FLastErrorDesc := GetErrorDescEx; + end; + Result := FLastError; +end; + +procedure TBlockSocket.ExceptCheck; +var + e: ESynapseError; +begin + FLastErrorDesc := GetErrorDescEx; + if (LastError <> 0) and (LastError <> WSAEINPROGRESS) + and (LastError <> WSAEWOULDBLOCK) then + begin + DoStatus(HR_Error, IntToStr(FLastError) + ',' + FLastErrorDesc); + if FRaiseExcept then + begin + e := ESynapseError.Create(Format('Synapse TCP/IP Socket error %d: %s', + [FLastError, FLastErrorDesc])); + e.ErrorCode := FLastError; + e.ErrorMessage := FLastErrorDesc; + raise e; + end; + end; +end; + +function TBlockSocket.WaitingData: Integer; +var + x: Integer; +begin + Result := 0; + if synsock.IoctlSocket(FSocket, FIONREAD, x) = 0 then + Result := x; + if Result > c64k then + Result := c64k; +end; + +function TBlockSocket.WaitingDataEx: Integer; +begin + if FBuffer <> '' then + Result := Length(FBuffer) + else + Result := WaitingData; +end; + +procedure TBlockSocket.Purge; +begin + Sleep(1); + try + while (Length(FBuffer) > 0) or (WaitingData > 0) do + begin + RecvPacket(0); + if FLastError <> 0 then + break; + end; + except + on exception do; + end; + ResetLastError; +end; + +procedure TBlockSocket.SetLinger(Enable: Boolean; Linger: Integer); +var + d: TSynaOption; +begin + d := TSynaOption.Create; + d.Option := SOT_Linger; + d.Enabled := Enable; + d.Value := Linger; + DelayedOption(d); +end; + +function TBlockSocket.LocalName: string; +begin + Result := synsock.GetHostName; + if Result = '' then + Result := '127.0.0.1'; +end; + +procedure TBlockSocket.ResolveNameToIP(Name: string; const IPList: TStrings); +begin + IPList.Clear; + synsock.ResolveNameToIP(Name, FamilyToAF(FFamily), GetSocketprotocol, GetSocketType, IPList); + if IPList.Count = 0 then + IPList.Add(cAnyHost); +end; + +function TBlockSocket.ResolveName(Name: string): string; +var + l: TStringList; +begin + l := TStringList.Create; + try + ResolveNameToIP(Name, l); + Result := l[0]; + finally + l.Free; + end; +end; + +function TBlockSocket.ResolvePort(Port: string): Word; +begin + Result := synsock.ResolvePort(Port, FamilyToAF(FFamily), GetSocketProtocol, GetSocketType); +end; + +function TBlockSocket.ResolveIPToName(IP: string): string; +begin + if not IsIP(IP) and not IsIp6(IP) then + IP := ResolveName(IP); + Result := synsock.ResolveIPToName(IP, FamilyToAF(FFamily), GetSocketProtocol, GetSocketType); +end; + +procedure TBlockSocket.SetRemoteSin(IP, Port: string); +begin + SetSin(FRemoteSin, IP, Port); +end; + +function TBlockSocket.GetLocalSinIP: string; +begin + Result := GetSinIP(FLocalSin); +end; + +function TBlockSocket.GetRemoteSinIP: string; +begin + Result := GetSinIP(FRemoteSin); +end; + +function TBlockSocket.GetLocalSinPort: Integer; +begin + Result := GetSinPort(FLocalSin); +end; + +function TBlockSocket.GetRemoteSinPort: Integer; +begin + Result := GetSinPort(FRemoteSin); +end; + +function TBlockSocket.InternalCanRead(Timeout: Integer): Boolean; +{$IFDEF CIL} +begin + Result := FSocket.Poll(Timeout * 1000, SelectMode.SelectRead); +{$ELSE} +var + TimeVal: PTimeVal; + TimeV: TTimeVal; + x: Integer; + FDSet: TFDSet; +begin + TimeV.tv_usec := (Timeout mod 1000) * 1000; + TimeV.tv_sec := Timeout div 1000; + TimeVal := @TimeV; + if Timeout = -1 then + TimeVal := nil; + FDSet := FFdSet; + x := synsock.Select(FSocket + 1, @FDSet, nil, nil, TimeVal); + SockCheck(x); + if FLastError <> 0 then + x := 0; + Result := x > 0; +{$ENDIF} +end; + +function TBlockSocket.CanRead(Timeout: Integer): Boolean; +var + ti, tr: Integer; + n: integer; +begin + if (FHeartbeatRate <> 0) and (Timeout <> -1) then + begin + ti := Timeout div FHeartbeatRate; + tr := Timeout mod FHeartbeatRate; + end + else + begin + ti := 0; + tr := Timeout; + end; + Result := InternalCanRead(tr); + if not Result then + for n := 0 to ti do + begin + DoHeartbeat; + if FStopFlag then + begin + Result := False; + FStopFlag := False; + Break; + end; + Result := InternalCanRead(FHeartbeatRate); + if Result then + break; + end; + ExceptCheck; + if Result then + DoStatus(HR_CanRead, ''); +end; + +function TBlockSocket.CanWrite(Timeout: Integer): Boolean; +{$IFDEF CIL} +begin + Result := FSocket.Poll(Timeout * 1000, SelectMode.SelectWrite); +{$ELSE} +var + TimeVal: PTimeVal; + TimeV: TTimeVal; + x: Integer; + FDSet: TFDSet; +begin + TimeV.tv_usec := (Timeout mod 1000) * 1000; + TimeV.tv_sec := Timeout div 1000; + TimeVal := @TimeV; + if Timeout = -1 then + TimeVal := nil; + FDSet := FFdSet; + x := synsock.Select(FSocket + 1, nil, @FDSet, nil, TimeVal); + SockCheck(x); + if FLastError <> 0 then + x := 0; + Result := x > 0; +{$ENDIF} + ExceptCheck; + if Result then + DoStatus(HR_CanWrite, ''); +end; + +function TBlockSocket.CanReadEx(Timeout: Integer): Boolean; +begin + if FBuffer <> '' then + Result := True + else + Result := CanRead(Timeout); +end; + +function TBlockSocket.SendBufferTo(Buffer: TMemory; Length: Integer): Integer; +begin + Result := 0; + if TestStopFlag then + Exit; + DoMonitor(True, Buffer, Length); + LimitBandwidth(Length, FMaxSendBandwidth, FNextsend); + Result := synsock.SendTo(FSocket, Buffer, Length, MSG_NOSIGNAL, FRemoteSin); + SockCheck(Result); + ExceptCheck; + Inc(FSendCounter, Result); + DoStatus(HR_WriteCount, IntToStr(Result)); +end; + +function TBlockSocket.RecvBufferFrom(Buffer: TMemory; Length: Integer): Integer; +begin + Result := 0; + if TestStopFlag then + Exit; + LimitBandwidth(Length, FMaxRecvBandwidth, FNextRecv); + Result := synsock.RecvFrom(FSocket, Buffer, Length, MSG_NOSIGNAL, FRemoteSin); + SockCheck(Result); + ExceptCheck; + Inc(FRecvCounter, Result); + DoStatus(HR_ReadCount, IntToStr(Result)); + DoMonitor(False, Buffer, Result); +end; + +function TBlockSocket.GetSizeRecvBuffer: Integer; +var + l: Integer; +{$IFDEF CIL} + buf: TMemory; +{$ENDIF} +begin +{$IFDEF CIL} + setlength(buf, 4); + SockCheck(synsock.GetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_RCVBUF), buf, l)); + Result := System.BitConverter.ToInt32(buf,0); +{$ELSE} + l := SizeOf(Result); + SockCheck(synsock.GetSockOpt(FSocket, SOL_SOCKET, SO_RCVBUF, @Result, l)); + if FLastError <> 0 then + Result := 1024; + ExceptCheck; +{$ENDIF} +end; + +procedure TBlockSocket.SetSizeRecvBuffer(Size: Integer); +var + d: TSynaOption; +begin + d := TSynaOption.Create; + d.Option := SOT_RecvBuff; + d.Value := Size; + DelayedOption(d); +end; + +function TBlockSocket.GetSizeSendBuffer: Integer; +var + l: Integer; +{$IFDEF CIL} + buf: TMemory; +{$ENDIF} +begin +{$IFDEF CIL} + setlength(buf, 4); + SockCheck(synsock.GetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_SNDBUF), buf, l)); + Result := System.BitConverter.ToInt32(buf,0); +{$ELSE} + l := SizeOf(Result); + SockCheck(synsock.GetSockOpt(FSocket, SOL_SOCKET, SO_SNDBUF, @Result, l)); + if FLastError <> 0 then + Result := 1024; + ExceptCheck; +{$ENDIF} +end; + +procedure TBlockSocket.SetSizeSendBuffer(Size: Integer); +var + d: TSynaOption; +begin + d := TSynaOption.Create; + d.Option := SOT_SendBuff; + d.Value := Size; + DelayedOption(d); +end; + +procedure TBlockSocket.SetNonBlockMode(Value: Boolean); +var + d: TSynaOption; +begin + d := TSynaOption.Create; + d.Option := SOT_nonblock; + d.Enabled := Value; + DelayedOption(d); +end; + +procedure TBlockSocket.SetTimeout(Timeout: Integer); +begin + SetSendTimeout(Timeout); + SetRecvTimeout(Timeout); +end; + +procedure TBlockSocket.SetSendTimeout(Timeout: Integer); +var + d: TSynaOption; +begin + d := TSynaOption.Create; + d.Option := SOT_sendtimeout; + d.Value := Timeout; + DelayedOption(d); +end; + +procedure TBlockSocket.SetRecvTimeout(Timeout: Integer); +var + d: TSynaOption; +begin + d := TSynaOption.Create; + d.Option := SOT_recvtimeout; + d.Value := Timeout; + DelayedOption(d); +end; + +{$IFNDEF CIL} +function TBlockSocket.GroupCanRead(const SocketList: TList; Timeout: Integer; + const CanReadList: TList): boolean; +var + FDSet: TFDSet; + TimeVal: PTimeVal; + TimeV: TTimeVal; + x, n: Integer; + Max: Integer; +begin + TimeV.tv_usec := (Timeout mod 1000) * 1000; + TimeV.tv_sec := Timeout div 1000; + TimeVal := @TimeV; + if Timeout = -1 then + TimeVal := nil; + FD_ZERO(FDSet); + Max := 0; + for n := 0 to SocketList.Count - 1 do + if TObject(SocketList.Items[n]) is TBlockSocket then + begin + if TBlockSocket(SocketList.Items[n]).Socket > Max then + Max := TBlockSocket(SocketList.Items[n]).Socket; + FD_SET(TBlockSocket(SocketList.Items[n]).Socket, FDSet); + end; + x := synsock.Select(Max + 1, @FDSet, nil, nil, TimeVal); + SockCheck(x); + ExceptCheck; + if FLastError <> 0 then + x := 0; + Result := x > 0; + CanReadList.Clear; + if Result then + for n := 0 to SocketList.Count - 1 do + if TObject(SocketList.Items[n]) is TBlockSocket then + if FD_ISSET(TBlockSocket(SocketList.Items[n]).Socket, FDSet) then + CanReadList.Add(TBlockSocket(SocketList.Items[n])); +end; +{$ENDIF} + +procedure TBlockSocket.EnableReuse(Value: Boolean); +var + d: TSynaOption; +begin + d := TSynaOption.Create; + d.Option := SOT_reuse; + d.Enabled := Value; + DelayedOption(d); +end; + +procedure TBlockSocket.SetTTL(TTL: integer); +var + d: TSynaOption; +begin + d := TSynaOption.Create; + d.Option := SOT_TTL; + d.Value := TTL; + DelayedOption(d); +end; + +function TBlockSocket.GetTTL:integer; +var + l: Integer; +begin +{$IFNDEF CIL} + l := SizeOf(Result); + if FIP6Used then + synsock.GetSockOpt(FSocket, IPPROTO_IPV6, IPV6_UNICAST_HOPS, @Result, l) + else + synsock.GetSockOpt(FSocket, IPPROTO_IP, IP_TTL, @Result, l); +{$ENDIF} +end; + +procedure TBlockSocket.SetFamily(Value: TSocketFamily); +begin + FFamily := Value; + FFamilySave := Value; +end; + +procedure TBlockSocket.SetSocket(Value: TSocket); +begin + FRecvCounter := 0; + FSendCounter := 0; + FSocket := Value; +{$IFNDEF CIL} + FD_ZERO(FFDSet); + FD_SET(FSocket, FFDSet); +{$ENDIF} + GetSins; + FIP6Used := FRemoteSin.AddressFamily = AF_INET6; +end; + +function TBlockSocket.GetWsaData: TWSAData; +begin + {$IFDEF ONCEWINSOCK} + Result := WsaDataOnce; + {$ELSE} + Result := FWsaDataOnce; + {$ENDIF} +end; + +function TBlockSocket.GetSocketType: integer; +begin + Result := 0; +end; + +function TBlockSocket.GetSocketProtocol: integer; +begin + Result := integer(IPPROTO_IP); +end; + +procedure TBlockSocket.DoStatus(Reason: THookSocketReason; const Value: string); +begin + if assigned(OnStatus) then + OnStatus(Self, Reason, Value); +end; + +procedure TBlockSocket.DoReadFilter(Buffer: TMemory; var Len: Integer); +var + s: AnsiString; +begin + if assigned(OnReadFilter) then + if Len > 0 then + begin + {$IFDEF CIL} + s := StringOf(Buffer); + {$ELSE} + SetLength(s, Len); + Move(Buffer^, Pointer(s)^, Len); + {$ENDIF} + OnReadFilter(Self, s); + if Length(s) > Len then + SetLength(s, Len); + Len := Length(s); + {$IFDEF CIL} + Buffer := BytesOf(s); + {$ELSE} + Move(Pointer(s)^, Buffer^, Len); + {$ENDIF} + end; +end; + +procedure TBlockSocket.DoCreateSocket; +begin + if assigned(OnCreateSocket) then + OnCreateSocket(Self); +end; + +procedure TBlockSocket.DoMonitor(Writing: Boolean; const Buffer: TMemory; Len: Integer); +begin + if assigned(OnMonitor) then + begin + OnMonitor(Self, Writing, Buffer, Len); + end; +end; + +procedure TBlockSocket.DoHeartbeat; +begin + if assigned(OnHeartbeat) and (FHeartbeatRate <> 0) then + begin + OnHeartbeat(Self); + end; +end; + +function TBlockSocket.GetErrorDescEx: string; +begin + Result := GetErrorDesc(FLastError); +end; + +class function TBlockSocket.GetErrorDesc(ErrorCode: Integer): string; +begin +{$IFDEF CIL} + if ErrorCode = 0 then + Result := '' + else + begin + Result := WSAGetLastErrorDesc; + if Result = '' then + Result := 'Other Winsock error (' + IntToStr(ErrorCode) + ')'; + end; +{$ELSE} + case ErrorCode of + 0: + Result := ''; + WSAEINTR: {10004} + Result := 'Interrupted system call'; + WSAEBADF: {10009} + Result := 'Bad file number'; + WSAEACCES: {10013} + Result := 'Permission denied'; + WSAEFAULT: {10014} + Result := 'Bad address'; + WSAEINVAL: {10022} + Result := 'Invalid argument'; + WSAEMFILE: {10024} + Result := 'Too many open files'; + WSAEWOULDBLOCK: {10035} + Result := 'Operation would block'; + WSAEINPROGRESS: {10036} + Result := 'Operation now in progress'; + WSAEALREADY: {10037} + Result := 'Operation already in progress'; + WSAENOTSOCK: {10038} + Result := 'Socket operation on nonsocket'; + WSAEDESTADDRREQ: {10039} + Result := 'Destination address required'; + WSAEMSGSIZE: {10040} + Result := 'Message too long'; + WSAEPROTOTYPE: {10041} + Result := 'Protocol wrong type for Socket'; + WSAENOPROTOOPT: {10042} + Result := 'Protocol not available'; + WSAEPROTONOSUPPORT: {10043} + Result := 'Protocol not supported'; + WSAESOCKTNOSUPPORT: {10044} + Result := 'Socket not supported'; + WSAEOPNOTSUPP: {10045} + Result := 'Operation not supported on Socket'; + WSAEPFNOSUPPORT: {10046} + Result := 'Protocol family not supported'; + WSAEAFNOSUPPORT: {10047} + Result := 'Address family not supported'; + WSAEADDRINUSE: {10048} + Result := 'Address already in use'; + WSAEADDRNOTAVAIL: {10049} + Result := 'Can''t assign requested address'; + WSAENETDOWN: {10050} + Result := 'Network is down'; + WSAENETUNREACH: {10051} + Result := 'Network is unreachable'; + WSAENETRESET: {10052} + Result := 'Network dropped connection on reset'; + WSAECONNABORTED: {10053} + Result := 'Software caused connection abort'; + WSAECONNRESET: {10054} + Result := 'Connection reset by peer'; + WSAENOBUFS: {10055} + Result := 'No Buffer space available'; + WSAEISCONN: {10056} + Result := 'Socket is already connected'; + WSAENOTCONN: {10057} + Result := 'Socket is not connected'; + WSAESHUTDOWN: {10058} + Result := 'Can''t send after Socket shutdown'; + WSAETOOMANYREFS: {10059} + Result := 'Too many references:can''t splice'; + WSAETIMEDOUT: {10060} + Result := 'Connection timed out'; + WSAECONNREFUSED: {10061} + Result := 'Connection refused'; + WSAELOOP: {10062} + Result := 'Too many levels of symbolic links'; + WSAENAMETOOLONG: {10063} + Result := 'File name is too long'; + WSAEHOSTDOWN: {10064} + Result := 'Host is down'; + WSAEHOSTUNREACH: {10065} + Result := 'No route to host'; + WSAENOTEMPTY: {10066} + Result := 'Directory is not empty'; + WSAEPROCLIM: {10067} + Result := 'Too many processes'; + WSAEUSERS: {10068} + Result := 'Too many users'; + WSAEDQUOT: {10069} + Result := 'Disk quota exceeded'; + WSAESTALE: {10070} + Result := 'Stale NFS file handle'; + WSAEREMOTE: {10071} + Result := 'Too many levels of remote in path'; + WSASYSNOTREADY: {10091} + Result := 'Network subsystem is unusable'; + WSAVERNOTSUPPORTED: {10092} + Result := 'Winsock DLL cannot support this application'; + WSANOTINITIALISED: {10093} + Result := 'Winsock not initialized'; + WSAEDISCON: {10101} + Result := 'Disconnect'; + WSAHOST_NOT_FOUND: {11001} + Result := 'Host not found'; + WSATRY_AGAIN: {11002} + Result := 'Non authoritative - host not found'; + WSANO_RECOVERY: {11003} + Result := 'Non recoverable error'; + WSANO_DATA: {11004} + Result := 'Valid name, no data record of requested type' + else + Result := 'Other Winsock error (' + IntToStr(ErrorCode) + ')'; + end; +{$ENDIF} +end; + +{======================================================================} + +constructor TSocksBlockSocket.Create; +begin + inherited Create; + FSocksIP:= ''; + FSocksPort:= '1080'; + FSocksTimeout:= 60000; + FSocksUsername:= ''; + FSocksPassword:= ''; + FUsingSocks := False; + FSocksResolver := True; + FSocksLastError := 0; + FSocksResponseIP := ''; + FSocksResponsePort := ''; + FSocksLocalIP := ''; + FSocksLocalPort := ''; + FSocksRemoteIP := ''; + FSocksRemotePort := ''; + FBypassFlag := False; + FSocksType := ST_Socks5; +end; + +function TSocksBlockSocket.SocksOpen: boolean; +var + Buf: AnsiString; + n: integer; +begin + Result := False; + FUsingSocks := False; + if FSocksType <> ST_Socks5 then + begin + FUsingSocks := True; + Result := True; + end + else + begin + FBypassFlag := True; + try + if FSocksUsername = '' then + Buf := #5 + #1 + #0 + else + Buf := #5 + #2 + #2 +#0; + SendString(Buf); + Buf := RecvBufferStr(2, FSocksTimeout); + if Length(Buf) < 2 then + Exit; + if Buf[1] <> #5 then + Exit; + n := Ord(Buf[2]); + case n of + 0: //not need authorisation + ; + 2: + begin + Buf := #1 + AnsiChar(Length(FSocksUsername)) + FSocksUsername + + AnsiChar(Length(FSocksPassword)) + FSocksPassword; + SendString(Buf); + Buf := RecvBufferStr(2, FSocksTimeout); + if Length(Buf) < 2 then + Exit; + if Buf[2] <> #0 then + Exit; + end; + else + //other authorisation is not supported! + Exit; + end; + FUsingSocks := True; + Result := True; + finally + FBypassFlag := False; + end; + end; +end; + +function TSocksBlockSocket.SocksRequest(Cmd: Byte; + const IP, Port: string): Boolean; +var + Buf: AnsiString; +begin + FBypassFlag := True; + try + if FSocksType <> ST_Socks5 then + Buf := #4 + AnsiChar(Cmd) + SocksCode(IP, Port) + else + Buf := #5 + AnsiChar(Cmd) + #0 + SocksCode(IP, Port); + SendString(Buf); + Result := FLastError = 0; + finally + FBypassFlag := False; + end; +end; + +function TSocksBlockSocket.SocksResponse: Boolean; +var + Buf, s: AnsiString; + x: integer; +begin + Result := False; + FBypassFlag := True; + try + FSocksResponseIP := ''; + FSocksResponsePort := ''; + FSocksLastError := -1; + if FSocksType <> ST_Socks5 then + begin + Buf := RecvBufferStr(8, FSocksTimeout); + if FLastError <> 0 then + Exit; + if Buf[1] <> #0 then + Exit; + FSocksLastError := Ord(Buf[2]); + end + else + begin + Buf := RecvBufferStr(4, FSocksTimeout); + if FLastError <> 0 then + Exit; + if Buf[1] <> #5 then + Exit; + case Ord(Buf[4]) of + 1: + s := RecvBufferStr(4, FSocksTimeout); + 3: + begin + x := RecvByte(FSocksTimeout); + if FLastError <> 0 then + Exit; + s := AnsiChar(x) + RecvBufferStr(x, FSocksTimeout); + end; + 4: + s := RecvBufferStr(16, FSocksTimeout); + else + Exit; + end; + Buf := Buf + s + RecvBufferStr(2, FSocksTimeout); + if FLastError <> 0 then + Exit; + FSocksLastError := Ord(Buf[2]); + end; + if ((FSocksLastError <> 0) and (FSocksLastError <> 90)) then + Exit; + SocksDecode(Buf); + Result := True; + finally + FBypassFlag := False; + end; +end; + +function TSocksBlockSocket.SocksCode(IP, Port: string): Ansistring; +var + ip6: TIp6Bytes; + n: integer; +begin + if FSocksType <> ST_Socks5 then + begin + Result := CodeInt(ResolvePort(Port)); + if not FSocksResolver then + IP := ResolveName(IP); + if IsIP(IP) then + begin + Result := Result + IPToID(IP); + Result := Result + FSocksUsername + #0; + end + else + begin + Result := Result + IPToID('0.0.0.1'); + Result := Result + FSocksUsername + #0; + Result := Result + IP + #0; + end; + end + else + begin + if not FSocksResolver then + IP := ResolveName(IP); + if IsIP(IP) then + Result := #1 + IPToID(IP) + else + if IsIP6(IP) then + begin + ip6 := StrToIP6(IP); + Result := #4; + for n := 0 to 15 do + Result := Result + AnsiChar(ip6[n]); + end + else + Result := #3 + AnsiChar(Length(IP)) + IP; + Result := Result + CodeInt(ResolvePort(Port)); + end; +end; + +function TSocksBlockSocket.SocksDecode(Value: Ansistring): integer; +var + Atyp: Byte; + y, n: integer; + w: Word; + ip6: TIp6Bytes; +begin + FSocksResponsePort := '0'; + Result := 0; + if FSocksType <> ST_Socks5 then + begin + if Length(Value) < 8 then + Exit; + Result := 3; + w := DecodeInt(Value, Result); + FSocksResponsePort := IntToStr(w); + FSocksResponseIP := Format('%d.%d.%d.%d', + [Ord(Value[5]), Ord(Value[6]), Ord(Value[7]), Ord(Value[8])]); + Result := 9; + end + else + begin + if Length(Value) < 4 then + Exit; + Atyp := Ord(Value[4]); + Result := 5; + case Atyp of + 1: + begin + if Length(Value) < 10 then + Exit; + FSocksResponseIP := Format('%d.%d.%d.%d', + [Ord(Value[5]), Ord(Value[6]), Ord(Value[7]), Ord(Value[8])]); + Result := 9; + end; + 3: + begin + y := Ord(Value[5]); + if Length(Value) < (5 + y + 2) then + Exit; + for n := 6 to 6 + y - 1 do + FSocksResponseIP := FSocksResponseIP + Value[n]; + Result := 5 + y + 1; + end; + 4: + begin + if Length(Value) < 22 then + Exit; + for n := 0 to 15 do + ip6[n] := ord(Value[n + 5]); + FSocksResponseIP := IP6ToStr(ip6); + Result := 21; + end; + else + Exit; + end; + w := DecodeInt(Value, Result); + FSocksResponsePort := IntToStr(w); + Result := Result + 2; + end; +end; + +{======================================================================} + +procedure TDgramBlockSocket.Connect(IP, Port: string); +begin + SetRemoteSin(IP, Port); + InternalCreateSocket(FRemoteSin); + FBuffer := ''; + DoStatus(HR_Connect, IP + ':' + Port); +end; + +function TDgramBlockSocket.RecvBuffer(Buffer: TMemory; Length: Integer): Integer; +begin + Result := RecvBufferFrom(Buffer, Length); +end; + +function TDgramBlockSocket.SendBuffer(Buffer: TMemory; Length: Integer): Integer; +begin + Result := SendBufferTo(Buffer, Length); +end; + +{======================================================================} + +destructor TUDPBlockSocket.Destroy; +begin + if Assigned(FSocksControlSock) then + FSocksControlSock.Free; + inherited; +end; + +procedure TUDPBlockSocket.EnableBroadcast(Value: Boolean); +var + d: TSynaOption; +begin + d := TSynaOption.Create; + d.Option := SOT_Broadcast; + d.Enabled := Value; + DelayedOption(d); +end; + +function TUDPBlockSocket.UdpAssociation: Boolean; +var + b: Boolean; +begin + Result := True; + FUsingSocks := False; + if FSocksIP <> '' then + begin + Result := False; + if not Assigned(FSocksControlSock) then + FSocksControlSock := TTCPBlockSocket.Create; + FSocksControlSock.CloseSocket; + FSocksControlSock.CreateSocketByName(FSocksIP); + FSocksControlSock.Connect(FSocksIP, FSocksPort); + if FSocksControlSock.LastError <> 0 then + Exit; + // if not assigned local port, assign it! + if not FBinded then + Bind(cAnyHost, cAnyPort); + //open control TCP connection to SOCKS + FSocksControlSock.FSocksUsername := FSocksUsername; + FSocksControlSock.FSocksPassword := FSocksPassword; + b := FSocksControlSock.SocksOpen; + if b then + b := FSocksControlSock.SocksRequest(3, GetLocalSinIP, IntToStr(GetLocalSinPort)); + if b then + b := FSocksControlSock.SocksResponse; + if not b and (FLastError = 0) then + FLastError := WSANO_RECOVERY; + FUsingSocks :=FSocksControlSock.UsingSocks; + FSocksRemoteIP := FSocksControlSock.FSocksResponseIP; + FSocksRemotePort := FSocksControlSock.FSocksResponsePort; + Result := b and (FLastError = 0); + end; +end; + +function TUDPBlockSocket.SendBufferTo(Buffer: TMemory; Length: Integer): Integer; +var + SIp: string; + SPort: integer; + Buf: Ansistring; +begin + Result := 0; + FUsingSocks := False; + if (FSocksIP <> '') and (not UdpAssociation) then + FLastError := WSANO_RECOVERY + else + begin + if FUsingSocks then + begin +{$IFNDEF CIL} + Sip := GetRemoteSinIp; + SPort := GetRemoteSinPort; + SetRemoteSin(FSocksRemoteIP, FSocksRemotePort); + SetLength(Buf,Length); + Move(Buffer^, Pointer(Buf)^, Length); + Buf := #0 + #0 + #0 + SocksCode(Sip, IntToStr(SPort)) + Buf; + Result := inherited SendBufferTo(Pointer(Buf), System.Length(buf)); + SetRemoteSin(Sip, IntToStr(SPort)); +{$ENDIF} + end + else + Result := inherited SendBufferTo(Buffer, Length); + end; +end; + +function TUDPBlockSocket.RecvBufferFrom(Buffer: TMemory; Length: Integer): Integer; +var + Buf: Ansistring; + x: integer; +begin + Result := inherited RecvBufferFrom(Buffer, Length); + if FUsingSocks then + begin +{$IFNDEF CIL} + SetLength(Buf, Result); + Move(Buffer^, Pointer(Buf)^, Result); + x := SocksDecode(Buf); + Result := Result - x + 1; + Buf := Copy(Buf, x, Result); + Move(Pointer(Buf)^, Buffer^, Result); + SetRemoteSin(FSocksResponseIP, FSocksResponsePort); +{$ENDIF} + end; +end; + +{$IFNDEF CIL} +procedure TUDPBlockSocket.AddMulticast(MCastIP: string); +var + Multicast: TIP_mreq; + Multicast6: TIPv6_mreq; + n: integer; + ip6: Tip6bytes; +begin + if FIP6Used then + begin + ip6 := StrToIp6(MCastIP); + for n := 0 to 15 do + Multicast6.ipv6mr_multiaddr.u6_addr8[n] := Ip6[n]; + Multicast6.ipv6mr_interface := 0; + SockCheck(synsock.SetSockOpt(FSocket, IPPROTO_IPV6, IPV6_JOIN_GROUP, + PAnsiChar(@Multicast6), SizeOf(Multicast6))); + end + else + begin + Multicast.imr_multiaddr.S_addr := swapbytes(strtoip(MCastIP)); + Multicast.imr_interface.S_addr := INADDR_ANY; + SockCheck(synsock.SetSockOpt(FSocket, IPPROTO_IP, IP_ADD_MEMBERSHIP, + PAnsiChar(@Multicast), SizeOf(Multicast))); + end; + ExceptCheck; +end; + +procedure TUDPBlockSocket.DropMulticast(MCastIP: string); +var + Multicast: TIP_mreq; + Multicast6: TIPv6_mreq; + n: integer; + ip6: Tip6bytes; +begin + if FIP6Used then + begin + ip6 := StrToIp6(MCastIP); + for n := 0 to 15 do + Multicast6.ipv6mr_multiaddr.u6_addr8[n] := Ip6[n]; + Multicast6.ipv6mr_interface := 0; + SockCheck(synsock.SetSockOpt(FSocket, IPPROTO_IPV6, IPV6_LEAVE_GROUP, + PAnsiChar(@Multicast6), SizeOf(Multicast6))); + end + else + begin + Multicast.imr_multiaddr.S_addr := swapbytes(strtoip(MCastIP)); + Multicast.imr_interface.S_addr := INADDR_ANY; + SockCheck(synsock.SetSockOpt(FSocket, IPPROTO_IP, IP_DROP_MEMBERSHIP, + PAnsiChar(@Multicast), SizeOf(Multicast))); + end; + ExceptCheck; +end; +{$ENDIF} + +procedure TUDPBlockSocket.SetMulticastTTL(TTL: integer); +var + d: TSynaOption; +begin + d := TSynaOption.Create; + d.Option := SOT_MulticastTTL; + d.Value := TTL; + DelayedOption(d); +end; + +function TUDPBlockSocket.GetMulticastTTL:integer; +var + l: Integer; +begin +{$IFNDEF CIL} + l := SizeOf(Result); + if FIP6Used then + synsock.GetSockOpt(FSocket, IPPROTO_IPV6, IPV6_MULTICAST_HOPS, @Result, l) + else + synsock.GetSockOpt(FSocket, IPPROTO_IP, IP_MULTICAST_TTL, @Result, l); +{$ENDIF} +end; + +procedure TUDPBlockSocket.EnableMulticastLoop(Value: Boolean); +var + d: TSynaOption; +begin + d := TSynaOption.Create; + d.Option := SOT_MulticastLoop; + d.Enabled := Value; + DelayedOption(d); +end; + +function TUDPBlockSocket.GetSocketType: integer; +begin + Result := integer(SOCK_DGRAM); +end; + +function TUDPBlockSocket.GetSocketProtocol: integer; +begin + Result := integer(IPPROTO_UDP); +end; + +{======================================================================} +constructor TTCPBlockSocket.CreateWithSSL(SSLPlugin: TSSLClass); +begin + inherited Create; + FSSL := SSLPlugin.Create(self); + FHTTPTunnelIP := ''; + FHTTPTunnelPort := ''; + FHTTPTunnel := False; + FHTTPTunnelRemoteIP := ''; + FHTTPTunnelRemotePort := ''; + FHTTPTunnelUser := ''; + FHTTPTunnelPass := ''; + FHTTPTunnelTimeout := 30000; +end; + +constructor TTCPBlockSocket.Create; +begin + CreateWithSSL(SSLImplementation); +end; + +destructor TTCPBlockSocket.Destroy; +begin + inherited Destroy; + FSSL.Free; +end; + +function TTCPBlockSocket.GetErrorDescEx: string; +begin + Result := inherited GetErrorDescEx; + if (FLastError = WSASYSNOTREADY) and (self.SSL.LastError <> 0) then + begin + Result := self.SSL.LastErrorDesc; + end; +end; + +procedure TTCPBlockSocket.CloseSocket; +begin + if FSSL.SSLEnabled then + FSSL.Shutdown; + if (FSocket <> INVALID_SOCKET) and (FLastError = 0) then + begin + Synsock.Shutdown(FSocket, 1); + Purge; + end; + inherited CloseSocket; +end; + +procedure TTCPBlockSocket.DoAfterConnect; +begin + if assigned(OnAfterConnect) then + begin + OnAfterConnect(Self); + end; +end; + +function TTCPBlockSocket.WaitingData: Integer; +begin + Result := 0; + if FSSL.SSLEnabled and (FSocket <> INVALID_SOCKET) then + Result := FSSL.WaitingData; + if Result = 0 then + Result := inherited WaitingData; +end; + +procedure TTCPBlockSocket.Listen; +var + b: Boolean; + Sip,SPort: string; +begin + if FSocksIP = '' then + begin + inherited Listen; + end + else + begin + Sip := GetLocalSinIP; + if Sip = cAnyHost then + Sip := LocalName; + SPort := IntToStr(GetLocalSinPort); + inherited Connect(FSocksIP, FSocksPort); + b := SocksOpen; + if b then + b := SocksRequest(2, Sip, SPort); + if b then + b := SocksResponse; + if not b and (FLastError = 0) then + FLastError := WSANO_RECOVERY; + FSocksLocalIP := FSocksResponseIP; + if FSocksLocalIP = cAnyHost then + FSocksLocalIP := FSocksIP; + FSocksLocalPort := FSocksResponsePort; + FSocksRemoteIP := ''; + FSocksRemotePort := ''; + ExceptCheck; + DoStatus(HR_Listen, ''); + end; +end; + +function TTCPBlockSocket.Accept: TSocket; +begin + if FUsingSocks then + begin + if not SocksResponse and (FLastError = 0) then + FLastError := WSANO_RECOVERY; + FSocksRemoteIP := FSocksResponseIP; + FSocksRemotePort := FSocksResponsePort; + Result := FSocket; + ExceptCheck; + DoStatus(HR_Accept, ''); + end + else + begin + result := inherited Accept; + end; +end; + +procedure TTCPBlockSocket.Connect(IP, Port: string); +begin + if FSocksIP <> '' then + SocksDoConnect(IP, Port) + else + if FHTTPTunnelIP <> '' then + HTTPTunnelDoConnect(IP, Port) + else + inherited Connect(IP, Port); + if FLasterror = 0 then + DoAfterConnect; +end; + +procedure TTCPBlockSocket.SocksDoConnect(IP, Port: string); +var + b: Boolean; +begin + inherited Connect(FSocksIP, FSocksPort); + if FLastError = 0 then + begin + b := SocksOpen; + if b then + b := SocksRequest(1, IP, Port); + if b then + b := SocksResponse; + if not b and (FLastError = 0) then + FLastError := WSASYSNOTREADY; + FSocksLocalIP := FSocksResponseIP; + FSocksLocalPort := FSocksResponsePort; + FSocksRemoteIP := IP; + FSocksRemotePort := Port; + end; + ExceptCheck; + DoStatus(HR_Connect, IP + ':' + Port); +end; + +procedure TTCPBlockSocket.HTTPTunnelDoConnect(IP, Port: string); +//bugfixed by Mike Green (mgreen@emixode.com) +var + s: string; +begin + Port := IntToStr(ResolvePort(Port)); + inherited Connect(FHTTPTunnelIP, FHTTPTunnelPort); + if FLastError <> 0 then + Exit; + FHTTPTunnel := False; + if IsIP6(IP) then + IP := '[' + IP + ']'; + SendString('CONNECT ' + IP + ':' + Port + ' HTTP/1.0' + CRLF); + if FHTTPTunnelUser <> '' then + Sendstring('Proxy-Authorization: Basic ' + + EncodeBase64(FHTTPTunnelUser + ':' + FHTTPTunnelPass) + CRLF); + SendString(CRLF); + repeat + s := RecvTerminated(FHTTPTunnelTimeout, #$0a); + if FLastError <> 0 then + Break; + if (Pos('HTTP/', s) = 1) and (Length(s) > 11) then + FHTTPTunnel := s[10] = '2'; + until (s = '') or (s = #$0d); + if (FLasterror = 0) and not FHTTPTunnel then + FLastError := WSASYSNOTREADY; + FHTTPTunnelRemoteIP := IP; + FHTTPTunnelRemotePort := Port; + ExceptCheck; +end; + +procedure TTCPBlockSocket.SSLDoConnect; +begin + ResetLastError; + if not FSSL.Connect then + FLastError := WSASYSNOTREADY; + ExceptCheck; +end; + +procedure TTCPBlockSocket.SSLDoShutdown; +begin + ResetLastError; + FSSL.BiShutdown; +end; + +function TTCPBlockSocket.GetLocalSinIP: string; +begin + if FUsingSocks then + Result := FSocksLocalIP + else + Result := inherited GetLocalSinIP; +end; + +function TTCPBlockSocket.GetRemoteSinIP: string; +begin + if FUsingSocks then + Result := FSocksRemoteIP + else + if FHTTPTunnel then + Result := FHTTPTunnelRemoteIP + else + Result := inherited GetRemoteSinIP; +end; + +function TTCPBlockSocket.GetLocalSinPort: Integer; +begin + if FUsingSocks then + Result := StrToIntDef(FSocksLocalPort, 0) + else + Result := inherited GetLocalSinPort; +end; + +function TTCPBlockSocket.GetRemoteSinPort: Integer; +begin + if FUsingSocks then + Result := ResolvePort(FSocksRemotePort) + else + if FHTTPTunnel then + Result := StrToIntDef(FHTTPTunnelRemotePort, 0) + else + Result := inherited GetRemoteSinPort; +end; + +function TTCPBlockSocket.RecvBuffer(Buffer: TMemory; Len: Integer): Integer; +begin + if FSSL.SSLEnabled then + begin + Result := 0; + if TestStopFlag then + Exit; + ResetLastError; + LimitBandwidth(Len, FMaxRecvBandwidth, FNextRecv); + Result := FSSL.RecvBuffer(Buffer, Len); + if FSSL.LastError <> 0 then + FLastError := WSASYSNOTREADY; + ExceptCheck; + Inc(FRecvCounter, Result); + DoStatus(HR_ReadCount, IntToStr(Result)); + DoMonitor(False, Buffer, Result); + DoReadFilter(Buffer, Result); + end + else + Result := inherited RecvBuffer(Buffer, Len); +end; + +function TTCPBlockSocket.SendBuffer(Buffer: TMemory; Length: Integer): Integer; +var + x, y: integer; + l, r: integer; +{$IFNDEF CIL} + p: Pointer; +{$ENDIF} +begin + if FSSL.SSLEnabled then + begin + Result := 0; + if TestStopFlag then + Exit; + ResetLastError; + DoMonitor(True, Buffer, Length); +{$IFDEF CIL} + Result := FSSL.SendBuffer(Buffer, Length); + if FSSL.LastError <> 0 then + FLastError := WSASYSNOTREADY; + Inc(FSendCounter, Result); + DoStatus(HR_WriteCount, IntToStr(Result)); +{$ELSE} + l := Length; + x := 0; + while x < l do + begin + y := l - x; + if y > FSendMaxChunk then + y := FSendMaxChunk; + if y > 0 then + begin + LimitBandwidth(y, FMaxSendBandwidth, FNextsend); + p := IncPoint(Buffer, x); + r := FSSL.SendBuffer(p, y); + if FSSL.LastError <> 0 then + FLastError := WSASYSNOTREADY; + if Flasterror <> 0 then + Break; + Inc(x, r); + Inc(Result, r); + Inc(FSendCounter, r); + DoStatus(HR_WriteCount, IntToStr(r)); + end + else + break; + end; +{$ENDIF} + ExceptCheck; + end + else + Result := inherited SendBuffer(Buffer, Length); +end; + +function TTCPBlockSocket.SSLAcceptConnection: Boolean; +begin + ResetLastError; + if not FSSL.Accept then + FLastError := WSASYSNOTREADY; + ExceptCheck; + Result := FLastError = 0; +end; + +function TTCPBlockSocket.GetSocketType: integer; +begin + Result := integer(SOCK_STREAM); +end; + +function TTCPBlockSocket.GetSocketProtocol: integer; +begin + Result := integer(IPPROTO_TCP); +end; + +{======================================================================} + +function TICMPBlockSocket.GetSocketType: integer; +begin + Result := integer(SOCK_RAW); +end; + +function TICMPBlockSocket.GetSocketProtocol: integer; +begin + if FIP6Used then + Result := integer(IPPROTO_ICMPV6) + else + Result := integer(IPPROTO_ICMP); +end; + +{======================================================================} + +function TRAWBlockSocket.GetSocketType: integer; +begin + Result := integer(SOCK_RAW); +end; + +function TRAWBlockSocket.GetSocketProtocol: integer; +begin + Result := integer(IPPROTO_RAW); +end; + +{======================================================================} + +function TPGMmessageBlockSocket.GetSocketType: integer; +begin + Result := integer(SOCK_RDM); +end; + +function TPGMmessageBlockSocket.GetSocketProtocol: integer; +begin + Result := integer(IPPROTO_RM); +end; + +{======================================================================} + +function TPGMstreamBlockSocket.GetSocketType: integer; +begin + Result := integer(SOCK_STREAM); +end; + +function TPGMstreamBlockSocket.GetSocketProtocol: integer; +begin + Result := integer(IPPROTO_RM); +end; + +{======================================================================} + +constructor TSynaClient.Create; +begin + inherited Create; + FIPInterface := cAnyHost; + FTargetHost := cLocalhost; + FTargetPort := cAnyPort; + FTimeout := 5000; + FUsername := ''; + FPassword := ''; +end; + +{======================================================================} + +constructor TCustomSSL.Create(const Value: TTCPBlockSocket); +begin + inherited Create; + FSocket := Value; + FSSLEnabled := False; + FUsername := ''; + FPassword := ''; + FLastError := 0; + FLastErrorDesc := ''; + FVerifyCert := False; + FSSLType := LT_all; + FKeyPassword := ''; + FCiphers := ''; + FCertificateFile := ''; + FPrivateKeyFile := ''; + FCertCAFile := ''; + FCertCA := ''; + FTrustCertificate := ''; + FTrustCertificateFile := ''; + FCertificate := ''; + FPrivateKey := ''; + FPFX := ''; + FPFXfile := ''; + FSSHChannelType := ''; + FSSHChannelArg1 := ''; + FSSHChannelArg2 := ''; + FCertComplianceLevel := -1; //default + FSNIHost := ''; +end; + +procedure TCustomSSL.Assign(const Value: TCustomSSL); +begin + FUsername := Value.Username; + FPassword := Value.Password; + FVerifyCert := Value.VerifyCert; + FSSLType := Value.SSLType; + FKeyPassword := Value.KeyPassword; + FCiphers := Value.Ciphers; + FCertificateFile := Value.CertificateFile; + FPrivateKeyFile := Value.PrivateKeyFile; + FCertCAFile := Value.CertCAFile; + FCertCA := Value.CertCA; + FTrustCertificate := Value.TrustCertificate; + FTrustCertificateFile := Value.TrustCertificateFile; + FCertificate := Value.Certificate; + FPrivateKey := Value.PrivateKey; + FPFX := Value.PFX; + FPFXfile := Value.PFXfile; + FCertComplianceLevel := Value.CertComplianceLevel; + FSNIHost := Value.FSNIHost; +end; + +procedure TCustomSSL.ReturnError; +begin + FLastError := -1; + FLastErrorDesc := 'SSL/TLS support is not compiled!'; +end; + +function TCustomSSL.LibVersion: String; +begin + Result := ''; +end; + +function TCustomSSL.LibName: String; +begin + Result := ''; +end; + +function TCustomSSL.CreateSelfSignedCert(Host: string): Boolean; +begin + Result := False; +end; + +function TCustomSSL.Connect: boolean; +begin + ReturnError; + Result := False; +end; + +function TCustomSSL.Accept: boolean; +begin + ReturnError; + Result := False; +end; + +function TCustomSSL.Shutdown: boolean; +begin + ReturnError; + Result := False; +end; + +function TCustomSSL.BiShutdown: boolean; +begin + ReturnError; + Result := False; +end; + +function TCustomSSL.SendBuffer(Buffer: TMemory; Len: Integer): Integer; +begin + ReturnError; + Result := integer(SOCKET_ERROR); +end; + +procedure TCustomSSL.SetCertCAFile(const Value: string); +begin + FCertCAFile := Value; +end; + +function TCustomSSL.RecvBuffer(Buffer: TMemory; Len: Integer): Integer; +begin + ReturnError; + Result := integer(SOCKET_ERROR); +end; + +function TCustomSSL.WaitingData: Integer; +begin + ReturnError; + Result := 0; +end; + +function TCustomSSL.GetSSLVersion: string; +begin + Result := ''; +end; + +function TCustomSSL.GetPeerSubject: string; +begin + Result := ''; +end; + +function TCustomSSL.GetPeerSerialNo: integer; +begin + Result := -1; +end; + +function TCustomSSL.GetPeerName: string; +begin + Result := ''; +end; + +function TCustomSSL.GetPeerNameHash: cardinal; +begin + Result := 0; +end; + +function TCustomSSL.GetPeerIssuer: string; +begin + Result := ''; +end; + +function TCustomSSL.GetPeerFingerprint: string; +begin + Result := ''; +end; + +function TCustomSSL.GetCertInfo: string; +begin + Result := ''; +end; + +function TCustomSSL.GetCipherName: string; +begin + Result := ''; +end; + +function TCustomSSL.GetCipherBits: integer; +begin + Result := 0; +end; + +function TCustomSSL.GetCipherAlgBits: integer; +begin + Result := 0; +end; + +function TCustomSSL.GetVerifyCert: integer; +begin + Result := 1; +end; + +function TCustomSSL.DoVerifyCert:boolean; +begin + if assigned(OnVerifyCert) then + begin + result:=OnVerifyCert(Self); + end + else + result:=true; +end; + + +{======================================================================} + +function TSSLNone.LibVersion: String; +begin + Result := 'Without SSL support'; +end; + +function TSSLNone.LibName: String; +begin + Result := 'ssl_none'; +end; + +{======================================================================} + +initialization +begin +{$IFDEF ONCEWINSOCK} + if not InitSocketInterface(DLLStackName) then + begin + e := ESynapseError.Create('Error loading Socket interface (' + DLLStackName + ')!'); + e.ErrorCode := 0; + e.ErrorMessage := 'Error loading Socket interface (' + DLLStackName + ')!'; + raise e; + end; + synsock.WSAStartup(WinsockLevel, WsaDataOnce); +{$ENDIF} +end; + +finalization +begin +{$IFDEF ONCEWINSOCK} + synsock.WSACleanup; + DestroySocketInterface; +{$ENDIF} +end; + +end. diff --git a/synapse/clamsend.pas b/synapse/clamsend.pas new file mode 100644 index 0000000..8d3c2d6 --- /dev/null +++ b/synapse/clamsend.pas @@ -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. diff --git a/synapse/dnssend.pas b/synapse/dnssend.pas new file mode 100644 index 0000000..84c14cc --- /dev/null +++ b/synapse/dnssend.pas @@ -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. diff --git a/synapse/ftpsend.pas b/synapse/ftpsend.pas new file mode 100644 index 0000000..0d36835 --- /dev/null +++ b/synapse/ftpsend.pas @@ -0,0 +1,1964 @@ +{==============================================================================| +| Project : Ararat Synapse | 004.000.000 | +|==============================================================================| +| Content: FTP 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-2010. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +| Petr Esner <petr.esner@atlas.cz> | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +{: @abstract(FTP client protocol) + +Used RFC: RFC-959, RFC-2228, RFC-2428 +} + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$H+} +{$TYPEINFO ON}// Borland changed defualt Visibility from Public to Published + // and it requires RTTI to be generated $M+ +{$M+} + +{$IFDEF UNICODE} + {$WARN IMPLICIT_STRING_CAST OFF} + {$WARN IMPLICIT_STRING_CAST_LOSS OFF} +{$ENDIF} + +unit ftpsend; + +interface + +uses + SysUtils, Classes, + blcksock, synautil, synaip, synsock; + +const + cFtpProtocol = '21'; + cFtpDataProtocol = '20'; + + {:Terminating value for TLogonActions} + FTP_OK = 255; + {:Terminating value for TLogonActions} + FTP_ERR = 254; + +type + {:Array for holding definition of logon sequence.} + TLogonActions = array [0..17] of byte; + + {:Procedural type for OnStatus event. Sender is calling @link(TFTPSend) object. + Value is FTP command or reply to this comand. (if it is reply, Response + is @True).} + TFTPStatus = procedure(Sender: TObject; Response: Boolean; + const Value: string) of object; + + {: @abstract(Object for holding file information) parsed from directory + listing of FTP server.} + TFTPListRec = class(TObject) + private + FFileName: String; + FDirectory: Boolean; + FReadable: Boolean; + FFileSize: int64; + FFileTime: TDateTime; + FOriginalLine: string; + FMask: string; + FPermission: String; + public + {: You can assign another TFTPListRec to this object.} + procedure Assign(Value: TFTPListRec); virtual; + {:name of file} + property FileName: string read FFileName write FFileName; + {:if name is subdirectory not file.} + property Directory: Boolean read FDirectory write FDirectory; + {:if you have rights to read} + property Readable: Boolean read FReadable write FReadable; + {:size of file in bytes} + property FileSize: int64 read FFileSize write FFileSize; + {:date and time of file. Local server timezone is used. Any timezone + conversions was not done!} + property FileTime: TDateTime read FFileTime write FFileTime; + {:original unparsed line} + property OriginalLine: string read FOriginalLine write FOriginalLine; + {:mask what was used for parsing} + property Mask: string read FMask write FMask; + {:permission string (depending on used mask!)} + property Permission: string read FPermission write FPermission; + end; + + {:@abstract(This is TList of TFTPListRec objects.) + This object is used for holding lististing of all files information in listed + directory on FTP server.} + TFTPList = class(TObject) + protected + FList: TList; + FLines: TStringList; + FMasks: TStringList; + FUnparsedLines: TStringList; + Monthnames: string; + BlockSize: string; + DirFlagValue: string; + FileName: string; + VMSFileName: string; + Day: string; + Month: string; + ThreeMonth: string; + YearTime: string; + Year: string; + Hours: string; + HoursModif: Ansistring; + Minutes: string; + Seconds: string; + Size: Ansistring; + Permissions: Ansistring; + DirFlag: string; + function GetListItem(Index: integer): TFTPListRec; virtual; + function ParseEPLF(Value: string): Boolean; virtual; + procedure ClearStore; virtual; + function ParseByMask(Value, NextValue, Mask: ansistring): Integer; virtual; + function CheckValues: Boolean; virtual; + procedure FillRecord(const Value: TFTPListRec); virtual; + public + {:Constructor. You not need create this object, it is created by TFTPSend + class as their property.} + constructor Create; + destructor Destroy; override; + + {:Clear list.} + procedure Clear; virtual; + + {:count of holded @link(TFTPListRec) objects} + function Count: integer; virtual; + + {:Assigns one list to another} + procedure Assign(Value: TFTPList); virtual; + + {:try to parse raw directory listing in @link(lines) to list of + @link(TFTPListRec).} + procedure ParseLines; virtual; + + {:By this property you have access to list of @link(TFTPListRec). + This is for compatibility only. Please, use @link(Items) instead.} + property List: TList read FList; + + {:By this property you have access to list of @link(TFTPListRec).} + property Items[Index: Integer]: TFTPListRec read GetListItem; default; + + {:Set of lines with RAW directory listing for @link(parseLines)} + property Lines: TStringList read FLines; + + {:Set of masks for directory listing parser. It is predefined by default, + however you can modify it as you need. (for example, you can add your own + definition mask.) Mask is same as mask used in TotalCommander.} + property Masks: TStringList read FMasks; + + {:After @link(ParseLines) it holding lines what was not sucessfully parsed.} + property UnparsedLines: TStringList read FUnparsedLines; + end; + + {:@abstract(Implementation of FTP protocol.) + Note: Are you missing properties for setting Username and Password? Look to + parent @link(TSynaClient) object! (Username and Password have default values + for "anonymous" FTP login) + + Are you missing properties for specify server address and port? Look to + parent @link(TSynaClient) too!} + TFTPSend = class(TSynaClient) + protected + FOnStatus: TFTPStatus; + FSock: TTCPBlockSocket; + FDSock: TTCPBlockSocket; + FResultCode: Integer; + FResultString: string; + FFullResult: TStringList; + FAccount: string; + FFWHost: string; + FFWPort: string; + FFWUsername: string; + FFWPassword: string; + FFWMode: integer; + FDataStream: TMemoryStream; + FDataIP: string; + FDataPort: string; + FDirectFile: Boolean; + FDirectFileName: string; + FCanResume: Boolean; + FPassiveMode: Boolean; + FForceDefaultPort: Boolean; + FForceOldPort: Boolean; + FFtpList: TFTPList; + FBinaryMode: Boolean; + FAutoTLS: Boolean; + FIsTLS: Boolean; + FIsDataTLS: Boolean; + FTLSonData: Boolean; + FFullSSL: Boolean; + function Auth(Mode: integer): Boolean; virtual; + function Connect: Boolean; virtual; + function InternalStor(const Command: string; RestoreAt: int64): Boolean; virtual; + function DataSocket: Boolean; virtual; + function AcceptDataSocket: Boolean; virtual; + procedure DoStatus(Response: Boolean; const Value: string); virtual; + public + {:Custom definition of login sequence. You can use this when you set + @link(FWMode) to value -1.} + CustomLogon: TLogonActions; + + constructor Create; + destructor Destroy; override; + + {:Waits and read FTP server response. You need this only in special cases!} + function ReadResult: Integer; virtual; + + {:Parse remote side information of data channel from value string (returned + by PASV command). This function you need only in special cases!} + procedure ParseRemote(Value: string); virtual; + + {:Parse remote side information of data channel from value string (returned + by EPSV command). This function you need only in special cases!} + procedure ParseRemoteEPSV(Value: string); virtual; + + {:Send Value as FTP command to FTP server. Returned result code is result of + this function. + This command is good for sending site specific command, or non-standard + commands.} + function FTPCommand(const Value: string): integer; virtual; + + {:Connect and logon to FTP server. If you specify any FireWall, connect to + firewall and throw them connect to FTP server. Login sequence depending on + @link(FWMode).} + function Login: Boolean; virtual; + + {:Logoff and disconnect from FTP server.} + function Logout: Boolean; virtual; + + {:Break current transmission of data. (You can call this method from + Sock.OnStatus event, or from another thread.)} + procedure Abort; virtual; + + {:Break current transmission of data. It is same as Abort, but it send abort + telnet commands prior ABOR FTP command. Some servers need it. (You can call + this method from Sock.OnStatus event, or from another thread.)} + procedure TelnetAbort; virtual; + + {:Download directory listing of Directory on FTP server. If Directory is + empty string, download listing of current working directory. + If NameList is @true, download only names of files in directory. + (internally use NLST command instead LIST command) + If NameList is @false, returned list is also parsed to @link(FTPList) + property.} + function List(Directory: string; NameList: Boolean): Boolean; virtual; + + {:Read data from FileName on FTP server. If Restore is @true and server + supports resume dowloads, download is resumed. (received is only rest + of file)} + function RetrieveFile(const FileName: string; Restore: Boolean): Boolean; virtual; + + {:Send data to FileName on FTP server. If Restore is @true and server + supports resume upload, upload is resumed. (send only rest of file) + In this case if remote file is same length as local file, nothing will be + done. If remote file is larger then local, resume is disabled and file is + transfered from begin!} + function StoreFile(const FileName: string; Restore: Boolean): Boolean; virtual; + + {:Send data to FTP server and assing unique name for this file.} + function StoreUniqueFile: Boolean; virtual; + + {:Append data to FileName on FTP server.} + function AppendFile(const FileName: string): Boolean; virtual; + + {:Rename on FTP server file with OldName to NewName.} + function RenameFile(const OldName, NewName: string): Boolean; virtual; + + {:Delete file FileName on FTP server.} + function DeleteFile(const FileName: string): Boolean; virtual; + + {:Return size of Filename file on FTP server. If command failed (i.e. not + implemented), return -1.} + function FileSize(const FileName: string): int64; virtual; + + {:Send NOOP command to FTP server for preserve of disconnect by inactivity + timeout.} + function NoOp: Boolean; virtual; + + {:Change currect working directory to Directory on FTP server.} + function ChangeWorkingDir(const Directory: string): Boolean; virtual; + + {:walk to upper directory on FTP server.} + function ChangeToParentDir: Boolean; virtual; + + {:walk to root directory on FTP server. (May not work with all servers properly!)} + function ChangeToRootDir: Boolean; virtual; + + {:Delete Directory on FTP server.} + function DeleteDir(const Directory: string): Boolean; virtual; + + {:Create Directory on FTP server.} + function CreateDir(const Directory: string): Boolean; virtual; + + {:Return current working directory on FTP server.} + function GetCurrentDir: String; virtual; + + {:Establish data channel to FTP server and retrieve data. + This function you need only in special cases, i.e. when you need to implement + some special unsupported FTP command!} + function DataRead(const DestStream: TStream): Boolean; virtual; + + {:Establish data channel to FTP server and send data. + This function you need only in special cases, i.e. when you need to implement + some special unsupported FTP command.} + function DataWrite(const SourceStream: TStream): Boolean; virtual; + published + {:After FTP command contains result number of this operation.} + property ResultCode: Integer read FResultCode; + + {:After FTP command contains main line of result.} + property ResultString: string read FResultString; + + {:After any FTP command it contains all lines of FTP server reply.} + property FullResult: TStringList read FFullResult; + + {:Account information used in some cases inside login sequence.} + property Account: string read FAccount Write FAccount; + + {:Address of firewall. If empty string (default), firewall not used.} + property FWHost: string read FFWHost Write FFWHost; + + {:port of firewall. standard value is same port as ftp server used. (21)} + property FWPort: string read FFWPort Write FFWPort; + + {:Username for login to firewall. (if needed)} + property FWUsername: string read FFWUsername Write FFWUsername; + + {:password for login to firewall. (if needed)} + property FWPassword: string read FFWPassword Write FFWPassword; + + {:Type of Firewall. Used only if you set some firewall address. Supported + predefined firewall login sequences are described by comments in source + file where you can see pseudocode decribing each sequence.} + property FWMode: integer read FFWMode Write FFWMode; + + {:Socket object used for TCP/IP operation on control channel. Good for + seting OnStatus hook, etc.} + property Sock: TTCPBlockSocket read FSock; + + {:Socket object used for TCP/IP operation on data channel. Good for seting + OnStatus hook, etc.} + property DSock: TTCPBlockSocket read FDSock; + + {:If you not use @link(DirectFile) mode, all data transfers is made to or + from this stream.} + property DataStream: TMemoryStream read FDataStream; + + {:After data connection is established, contains remote side IP of this + connection.} + property DataIP: string read FDataIP; + + {:After data connection is established, contains remote side port of this + connection.} + property DataPort: string read FDataPort; + + {:Mode of data handling by data connection. If @False, all data operations + are made to or from @link(DataStream) TMemoryStream. + If @true, data operations is made directly to file in your disk. (filename + is specified by @link(DirectFileName) property.) Dafault is @False!} + property DirectFile: Boolean read FDirectFile Write FDirectFile; + + {:Filename for direct disk data operations.} + property DirectFileName: string read FDirectFileName Write FDirectFileName; + + {:Indicate after @link(Login) if remote server support resume downloads and + uploads.} + property CanResume: Boolean read FCanResume; + + {:If true (default value), all transfers is made by passive method. + It is safer method for various firewalls.} + property PassiveMode: Boolean read FPassiveMode Write FPassiveMode; + + {:Force to listen for dataconnection on standard port (20). Default is @false, + dataconnections will be made to any non-standard port reported by PORT FTP + command. This setting is not used, if you use passive mode.} + property ForceDefaultPort: Boolean read FForceDefaultPort Write FForceDefaultPort; + + {:When is @true, then is disabled EPSV and EPRT support. However without this + commands you cannot use IPv6! (Disabling of this commands is needed only + when you are behind some crap firewall/NAT.} + property ForceOldPort: Boolean read FForceOldPort Write FForceOldPort; + + {:You may set this hook for monitoring FTP commands and replies.} + property OnStatus: TFTPStatus read FOnStatus write FOnStatus; + + {:After LIST command is here parsed list of files in given directory.} + property FtpList: TFTPList read FFtpList; + + {:if @true (default), then data transfers is in binary mode. If this is set + to @false, then ASCII mode is used.} + property BinaryMode: Boolean read FBinaryMode Write FBinaryMode; + + {:if is true, then if server support upgrade to SSL/TLS mode, then use them.} + property AutoTLS: Boolean read FAutoTLS Write FAutoTLS; + + {:if server listen on SSL/TLS port, then you set this to true.} + property FullSSL: Boolean read FFullSSL Write FFullSSL; + + {:Signalise, if control channel is in SSL/TLS mode.} + property IsTLS: Boolean read FIsTLS; + + {:Signalise, if data transfers is in SSL/TLS mode.} + property IsDataTLS: Boolean read FIsDataTLS; + + {:If @true (default), then try to use SSL/TLS on data transfers too. + If @false, then SSL/TLS is used only for control connection.} + property TLSonData: Boolean read FTLSonData write FTLSonData; + end; + +{:A very useful function, and example of use can be found in the TFtpSend object. + Dowload specified file from FTP server to LocalFile.} +function FtpGetFile(const IP, Port, FileName, LocalFile, + User, Pass: string): Boolean; + +{:A very useful function, and example of use can be found in the TFtpSend object. + Upload specified LocalFile to FTP server.} +function FtpPutFile(const IP, Port, FileName, LocalFile, + User, Pass: string): Boolean; + +{:A very useful function, and example of use can be found in the TFtpSend object. + Initiate transfer of file between two FTP servers.} +function FtpInterServerTransfer( + const FromIP, FromPort, FromFile, FromUser, FromPass: string; + const ToIP, ToPort, ToFile, ToUser, ToPass: string): Boolean; + +implementation + +constructor TFTPSend.Create; +begin + inherited Create; + FFullResult := TStringList.Create; + FDataStream := TMemoryStream.Create; + FSock := TTCPBlockSocket.Create; + FSock.Owner := self; + FSock.ConvertLineEnd := True; + FDSock := TTCPBlockSocket.Create; + FDSock.Owner := self; + FFtpList := TFTPList.Create; + FTimeout := 300000; + FTargetPort := cFtpProtocol; + FUsername := 'anonymous'; + FPassword := 'anonymous@' + FSock.LocalName; + FDirectFile := False; + FPassiveMode := True; + FForceDefaultPort := False; + FForceOldPort := false; + FAccount := ''; + FFWHost := ''; + FFWPort := cFtpProtocol; + FFWUsername := ''; + FFWPassword := ''; + FFWMode := 0; + FBinaryMode := True; + FAutoTLS := False; + FFullSSL := False; + FIsTLS := False; + FIsDataTLS := False; + FTLSonData := True; +end; + +destructor TFTPSend.Destroy; +begin + FDSock.Free; + FSock.Free; + FFTPList.Free; + FDataStream.Free; + FFullResult.Free; + inherited Destroy; +end; + +procedure TFTPSend.DoStatus(Response: Boolean; const Value: string); +begin + if assigned(OnStatus) then + OnStatus(Self, Response, Value); +end; + +function TFTPSend.ReadResult: Integer; +var + s, c: AnsiString; +begin + FFullResult.Clear; + c := ''; + repeat + s := FSock.RecvString(FTimeout); + if c = '' then + if length(s) > 3 then + if s[4] in [' ', '-'] then + c :=Copy(s, 1, 3); + FResultString := s; + FFullResult.Add(s); + DoStatus(True, s); + if FSock.LastError <> 0 then + Break; + until (c <> '') and (Pos(c + ' ', s) = 1); + Result := StrToIntDef(c, 0); + FResultCode := Result; +end; + +function TFTPSend.FTPCommand(const Value: string): integer; +begin + FSock.Purge; + FSock.SendString(Value + CRLF); + DoStatus(False, Value); + Result := ReadResult; +end; + +// based on idea by Petr Esner <petr.esner@atlas.cz> +function TFTPSend.Auth(Mode: integer): Boolean; +const + //if not USER <username> then + // if not PASS <password> then + // if not ACCT <account> then ERROR! + //OK! + Action0: TLogonActions = + (0, FTP_OK, 3, + 1, FTP_OK, 6, + 2, FTP_OK, FTP_ERR, + 0, 0, 0, 0, 0, 0, 0, 0, 0); + + //if not USER <FWusername> then + // if not PASS <FWPassword> then ERROR! + //if SITE <FTPServer> then ERROR! + //if not USER <username> then + // if not PASS <password> then + // if not ACCT <account> then ERROR! + //OK! + Action1: TLogonActions = + (3, 6, 3, + 4, 6, FTP_ERR, + 5, FTP_ERR, 9, + 0, FTP_OK, 12, + 1, FTP_OK, 15, + 2, FTP_OK, FTP_ERR); + + //if not USER <FWusername> then + // if not PASS <FWPassword> then ERROR! + //if USER <UserName>'@'<FTPServer> then OK! + //if not PASS <password> then + // if not ACCT <account> then ERROR! + //OK! + Action2: TLogonActions = + (3, 6, 3, + 4, 6, FTP_ERR, + 6, FTP_OK, 9, + 1, FTP_OK, 12, + 2, FTP_OK, FTP_ERR, + 0, 0, 0); + + //if not USER <FWusername> then + // if not PASS <FWPassword> then ERROR! + //if not USER <username> then + // if not PASS <password> then + // if not ACCT <account> then ERROR! + //OK! + Action3: TLogonActions = + (3, 6, 3, + 4, 6, FTP_ERR, + 0, FTP_OK, 9, + 1, FTP_OK, 12, + 2, FTP_OK, FTP_ERR, + 0, 0, 0); + + //OPEN <FTPserver> + //if not USER <username> then + // if not PASS <password> then + // if not ACCT <account> then ERROR! + //OK! + Action4: TLogonActions = + (7, 3, 3, + 0, FTP_OK, 6, + 1, FTP_OK, 9, + 2, FTP_OK, FTP_ERR, + 0, 0, 0, 0, 0, 0); + + //if USER <UserName>'@'<FTPServer> then OK! + //if not PASS <password> then + // if not ACCT <account> then ERROR! + //OK! + Action5: TLogonActions = + (6, FTP_OK, 3, + 1, FTP_OK, 6, + 2, FTP_OK, FTP_ERR, + 0, 0, 0, 0, 0, 0, 0, 0, 0); + + //if not USER <FWUserName>@<FTPServer> then + // if not PASS <FWPassword> then ERROR! + //if not USER <username> then + // if not PASS <password> then + // if not ACCT <account> then ERROR! + //OK! + Action6: TLogonActions = + (8, 6, 3, + 4, 6, FTP_ERR, + 0, FTP_OK, 9, + 1, FTP_OK, 12, + 2, FTP_OK, FTP_ERR, + 0, 0, 0); + + //if USER <UserName>@<FTPServer> <FWUserName> then ERROR! + //if not PASS <password> then + // if not ACCT <account> then ERROR! + //OK! + Action7: TLogonActions = + (9, FTP_ERR, 3, + 1, FTP_OK, 6, + 2, FTP_OK, FTP_ERR, + 0, 0, 0, 0, 0, 0, 0, 0, 0); + + //if not USER <UserName>@<FWUserName>@<FTPServer> then + // if not PASS <Password>@<FWPassword> then + // if not ACCT <account> then ERROR! + //OK! + Action8: TLogonActions = + (10, FTP_OK, 3, + 11, FTP_OK, 6, + 2, FTP_OK, FTP_ERR, + 0, 0, 0, 0, 0, 0, 0, 0, 0); +var + FTPServer: string; + LogonActions: TLogonActions; + i: integer; + s: string; + x: integer; +begin + Result := False; + if FFWHost = '' then + Mode := 0; + if (FTargetPort = cFtpProtocol) or (FTargetPort = '21') then + FTPServer := FTargetHost + else + FTPServer := FTargetHost + ':' + FTargetPort; + case Mode of + -1: + LogonActions := CustomLogon; + 1: + LogonActions := Action1; + 2: + LogonActions := Action2; + 3: + LogonActions := Action3; + 4: + LogonActions := Action4; + 5: + LogonActions := Action5; + 6: + LogonActions := Action6; + 7: + LogonActions := Action7; + 8: + LogonActions := Action8; + else + LogonActions := Action0; + end; + i := 0; + repeat + case LogonActions[i] of + 0: s := 'USER ' + FUserName; + 1: s := 'PASS ' + FPassword; + 2: s := 'ACCT ' + FAccount; + 3: s := 'USER ' + FFWUserName; + 4: s := 'PASS ' + FFWPassword; + 5: s := 'SITE ' + FTPServer; + 6: s := 'USER ' + FUserName + '@' + FTPServer; + 7: s := 'OPEN ' + FTPServer; + 8: s := 'USER ' + FFWUserName + '@' + FTPServer; + 9: s := 'USER ' + FUserName + '@' + FTPServer + ' ' + FFWUserName; + 10: s := 'USER ' + FUserName + '@' + FFWUserName + '@' + FTPServer; + 11: s := 'PASS ' + FPassword + '@' + FFWPassword; + end; + x := FTPCommand(s); + x := x div 100; + if (x <> 2) and (x <> 3) then + Exit; + i := LogonActions[i + x - 1]; + case i of + FTP_ERR: + Exit; + FTP_OK: + begin + Result := True; + Exit; + end; + end; + until False; +end; + + +function TFTPSend.Connect: Boolean; +begin + FSock.CloseSocket; + FSock.Bind(FIPInterface, cAnyPort); + if FSock.LastError = 0 then + if FFWHost = '' then + FSock.Connect(FTargetHost, FTargetPort) + else + FSock.Connect(FFWHost, FFWPort); + if FSock.LastError = 0 then + if FFullSSL then + FSock.SSLDoConnect; + Result := FSock.LastError = 0; +end; + +function TFTPSend.Login: Boolean; +var + x: integer; +begin + Result := False; + FCanResume := False; + if not Connect then + Exit; + FIsTLS := FFullSSL; + FIsDataTLS := False; + repeat + x := ReadResult div 100; + until x <> 1; + if x <> 2 then + Exit; + if FAutoTLS and not(FIsTLS) then + if (FTPCommand('AUTH TLS') div 100) = 2 then + begin + FSock.SSLDoConnect; + FIsTLS := FSock.LastError = 0; + if not FIsTLS then + begin + Result := False; + Exit; + end; + end; + if not Auth(FFWMode) then + Exit; + if FIsTLS then + begin + FTPCommand('PBSZ 0'); + if FTLSonData then + FIsDataTLS := (FTPCommand('PROT P') div 100) = 2; + if not FIsDataTLS then + FTPCommand('PROT C'); + end; + FTPCommand('TYPE I'); + FTPCommand('STRU F'); + FTPCommand('MODE S'); + if FTPCommand('REST 0') = 350 then + if FTPCommand('REST 1') = 350 then + begin + FTPCommand('REST 0'); + FCanResume := True; + end; + Result := True; +end; + +function TFTPSend.Logout: Boolean; +begin + Result := (FTPCommand('QUIT') div 100) = 2; + FSock.CloseSocket; +end; + +procedure TFTPSend.ParseRemote(Value: string); +var + n: integer; + nb, ne: integer; + s: string; + x: integer; +begin + Value := trim(Value); + nb := Pos('(',Value); + ne := Pos(')',Value); + if (nb = 0) or (ne = 0) then + begin + nb:=RPos(' ',Value); + s:=Copy(Value, nb + 1, Length(Value) - nb); + end + else + begin + s:=Copy(Value,nb+1,ne-nb-1); + end; + for n := 1 to 4 do + if n = 1 then + FDataIP := Fetch(s, ',') + else + FDataIP := FDataIP + '.' + Fetch(s, ','); + x := StrToIntDef(Fetch(s, ','), 0) * 256; + x := x + StrToIntDef(Fetch(s, ','), 0); + FDataPort := IntToStr(x); +end; + +procedure TFTPSend.ParseRemoteEPSV(Value: string); +var + n: integer; + s, v: AnsiString; +begin + s := SeparateRight(Value, '('); + s := Trim(SeparateLeft(s, ')')); + Delete(s, Length(s), 1); + v := ''; + for n := Length(s) downto 1 do + if s[n] in ['0'..'9'] then + v := s[n] + v + else + Break; + FDataPort := v; + FDataIP := FTargetHost; +end; + +function TFTPSend.DataSocket: boolean; +var + s: string; +begin + Result := False; + if FIsDataTLS then + FPassiveMode := True; + if FPassiveMode then + begin + if FSock.IP6used then + s := '2' + else + s := '1'; + if FSock.IP6used and not(FForceOldPort) and ((FTPCommand('EPSV ' + s) div 100) = 2) then + begin + ParseRemoteEPSV(FResultString); + end + else + if FSock.IP6used then + Exit + else + begin + if (FTPCommand('PASV') div 100) <> 2 then + Exit; + ParseRemote(FResultString); + end; + FDSock.CloseSocket; + FDSock.Bind(FIPInterface, cAnyPort); + FDSock.Connect(FDataIP, FDataPort); + Result := FDSock.LastError = 0; + end + else + begin + FDSock.CloseSocket; + if FForceDefaultPort then + s := cFtpDataProtocol + else + s := '0'; + //data conection from same interface as command connection + FDSock.Bind(FSock.GetLocalSinIP, s); + if FDSock.LastError <> 0 then + Exit; + FDSock.SetLinger(True, 10000); + FDSock.Listen; + FDSock.GetSins; + FDataIP := FDSock.GetLocalSinIP; + FDataIP := FDSock.ResolveName(FDataIP); + FDataPort := IntToStr(FDSock.GetLocalSinPort); + if FSock.IP6used and (not FForceOldPort) then + begin + if IsIp6(FDataIP) then + s := '2' + else + s := '1'; + s := 'EPRT |' + s +'|' + FDataIP + '|' + FDataPort + '|'; + Result := (FTPCommand(s) div 100) = 2; + end; + if not Result and IsIP(FDataIP) then + begin + s := ReplaceString(FDataIP, '.', ','); + s := 'PORT ' + s + ',' + IntToStr(FDSock.GetLocalSinPort div 256) + + ',' + IntToStr(FDSock.GetLocalSinPort mod 256); + Result := (FTPCommand(s) div 100) = 2; + end; + end; +end; + +function TFTPSend.AcceptDataSocket: Boolean; +var + x: TSocket; +begin + if FPassiveMode then + Result := True + else + begin + Result := False; + if FDSock.CanRead(FTimeout) then + begin + x := FDSock.Accept; + if not FDSock.UsingSocks then + FDSock.CloseSocket; + FDSock.Socket := x; + Result := True; + end; + end; + if Result and FIsDataTLS then + begin + FDSock.SSL.Assign(FSock.SSL); + FDSock.SSLDoConnect; + Result := FDSock.LastError = 0; + end; +end; + +function TFTPSend.DataRead(const DestStream: TStream): Boolean; +var + x: integer; +begin + Result := False; + try + if not AcceptDataSocket then + Exit; + FDSock.RecvStreamRaw(DestStream, FTimeout); + FDSock.CloseSocket; + x := ReadResult; + Result := (x div 100) = 2; + finally + FDSock.CloseSocket; + end; +end; + +function TFTPSend.DataWrite(const SourceStream: TStream): Boolean; +var + x: integer; + b: Boolean; +begin + Result := False; + try + if not AcceptDataSocket then + Exit; + FDSock.SendStreamRaw(SourceStream); + b := FDSock.LastError = 0; + FDSock.CloseSocket; + x := ReadResult; + Result := b and ((x div 100) = 2); + finally + FDSock.CloseSocket; + end; +end; + +function TFTPSend.List(Directory: string; NameList: Boolean): Boolean; +var + x: integer; +begin + Result := False; + FDataStream.Clear; + FFTPList.Clear; + if Directory <> '' then + Directory := ' ' + Directory; + FTPCommand('TYPE A'); + if not DataSocket then + Exit; + if NameList then + x := FTPCommand('NLST' + Directory) + else + x := FTPCommand('LIST' + Directory); + if (x div 100) <> 1 then + Exit; + Result := DataRead(FDataStream); + if (not NameList) and Result then + begin + FDataStream.Position := 0; + FFTPList.Lines.LoadFromStream(FDataStream); + FFTPList.ParseLines; + end; + FDataStream.Position := 0; +end; + +function TFTPSend.RetrieveFile(const FileName: string; Restore: Boolean): Boolean; +var + RetrStream: TStream; +begin + Result := False; + if FileName = '' then + Exit; + if not DataSocket then + Exit; + Restore := Restore and FCanResume; + if FDirectFile then + if Restore and FileExists(FDirectFileName) then + RetrStream := TFileStream.Create(FDirectFileName, + fmOpenReadWrite or fmShareExclusive) + else + RetrStream := TFileStream.Create(FDirectFileName, + fmCreate or fmShareDenyWrite) + else + RetrStream := FDataStream; + try + if FBinaryMode then + FTPCommand('TYPE I') + else + FTPCommand('TYPE A'); + if Restore then + begin + RetrStream.Position := RetrStream.Size; + if (FTPCommand('REST ' + IntToStr(RetrStream.Size)) div 100) <> 3 then + Exit; + end + else + if RetrStream is TMemoryStream then + TMemoryStream(RetrStream).Clear; + if (FTPCommand('RETR ' + FileName) div 100) <> 1 then + Exit; + Result := DataRead(RetrStream); + if not FDirectFile then + RetrStream.Position := 0; + finally + if FDirectFile then + RetrStream.Free; + end; +end; + +function TFTPSend.InternalStor(const Command: string; RestoreAt: int64): Boolean; +var + SendStream: TStream; + StorSize: int64; +begin + Result := False; + if FDirectFile then + if not FileExists(FDirectFileName) then + Exit + else + SendStream := TFileStream.Create(FDirectFileName, + fmOpenRead or fmShareDenyWrite) + else + SendStream := FDataStream; + try + if not DataSocket then + Exit; + if FBinaryMode then + FTPCommand('TYPE I') + else + FTPCommand('TYPE A'); + StorSize := SendStream.Size; + if not FCanResume then + RestoreAt := 0; + if (StorSize > 0) and (RestoreAt = StorSize) then + begin + Result := True; + Exit; + end; + if RestoreAt > StorSize then + RestoreAt := 0; + FTPCommand('ALLO ' + IntToStr(StorSize - RestoreAt)); + if FCanResume then + if (FTPCommand('REST ' + IntToStr(RestoreAt)) div 100) <> 3 then + Exit; + SendStream.Position := RestoreAt; + if (FTPCommand(Command) div 100) <> 1 then + Exit; + Result := DataWrite(SendStream); + finally + if FDirectFile then + SendStream.Free; + end; +end; + +function TFTPSend.StoreFile(const FileName: string; Restore: Boolean): Boolean; +var + RestoreAt: int64; +begin + Result := False; + if FileName = '' then + Exit; + RestoreAt := 0; + Restore := Restore and FCanResume; + if Restore then + begin + RestoreAt := Self.FileSize(FileName); + if RestoreAt < 0 then + RestoreAt := 0; + end; + Result := InternalStor('STOR ' + FileName, RestoreAt); +end; + +function TFTPSend.StoreUniqueFile: Boolean; +begin + Result := InternalStor('STOU', 0); +end; + +function TFTPSend.AppendFile(const FileName: string): Boolean; +begin + Result := False; + if FileName = '' then + Exit; + Result := InternalStor('APPE ' + FileName, 0); +end; + +function TFTPSend.NoOp: Boolean; +begin + Result := (FTPCommand('NOOP') div 100) = 2; +end; + +function TFTPSend.RenameFile(const OldName, NewName: string): Boolean; +begin + Result := False; + if (FTPCommand('RNFR ' + OldName) div 100) <> 3 then + Exit; + Result := (FTPCommand('RNTO ' + NewName) div 100) = 2; +end; + +function TFTPSend.DeleteFile(const FileName: string): Boolean; +begin + Result := (FTPCommand('DELE ' + FileName) div 100) = 2; +end; + +function TFTPSend.FileSize(const FileName: string): int64; +var + s: string; +begin + Result := -1; + if (FTPCommand('SIZE ' + FileName) div 100) = 2 then + begin + s := Trim(SeparateRight(ResultString, ' ')); + s := Trim(SeparateLeft(s, ' ')); + {$IFDEF VER100} + Result := StrToIntDef(s, -1); + {$ELSE} + Result := StrToInt64Def(s, -1); + {$ENDIF} + end; +end; + +function TFTPSend.ChangeWorkingDir(const Directory: string): Boolean; +begin + Result := (FTPCommand('CWD ' + Directory) div 100) = 2; +end; + +function TFTPSend.ChangeToParentDir: Boolean; +begin + Result := (FTPCommand('CDUP') div 100) = 2; +end; + +function TFTPSend.ChangeToRootDir: Boolean; +begin + Result := ChangeWorkingDir('/'); +end; + +function TFTPSend.DeleteDir(const Directory: string): Boolean; +begin + Result := (FTPCommand('RMD ' + Directory) div 100) = 2; +end; + +function TFTPSend.CreateDir(const Directory: string): Boolean; +begin + Result := (FTPCommand('MKD ' + Directory) div 100) = 2; +end; + +function TFTPSend.GetCurrentDir: String; +begin + Result := ''; + if (FTPCommand('PWD') div 100) = 2 then + begin + Result := SeparateRight(FResultString, '"'); + Result := Trim(Separateleft(Result, '"')); + end; +end; + +procedure TFTPSend.Abort; +begin + FSock.SendString('ABOR' + CRLF); + FDSock.StopFlag := True; +end; + +procedure TFTPSend.TelnetAbort; +begin + FSock.SendString(#$FF + #$F4 + #$FF + #$F2); + Abort; +end; + +{==============================================================================} + +procedure TFTPListRec.Assign(Value: TFTPListRec); +begin + FFileName := Value.FileName; + FDirectory := Value.Directory; + FReadable := Value.Readable; + FFileSize := Value.FileSize; + FFileTime := Value.FileTime; + FOriginalLine := Value.OriginalLine; + FMask := Value.Mask; +end; + +constructor TFTPList.Create; +begin + inherited Create; + FList := TList.Create; + FLines := TStringList.Create; + FMasks := TStringList.Create; + FUnparsedLines := TStringList.Create; + //various UNIX + FMasks.add('pppppppppp $!!!S*$TTT$DD$hh mm ss$YYYY$n*'); + FMasks.add('pppppppppp $!!!S*$DD$TTT$hh mm ss$YYYY$n*'); + FMasks.add('pppppppppp $!!!S*$TTT$DD$UUUUU$n*'); //mostly used UNIX format + FMasks.add('pppppppppp $!!!S*$DD$TTT$UUUUU$n*'); + //MacOS + FMasks.add('pppppppppp $!!S*$TTT$DD$UUUUU$n*'); + FMasks.add('pppppppppp $!S*$TTT$DD$UUUUU$n*'); + //Novell + FMasks.add('d $!S*$TTT$DD$UUUUU$n*'); + //Windows + FMasks.add('MM DD YY hh mmH !S* n*'); + FMasks.add('MM DD YY hh mmH $ d!n*'); + FMasks.add('MM DD YYYY hh mmH !S* n*'); + FMasks.add('MM DD YYYY hh mmH $ d!n*'); + FMasks.add('DD MM YYYY hh mmH !S* n*'); + FMasks.add('DD MM YYYY hh mmH $ d!n*'); + //VMS + FMasks.add('v*$ DD TTT YYYY hh mm'); + FMasks.add('v*$!DD TTT YYYY hh mm'); + FMasks.add('n*$ YYYY MM DD hh mm$S*'); + //AS400 + FMasks.add('!S*$MM DD YY hh mm ss !n*'); + FMasks.add('!S*$DD MM YY hh mm ss !n*'); + FMasks.add('n*!S*$MM DD YY hh mm ss d'); + FMasks.add('n*!S*$DD MM YY hh mm ss d'); + //VxWorks + FMasks.add('$S* TTT DD YYYY hh mm ss $n* $ d'); + FMasks.add('$S* TTT DD YYYY hh mm ss $n*'); + //Distinct + FMasks.add('d $S*$TTT DD YYYY hh mm$n*'); + FMasks.add('d $S*$TTT DD$hh mm$n*'); + //PC-NFSD + FMasks.add('nnnnnnnn.nnn dSSSSSSSSSSS MM DD YY hh mmH'); + //VOS + FMasks.add('- SSSSS YY MM DD hh mm ss n*'); + FMasks.add('- d= SSSSS YY MM DD hh mm ss n*'); + //Unissys ClearPath + FMasks.add('nnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnn SSSSSSSSS MM DD YYYY hh mm'); + FMasks.add('n*\x SSSSSSSSS MM DD YYYY hh mm'); + //IBM + FMasks.add('- SSSSSSSSSSSS d MM DD YYYY hh mm n*'); + //OS9 + FMasks.add('- YY MM DD hhmm d SSSSSSSSS n*'); + //tandem + FMasks.add('nnnnnnnn SSSSSSS DD TTT YY hh mm ss'); + //MVS + FMasks.add('- YYYY MM DD SSSSS d=O n*'); + //BullGCOS8 + FMasks.add(' $S* MM DD YY hh mm ss !n*'); + FMasks.add('d $S* MM DD YY !n*'); + //BullGCOS7 + FMasks.add(' TTT DD YYYY n*'); + FMasks.add(' d n*'); +end; + +destructor TFTPList.Destroy; +begin + Clear; + FList.Free; + FLines.Free; + FMasks.Free; + FUnparsedLines.Free; + inherited Destroy; +end; + +procedure TFTPList.Clear; +var + n:integer; +begin + for n := 0 to FList.Count - 1 do + if Assigned(FList[n]) then + TFTPListRec(FList[n]).Free; + FList.Clear; + FLines.Clear; + FUnparsedLines.Clear; +end; + +function TFTPList.Count: integer; +begin + Result := FList.Count; +end; + +function TFTPList.GetListItem(Index: integer): TFTPListRec; +begin + Result := nil; + if Index < Count then + Result := TFTPListRec(FList[Index]); +end; + +procedure TFTPList.Assign(Value: TFTPList); +var + flr: TFTPListRec; + n: integer; +begin + Clear; + for n := 0 to Value.Count - 1 do + begin + flr := TFTPListRec.Create; + flr.Assign(Value[n]); + Flist.Add(flr); + end; + Lines.Assign(Value.Lines); + Masks.Assign(Value.Masks); + UnparsedLines.Assign(Value.UnparsedLines); +end; + +procedure TFTPList.ClearStore; +begin + Monthnames := ''; + BlockSize := ''; + DirFlagValue := ''; + FileName := ''; + VMSFileName := ''; + Day := ''; + Month := ''; + ThreeMonth := ''; + YearTime := ''; + Year := ''; + Hours := ''; + HoursModif := ''; + Minutes := ''; + Seconds := ''; + Size := ''; + Permissions := ''; + DirFlag := ''; +end; + +function TFTPList.ParseByMask(Value, NextValue, Mask: AnsiString): Integer; +var + Ivalue, IMask: integer; + MaskC, LastMaskC: AnsiChar; + c: AnsiChar; + s: string; +begin + ClearStore; + Result := 0; + if Value = '' then + Exit; + if Mask = '' then + Exit; + Ivalue := 1; + IMask := 1; + Result := 1; + LastMaskC := ' '; + while Imask <= Length(mask) do + begin + if (Mask[Imask] <> '*') and (Ivalue > Length(Value)) then + begin + Result := 0; + Exit; + end; + MaskC := Mask[Imask]; + if Ivalue > Length(Value) then + Exit; + c := Value[Ivalue]; + case MaskC of + 'n': + FileName := FileName + c; + 'v': + VMSFileName := VMSFileName + c; + '.': + begin + if c in ['.', ' '] then + FileName := TrimSP(FileName) + '.' + else + begin + Result := 0; + Exit; + end; + end; + 'D': + Day := Day + c; + 'M': + Month := Month + c; + 'T': + ThreeMonth := ThreeMonth + c; + 'U': + YearTime := YearTime + c; + 'Y': + Year := Year + c; + 'h': + Hours := Hours + c; + 'H': + HoursModif := HoursModif + c; + 'm': + Minutes := Minutes + c; + 's': + Seconds := Seconds + c; + 'S': + Size := Size + c; + 'p': + Permissions := Permissions + c; + 'd': + DirFlag := DirFlag + c; + 'x': + if c <> ' ' then + begin + Result := 0; + Exit; + end; + '*': + begin + s := ''; + if LastMaskC in ['n', 'v'] then + begin + if Imask = Length(Mask) then + s := Copy(Value, IValue, Maxint) + else + while IValue <= Length(Value) do + begin + if Value[Ivalue] = ' ' then + break; + s := s + Value[Ivalue]; + Inc(Ivalue); + end; + if LastMaskC = 'n' then + FileName := FileName + s + else + VMSFileName := VMSFileName + s; + end + else + begin + while IValue <= Length(Value) do + begin + if not(Value[Ivalue] in ['0'..'9']) then + break; + s := s + Value[Ivalue]; + Inc(Ivalue); + end; + case LastMaskC of + 'S': + Size := Size + s; + end; + end; + Dec(IValue); + end; + '!': + begin + while IValue <= Length(Value) do + begin + if Value[Ivalue] = ' ' then + break; + Inc(Ivalue); + end; + while IValue <= Length(Value) do + begin + if Value[Ivalue] <> ' ' then + break; + Inc(Ivalue); + end; + Dec(IValue); + end; + '$': + begin + while IValue <= Length(Value) do + begin + if not(Value[Ivalue] in [' ', #9]) then + break; + Inc(Ivalue); + end; + Dec(IValue); + end; + '=': + begin + s := ''; + case LastmaskC of + 'S': + begin + while Imask <= Length(Mask) do + begin + if not(Mask[Imask] in ['0'..'9']) then + break; + s := s + Mask[Imask]; + Inc(Imask); + end; + Dec(Imask); + BlockSize := s; + end; + 'T': + begin + Monthnames := Copy(Mask, IMask, 12 * 3); + Inc(IMask, 12 * 3); + end; + 'd': + begin + Inc(Imask); + DirFlagValue := Mask[Imask]; + end; + end; + end; + '\': + begin + Value := NextValue; + IValue := 0; + Result := 2; + end; + end; + Inc(Ivalue); + Inc(Imask); + LastMaskC := MaskC; + end; +end; + +function TFTPList.CheckValues: Boolean; +var + x, n: integer; +begin + Result := false; + if FileName <> '' then + begin + if pos('?', VMSFilename) > 0 then + Exit; + if pos('*', VMSFilename) > 0 then + Exit; + end; + if VMSFileName <> '' then + if pos(';', VMSFilename) <= 0 then + Exit; + if (FileName = '') and (VMSFileName = '') then + Exit; + if Permissions <> '' then + begin + if length(Permissions) <> 10 then + Exit; + for n := 1 to 10 do + if not(Permissions[n] in + ['a', 'b', 'c', 'd', 'h', 'l', 'p', 'r', 's', 't', 'w', 'x', 'y', '-']) then + Exit; + end; + if Day <> '' then + begin + Day := TrimSP(Day); + x := StrToIntDef(day, -1); + if (x < 1) or (x > 31) then + Exit; + end; + if Month <> '' then + begin + Month := TrimSP(Month); + x := StrToIntDef(Month, -1); + if (x < 1) or (x > 12) then + Exit; + end; + if Hours <> '' then + begin + Hours := TrimSP(Hours); + x := StrToIntDef(Hours, -1); + if (x < 0) or (x > 24) then + Exit; + end; + if HoursModif <> '' then + begin + if not (HoursModif[1] in ['a', 'A', 'p', 'P']) then + Exit; + end; + if Minutes <> '' then + begin + Minutes := TrimSP(Minutes); + x := StrToIntDef(Minutes, -1); + if (x < 0) or (x > 59) then + Exit; + end; + if Seconds <> '' then + begin + Seconds := TrimSP(Seconds); + x := StrToIntDef(Seconds, -1); + if (x < 0) or (x > 59) then + Exit; + end; + if Size <> '' then + begin + Size := TrimSP(Size); + for n := 1 to Length(Size) do + if not (Size[n] in ['0'..'9']) then + Exit; + end; + + if length(Monthnames) = (12 * 3) then + for n := 1 to 12 do + CustomMonthNames[n] := Copy(Monthnames, ((n - 1) * 3) + 1, 3); + if ThreeMonth <> '' then + begin + x := GetMonthNumber(ThreeMonth); + if (x = 0) then + Exit; + end; + if YearTime <> '' then + begin + YearTime := ReplaceString(YearTime, '-', ':'); + if pos(':', YearTime) > 0 then + begin + if (GetTimeFromstr(YearTime) = -1) then + Exit; + end + else + begin + YearTime := TrimSP(YearTime); + x := StrToIntDef(YearTime, -1); + if (x = -1) then + Exit; + if (x < 1900) or (x > 2100) then + Exit; + end; + end; + if Year <> '' then + begin + Year := TrimSP(Year); + x := StrToIntDef(Year, -1); + if (x = -1) then + Exit; + if Length(Year) = 4 then + begin + if not((x > 1900) and (x < 2100)) then + Exit; + end + else + if Length(Year) = 2 then + begin + if not((x >= 0) and (x <= 99)) then + Exit; + end + else + if Length(Year) = 3 then + begin + if not((x >= 100) and (x <= 110)) then + Exit; + end + else + Exit; + end; + Result := True; +end; + +procedure TFTPList.FillRecord(const Value: TFTPListRec); +var + s: string; + x: integer; + myear: Word; + mmonth: Word; + mday: Word; + mhours, mminutes, mseconds: word; + n: integer; +begin + s := DirFlagValue; + if s = '' then + s := 'D'; + s := Uppercase(s); + Value.Directory := s = Uppercase(DirFlag); + if FileName <> '' then + Value.FileName := SeparateLeft(Filename, ' -> '); + if VMSFileName <> '' then + begin + Value.FileName := VMSFilename; + Value.Directory := Pos('.DIR;',VMSFilename) > 0; + end; + Value.FileName := TrimSPRight(Value.FileName); + Value.Readable := not Value.Directory; + if BlockSize <> '' then + x := StrToIntDef(BlockSize, 1) + else + x := 1; + {$IFDEF VER100} + Value.FileSize := x * StrToIntDef(Size, 0); + {$ELSE} + Value.FileSize := x * StrToInt64Def(Size, 0); + {$ENDIF} + + DecodeDate(Date,myear,mmonth,mday); + mhours := 0; + mminutes := 0; + mseconds := 0; + + if Day <> '' then + mday := StrToIntDef(day, 1); + if Month <> '' then + mmonth := StrToIntDef(Month, 1); + if length(Monthnames) = (12 * 3) then + for n := 1 to 12 do + CustomMonthNames[n] := Copy(Monthnames, ((n - 1) * 3) + 1, 3); + if ThreeMonth <> '' then + mmonth := GetMonthNumber(ThreeMonth); + if Year <> '' then + begin + myear := StrToIntDef(Year, 0); + if (myear <= 99) and (myear > 50) then + myear := myear + 1900; + if myear <= 50 then + myear := myear + 2000; + end; + if YearTime <> '' then + begin + if pos(':', YearTime) > 0 then + begin + YearTime := TrimSP(YearTime); + mhours := StrToIntDef(Separateleft(YearTime, ':'), 0); + mminutes := StrToIntDef(SeparateRight(YearTime, ':'), 0); + if (Encodedate(myear, mmonth, mday) + + EncodeTime(mHours, mminutes, 0, 0)) > now then + Dec(mYear); + end + else + myear := StrToIntDef(YearTime, 0); + end; + if Minutes <> '' then + mminutes := StrToIntDef(Minutes, 0); + if Seconds <> '' then + mseconds := StrToIntDef(Seconds, 0); + if Hours <> '' then + begin + mHours := StrToIntDef(Hours, 0); + if HoursModif <> '' then + if Uppercase(HoursModif[1]) = 'P' then + if mHours <> 12 then + mHours := MHours + 12; + end; + Value.FileTime := Encodedate(myear, mmonth, mday) + + EncodeTime(mHours, mminutes, mseconds, 0); + if Permissions <> '' then + begin + Value.Permission := Permissions; + Value.Readable := Uppercase(permissions)[2] = 'R'; + if Uppercase(permissions)[1] = 'D' then + begin + Value.Directory := True; + Value.Readable := false; + end + else + if Uppercase(permissions)[1] = 'L' then + Value.Directory := True; + end; +end; + +function TFTPList.ParseEPLF(Value: string): Boolean; +var + s, os: string; + flr: TFTPListRec; +begin + Result := False; + if Value <> '' then + if Value[1] = '+' then + begin + os := Value; + Delete(Value, 1, 1); + flr := TFTPListRec.create; + flr.FileName := SeparateRight(Value, #9); + s := Fetch(Value, ','); + while s <> '' do + begin + if s[1] = #9 then + Break; + case s[1] of + '/': + flr.Directory := true; + 'r': + flr.Readable := true; + 's': + {$IFDEF VER100} + flr.FileSize := StrToIntDef(Copy(s, 2, Length(s) - 1), 0); + {$ELSE} + flr.FileSize := StrToInt64Def(Copy(s, 2, Length(s) - 1), 0); + {$ENDIF} + 'm': + flr.FileTime := (StrToIntDef(Copy(s, 2, Length(s) - 1), 0) / 86400) + + 25569; + end; + s := Fetch(Value, ','); + end; + if flr.FileName <> '' then + if (flr.Directory and ((flr.FileName = '.') or (flr.FileName = '..'))) + or (flr.FileName = '') then + flr.free + else + begin + flr.OriginalLine := os; + flr.Mask := 'EPLF'; + Flist.Add(flr); + Result := True; + end; + end; +end; + +procedure TFTPList.ParseLines; +var + flr: TFTPListRec; + n, m: Integer; + S: string; + x: integer; + b: Boolean; +begin + n := 0; + while n < Lines.Count do + begin + if n = Lines.Count - 1 then + s := '' + else + s := Lines[n + 1]; + b := False; + x := 0; + if ParseEPLF(Lines[n]) then + begin + b := True; + x := 1; + end + else + for m := 0 to Masks.Count - 1 do + begin + x := ParseByMask(Lines[n], s, Masks[m]); + if x > 0 then + if CheckValues then + begin + flr := TFTPListRec.create; + FillRecord(flr); + flr.OriginalLine := Lines[n]; + flr.Mask := Masks[m]; + if flr.Directory and ((flr.FileName = '.') or (flr.FileName = '..')) then + flr.free + else + Flist.Add(flr); + b := True; + Break; + end; + end; + if not b then + FUnparsedLines.Add(Lines[n]); + Inc(n); + if x > 1 then + Inc(n, x - 1); + end; +end; + +{==============================================================================} + +function FtpGetFile(const IP, Port, FileName, LocalFile, + User, Pass: string): Boolean; +begin + Result := False; + with TFTPSend.Create do + try + if User <> '' then + begin + Username := User; + Password := Pass; + end; + TargetHost := IP; + TargetPort := Port; + if not Login then + Exit; + DirectFileName := LocalFile; + DirectFile:=True; + Result := RetrieveFile(FileName, False); + Logout; + finally + Free; + end; +end; + +function FtpPutFile(const IP, Port, FileName, LocalFile, + User, Pass: string): Boolean; +begin + Result := False; + with TFTPSend.Create do + try + if User <> '' then + begin + Username := User; + Password := Pass; + end; + TargetHost := IP; + TargetPort := Port; + if not Login then + Exit; + DirectFileName := LocalFile; + DirectFile:=True; + Result := StoreFile(FileName, False); + Logout; + finally + Free; + end; +end; + +function FtpInterServerTransfer( + const FromIP, FromPort, FromFile, FromUser, FromPass: string; + const ToIP, ToPort, ToFile, ToUser, ToPass: string): Boolean; +var + FromFTP, ToFTP: TFTPSend; + s: string; + x: integer; +begin + Result := False; + FromFTP := TFTPSend.Create; + toFTP := TFTPSend.Create; + try + if FromUser <> '' then + begin + FromFTP.Username := FromUser; + FromFTP.Password := FromPass; + end; + if ToUser <> '' then + begin + ToFTP.Username := ToUser; + ToFTP.Password := ToPass; + end; + FromFTP.TargetHost := FromIP; + FromFTP.TargetPort := FromPort; + ToFTP.TargetHost := ToIP; + ToFTP.TargetPort := ToPort; + if not FromFTP.Login then + Exit; + if not ToFTP.Login then + Exit; + if (FromFTP.FTPCommand('PASV') div 100) <> 2 then + Exit; + FromFTP.ParseRemote(FromFTP.ResultString); + s := ReplaceString(FromFTP.DataIP, '.', ','); + s := 'PORT ' + s + ',' + IntToStr(StrToIntDef(FromFTP.DataPort, 0) div 256) + + ',' + IntToStr(StrToIntDef(FromFTP.DataPort, 0) mod 256); + if (ToFTP.FTPCommand(s) div 100) <> 2 then + Exit; + x := ToFTP.FTPCommand('RETR ' + FromFile); + if (x div 100) <> 1 then + Exit; + x := FromFTP.FTPCommand('STOR ' + ToFile); + if (x div 100) <> 1 then + Exit; + FromFTP.Timeout := 21600000; + x := FromFTP.ReadResult; + if (x div 100) <> 2 then + Exit; + ToFTP.Timeout := 21600000; + x := ToFTP.ReadResult; + if (x div 100) <> 2 then + Exit; + Result := True; + finally + ToFTP.Free; + FromFTP.Free; + end; +end; + +end. diff --git a/synapse/ftptsend.pas b/synapse/ftptsend.pas new file mode 100644 index 0000000..6ab4173 --- /dev/null +++ b/synapse/ftptsend.pas @@ -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. diff --git a/synapse/httpsend.pas b/synapse/httpsend.pas new file mode 100644 index 0000000..7182db3 --- /dev/null +++ b/synapse/httpsend.pas @@ -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. diff --git a/synapse/imapsend.pas b/synapse/imapsend.pas new file mode 100644 index 0000000..85ac3fa --- /dev/null +++ b/synapse/imapsend.pas @@ -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. diff --git a/synapse/laz_synapse.lpk b/synapse/laz_synapse.lpk new file mode 100644 index 0000000..e686e41 --- /dev/null +++ b/synapse/laz_synapse.lpk @@ -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> diff --git a/synapse/laz_synapse.pas b/synapse/laz_synapse.pas new file mode 100644 index 0000000..2eaa540 --- /dev/null +++ b/synapse/laz_synapse.pas @@ -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. diff --git a/synapse/ldapsend.pas b/synapse/ldapsend.pas new file mode 100644 index 0000000..ece52d6 --- /dev/null +++ b/synapse/ldapsend.pas @@ -0,0 +1,1208 @@ +{==============================================================================| +| Project : Ararat Synapse | 001.007.000 | +|==============================================================================| +| Content: LDAP 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)2003-2010. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +{:@abstract(LDAP client) + +Used RFC: RFC-2251, RFC-2254, RFC-2829, RFC-2830 +} + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$H+} + +{$IFDEF UNICODE} + {$WARN IMPLICIT_STRING_CAST OFF} + {$WARN IMPLICIT_STRING_CAST_LOSS OFF} +{$ENDIF} + +unit ldapsend; + +interface + +uses + SysUtils, Classes, + blcksock, synautil, asn1util, synacode; + +const + cLDAPProtocol = '389'; + + LDAP_ASN1_BIND_REQUEST = $60; + LDAP_ASN1_BIND_RESPONSE = $61; + LDAP_ASN1_UNBIND_REQUEST = $42; + LDAP_ASN1_SEARCH_REQUEST = $63; + LDAP_ASN1_SEARCH_ENTRY = $64; + LDAP_ASN1_SEARCH_DONE = $65; + LDAP_ASN1_SEARCH_REFERENCE = $73; + LDAP_ASN1_MODIFY_REQUEST = $66; + LDAP_ASN1_MODIFY_RESPONSE = $67; + LDAP_ASN1_ADD_REQUEST = $68; + LDAP_ASN1_ADD_RESPONSE = $69; + LDAP_ASN1_DEL_REQUEST = $4A; + LDAP_ASN1_DEL_RESPONSE = $6B; + LDAP_ASN1_MODIFYDN_REQUEST = $6C; + LDAP_ASN1_MODIFYDN_RESPONSE = $6D; + LDAP_ASN1_COMPARE_REQUEST = $6E; + LDAP_ASN1_COMPARE_RESPONSE = $6F; + LDAP_ASN1_ABANDON_REQUEST = $70; + LDAP_ASN1_EXT_REQUEST = $77; + LDAP_ASN1_EXT_RESPONSE = $78; + + +type + + {:@abstract(LDAP attribute with list of their values) + This class holding name of LDAP attribute and list of their values. This is + descendant of TStringList class enhanced by some new properties.} + TLDAPAttribute = class(TStringList) + private + FAttributeName: AnsiString; + FIsBinary: Boolean; + protected + function Get(Index: integer): string; override; + procedure Put(Index: integer; const Value: string); override; + procedure SetAttributeName(Value: AnsiString); + published + {:Name of LDAP attribute.} + property AttributeName: AnsiString read FAttributeName Write SetAttributeName; + {:Return @true when attribute contains binary data.} + property IsBinary: Boolean read FIsBinary; + end; + + {:@abstract(List of @link(TLDAPAttribute)) + This object can hold list of TLDAPAttribute objects.} + TLDAPAttributeList = class(TObject) + private + FAttributeList: TList; + function GetAttribute(Index: integer): TLDAPAttribute; + public + constructor Create; + destructor Destroy; override; + {:Clear list.} + procedure Clear; + {:Return count of TLDAPAttribute objects in list.} + function Count: integer; + {:Add new TLDAPAttribute object to list.} + function Add: TLDAPAttribute; + {:Delete one TLDAPAttribute object from list.} + procedure Del(Index: integer); + {:Find and return attribute with requested name. Returns nil if not found.} + function Find(AttributeName: AnsiString): TLDAPAttribute; + {:Find and return attribute value with requested name. Returns empty string if not found.} + function Get(AttributeName: AnsiString): string; + {:List of TLDAPAttribute objects.} + property Items[Index: Integer]: TLDAPAttribute read GetAttribute; default; + end; + + {:@abstract(LDAP result object) + This object can hold LDAP object. (their name and all their attributes with + values)} + TLDAPResult = class(TObject) + private + FObjectName: AnsiString; + FAttributes: TLDAPAttributeList; + public + constructor Create; + destructor Destroy; override; + published + {:Name of this LDAP object.} + property ObjectName: AnsiString read FObjectName write FObjectName; + {:Here is list of object attributes.} + property Attributes: TLDAPAttributeList read FAttributes; + end; + + {:@abstract(List of LDAP result objects) + This object can hold list of LDAP objects. (for example result of LDAP SEARCH.)} + TLDAPResultList = class(TObject) + private + FResultList: TList; + function GetResult(Index: integer): TLDAPResult; + public + constructor Create; + destructor Destroy; override; + {:Clear all TLDAPResult objects in list.} + procedure Clear; + {:Return count of TLDAPResult objects in list.} + function Count: integer; + {:Create and add new TLDAPResult object to list.} + function Add: TLDAPResult; + {:List of TLDAPResult objects.} + property Items[Index: Integer]: TLDAPResult read GetResult; default; + end; + + {:Define possible operations for LDAP MODIFY operations.} + TLDAPModifyOp = ( + MO_Add, + MO_Delete, + MO_Replace + ); + + {:Specify possible values for search scope.} + TLDAPSearchScope = ( + SS_BaseObject, + SS_SingleLevel, + SS_WholeSubtree + ); + + {:Specify possible values about alias dereferencing.} + TLDAPSearchAliases = ( + SA_NeverDeref, + SA_InSearching, + SA_FindingBaseObj, + SA_Always + ); + + {:@abstract(Implementation of LDAP client) + (version 2 and 3) + + 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!} + TLDAPSend = class(TSynaClient) + private + FSock: TTCPBlockSocket; + FResultCode: Integer; + FResultString: AnsiString; + FFullResult: AnsiString; + FAutoTLS: Boolean; + FFullSSL: Boolean; + FSeq: integer; + FResponseCode: integer; + FResponseDN: AnsiString; + FReferals: TStringList; + FVersion: integer; + FSearchScope: TLDAPSearchScope; + FSearchAliases: TLDAPSearchAliases; + FSearchSizeLimit: integer; + FSearchTimeLimit: integer; + FSearchResult: TLDAPResultList; + FExtName: AnsiString; + FExtValue: AnsiString; + function Connect: Boolean; + function BuildPacket(const Value: AnsiString): AnsiString; + function ReceiveResponse: AnsiString; + function DecodeResponse(const Value: AnsiString): AnsiString; + function LdapSasl(Value: AnsiString): AnsiString; + function TranslateFilter(Value: AnsiString): AnsiString; + function GetErrorString(Value: integer): AnsiString; + public + constructor Create; + destructor Destroy; override; + + {:Try to connect to LDAP server and start secure channel, when it is required.} + function Login: Boolean; + + {:Try to bind to LDAP server with @link(TSynaClient.Username) and + @link(TSynaClient.Password). If this is empty strings, then it do annonymous + Bind. When you not call Bind on LDAPv3, then is automaticly used anonymous + mode. + + This method using plaintext transport of password! It is not secure!} + function Bind: Boolean; + + {:Try to bind to LDAP server with @link(TSynaClient.Username) and + @link(TSynaClient.Password). If this is empty strings, then it do annonymous + Bind. When you not call Bind on LDAPv3, then is automaticly used anonymous + mode. + + This method using SASL with DIGEST-MD5 method for secure transfer of your + password.} + function BindSasl: Boolean; + + {:Close connection to LDAP server.} + function Logout: Boolean; + + {:Modify content of LDAP attribute on this object.} + function Modify(obj: AnsiString; Op: TLDAPModifyOp; const Value: TLDAPAttribute): Boolean; + + {:Add list of attributes to specified object.} + function Add(obj: AnsiString; const Value: TLDAPAttributeList): Boolean; + + {:Delete this LDAP object from server.} + function Delete(obj: AnsiString): Boolean; + + {:Modify object name of this LDAP object.} + function ModifyDN(obj, newRDN, newSuperior: AnsiString; DeleteoldRDN: Boolean): Boolean; + + {:Try to compare Attribute value with this LDAP object.} + function Compare(obj, AttributeValue: AnsiString): Boolean; + + {:Search LDAP base for LDAP objects by Filter.} + function Search(obj: AnsiString; TypesOnly: Boolean; Filter: AnsiString; + const Attributes: TStrings): Boolean; + + {:Call any LDAPv3 extended command.} + function Extended(const Name, Value: AnsiString): Boolean; + + {:Try to start SSL/TLS connection to LDAP server.} + function StartTLS: Boolean; + published + {:Specify version of used LDAP protocol. Default value is 3.} + property Version: integer read FVersion Write FVersion; + + {:Result code of last LDAP operation.} + property ResultCode: Integer read FResultCode; + + {:Human readable description of result code of last LDAP operation.} + property ResultString: AnsiString read FResultString; + + {:Binary string with full last response of LDAP server. This string is + encoded by ASN.1 BER encoding! You need this only for debugging.} + property FullResult: AnsiString read FFullResult; + + {:If @true, then try to start TSL mode in Login procedure.} + property AutoTLS: Boolean read FAutoTLS Write FAutoTLS; + + {:If @true, then use connection to LDAP server through SSL/TLS tunnel.} + property FullSSL: Boolean read FFullSSL Write FFullSSL; + + {:Sequence number of last LDAp command. It is incremented by any LDAP command.} + property Seq: integer read FSeq; + + {:Specify what search scope is used in search command.} + property SearchScope: TLDAPSearchScope read FSearchScope Write FSearchScope; + + {:Specify how to handle aliases in search command.} + property SearchAliases: TLDAPSearchAliases read FSearchAliases Write FSearchAliases; + + {:Specify result size limit in search command. Value 0 means without limit.} + property SearchSizeLimit: integer read FSearchSizeLimit Write FSearchSizeLimit; + + {:Specify search time limit in search command (seconds). Value 0 means + without limit.} + property SearchTimeLimit: integer read FSearchTimeLimit Write FSearchTimeLimit; + + {:Here is result of search command.} + property SearchResult: TLDAPResultList read FSearchResult; + + {:On each LDAP operation can LDAP server return some referals URLs. Here is + their list.} + property Referals: TStringList read FReferals; + + {:When you call @link(Extended) operation, then here is result Name returned + by server.} + property ExtName: AnsiString read FExtName; + + {:When you call @link(Extended) operation, then here is result Value returned + by server.} + property ExtValue: AnsiString read FExtValue; + + {:TCP socket used by all LDAP operations.} + property Sock: TTCPBlockSocket read FSock; + end; + +{:Dump result of LDAP SEARCH into human readable form. Good for debugging.} +function LDAPResultDump(const Value: TLDAPResultList): AnsiString; + +implementation + +{==============================================================================} +function TLDAPAttribute.Get(Index: integer): string; +begin + Result := inherited Get(Index); + if FIsbinary then + Result := DecodeBase64(Result); +end; + +procedure TLDAPAttribute.Put(Index: integer; const Value: string); +var + s: AnsiString; +begin + s := Value; + if FIsbinary then + s := EncodeBase64(Value) + else + s :=UnquoteStr(s, '"'); + inherited Put(Index, s); +end; + +procedure TLDAPAttribute.SetAttributeName(Value: AnsiString); +begin + FAttributeName := Value; + FIsBinary := Pos(';binary', Lowercase(value)) > 0; +end; + +{==============================================================================} +constructor TLDAPAttributeList.Create; +begin + inherited Create; + FAttributeList := TList.Create; +end; + +destructor TLDAPAttributeList.Destroy; +begin + Clear; + FAttributeList.Free; + inherited Destroy; +end; + +procedure TLDAPAttributeList.Clear; +var + n: integer; + x: TLDAPAttribute; +begin + for n := Count - 1 downto 0 do + begin + x := GetAttribute(n); + if Assigned(x) then + x.Free; + end; + FAttributeList.Clear; +end; + +function TLDAPAttributeList.Count: integer; +begin + Result := FAttributeList.Count; +end; + +function TLDAPAttributeList.Get(AttributeName: AnsiString): string; +var + x: TLDAPAttribute; +begin + Result := ''; + x := self.Find(AttributeName); + if x <> nil then + if x.Count > 0 then + Result := x[0]; +end; + +function TLDAPAttributeList.GetAttribute(Index: integer): TLDAPAttribute; +begin + Result := nil; + if Index < Count then + Result := TLDAPAttribute(FAttributeList[Index]); +end; + +function TLDAPAttributeList.Add: TLDAPAttribute; +begin + Result := TLDAPAttribute.Create; + FAttributeList.Add(Result); +end; + +procedure TLDAPAttributeList.Del(Index: integer); +var + x: TLDAPAttribute; +begin + x := GetAttribute(Index); + if Assigned(x) then + x.free; + FAttributeList.Delete(Index); +end; + +function TLDAPAttributeList.Find(AttributeName: AnsiString): TLDAPAttribute; +var + n: integer; + x: TLDAPAttribute; +begin + Result := nil; + AttributeName := lowercase(AttributeName); + for n := 0 to Count - 1 do + begin + x := GetAttribute(n); + if Assigned(x) then + if lowercase(x.AttributeName) = Attributename then + begin + result := x; + break; + end; + end; +end; + +{==============================================================================} +constructor TLDAPResult.Create; +begin + inherited Create; + FAttributes := TLDAPAttributeList.Create; +end; + +destructor TLDAPResult.Destroy; +begin + FAttributes.Free; + inherited Destroy; +end; + +{==============================================================================} +constructor TLDAPResultList.Create; +begin + inherited Create; + FResultList := TList.Create; +end; + +destructor TLDAPResultList.Destroy; +begin + Clear; + FResultList.Free; + inherited Destroy; +end; + +procedure TLDAPResultList.Clear; +var + n: integer; + x: TLDAPResult; +begin + for n := Count - 1 downto 0 do + begin + x := GetResult(n); + if Assigned(x) then + x.Free; + end; + FResultList.Clear; +end; + +function TLDAPResultList.Count: integer; +begin + Result := FResultList.Count; +end; + +function TLDAPResultList.GetResult(Index: integer): TLDAPResult; +begin + Result := nil; + if Index < Count then + Result := TLDAPResult(FResultList[Index]); +end; + +function TLDAPResultList.Add: TLDAPResult; +begin + Result := TLDAPResult.Create; + FResultList.Add(Result); +end; + +{==============================================================================} +constructor TLDAPSend.Create; +begin + inherited Create; + FReferals := TStringList.Create; + FFullResult := ''; + FSock := TTCPBlockSocket.Create; + FSock.Owner := self; + FTimeout := 60000; + FTargetPort := cLDAPProtocol; + FAutoTLS := False; + FFullSSL := False; + FSeq := 0; + FVersion := 3; + FSearchScope := SS_WholeSubtree; + FSearchAliases := SA_Always; + FSearchSizeLimit := 0; + FSearchTimeLimit := 0; + FSearchResult := TLDAPResultList.Create; +end; + +destructor TLDAPSend.Destroy; +begin + FSock.Free; + FSearchResult.Free; + FReferals.Free; + inherited Destroy; +end; + +function TLDAPSend.GetErrorString(Value: integer): AnsiString; +begin + case Value of + 0: + Result := 'Success'; + 1: + Result := 'Operations error'; + 2: + Result := 'Protocol error'; + 3: + Result := 'Time limit Exceeded'; + 4: + Result := 'Size limit Exceeded'; + 5: + Result := 'Compare FALSE'; + 6: + Result := 'Compare TRUE'; + 7: + Result := 'Auth method not supported'; + 8: + Result := 'Strong auth required'; + 9: + Result := '-- reserved --'; + 10: + Result := 'Referal'; + 11: + Result := 'Admin limit exceeded'; + 12: + Result := 'Unavailable critical extension'; + 13: + Result := 'Confidentality required'; + 14: + Result := 'Sasl bind in progress'; + 16: + Result := 'No such attribute'; + 17: + Result := 'Undefined attribute type'; + 18: + Result := 'Inappropriate matching'; + 19: + Result := 'Constraint violation'; + 20: + Result := 'Attribute or value exists'; + 21: + Result := 'Invalid attribute syntax'; + 32: + Result := 'No such object'; + 33: + Result := 'Alias problem'; + 34: + Result := 'Invalid DN syntax'; + 36: + Result := 'Alias dereferencing problem'; + 48: + Result := 'Inappropriate authentication'; + 49: + Result := 'Invalid credentials'; + 50: + Result := 'Insufficient access rights'; + 51: + Result := 'Busy'; + 52: + Result := 'Unavailable'; + 53: + Result := 'Unwilling to perform'; + 54: + Result := 'Loop detect'; + 64: + Result := 'Naming violation'; + 65: + Result := 'Object class violation'; + 66: + Result := 'Not allowed on non leaf'; + 67: + Result := 'Not allowed on RDN'; + 68: + Result := 'Entry already exists'; + 69: + Result := 'Object class mods prohibited'; + 71: + Result := 'Affects multiple DSAs'; + 80: + Result := 'Other'; + else + Result := '--unknown--'; + end; +end; + +function TLDAPSend.Connect: Boolean; +begin + // Do not call this function! It is calling by LOGIN method! + FSock.CloseSocket; + FSock.LineBuffer := ''; + FSeq := 0; + 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 TLDAPSend.BuildPacket(const Value: AnsiString): AnsiString; +begin + Inc(FSeq); + Result := ASNObject(ASNObject(ASNEncInt(FSeq), ASN1_INT) + Value, ASN1_SEQ); +end; + +function TLDAPSend.ReceiveResponse: AnsiString; +var + x: Byte; + i,j: integer; +begin + Result := ''; + FFullResult := ''; + x := FSock.RecvByte(FTimeout); + if x <> ASN1_SEQ then + Exit; + Result := AnsiChar(x); + x := FSock.RecvByte(FTimeout); + Result := Result + AnsiChar(x); + if x < $80 then + i := 0 + else + i := x and $7F; + if i > 0 then + Result := Result + FSock.RecvBufferStr(i, Ftimeout); + if FSock.LastError <> 0 then + begin + Result := ''; + Exit; + end; + //get length of LDAP packet + j := 2; + i := ASNDecLen(j, Result); + //retreive rest of LDAP packet + if i > 0 then + Result := Result + FSock.RecvBufferStr(i, Ftimeout); + if FSock.LastError <> 0 then + begin + Result := ''; + Exit; + end; + FFullResult := Result; +end; + +function TLDAPSend.DecodeResponse(const Value: AnsiString): AnsiString; +var + i, x: integer; + Svt: Integer; + s, t: AnsiString; +begin + Result := ''; + FResultCode := -1; + FResultstring := ''; + FResponseCode := -1; + FResponseDN := ''; + FReferals.Clear; + i := 1; + ASNItem(i, Value, Svt); + x := StrToIntDef(ASNItem(i, Value, Svt), 0); + if (svt <> ASN1_INT) or (x <> FSeq) then + Exit; + s := ASNItem(i, Value, Svt); + FResponseCode := svt; + if FResponseCode in [LDAP_ASN1_BIND_RESPONSE, LDAP_ASN1_SEARCH_DONE, + LDAP_ASN1_MODIFY_RESPONSE, LDAP_ASN1_ADD_RESPONSE, LDAP_ASN1_DEL_RESPONSE, + LDAP_ASN1_MODIFYDN_RESPONSE, LDAP_ASN1_COMPARE_RESPONSE, + LDAP_ASN1_EXT_RESPONSE] then + begin + FResultCode := StrToIntDef(ASNItem(i, Value, Svt), -1); + FResponseDN := ASNItem(i, Value, Svt); + FResultString := ASNItem(i, Value, Svt); + if FResultString = '' then + FResultString := GetErrorString(FResultCode); + if FResultCode = 10 then + begin + s := ASNItem(i, Value, Svt); + if svt = $A3 then + begin + x := 1; + while x < Length(s) do + begin + t := ASNItem(x, s, Svt); + FReferals.Add(t); + end; + end; + end; + end; + Result := Copy(Value, i, Length(Value) - i + 1); +end; + +function TLDAPSend.LdapSasl(Value: AnsiString): AnsiString; +var + nonce, cnonce, nc, realm, qop, uri, response: AnsiString; + s: AnsiString; + a1, a2: AnsiString; + l: TStringList; + n: integer; +begin + l := TStringList.Create; + try + nonce := ''; + realm := ''; + l.CommaText := Value; + n := IndexByBegin('nonce=', l); + if n >= 0 then + nonce := UnQuoteStr(Trim(SeparateRight(l[n], 'nonce=')), '"'); + n := IndexByBegin('realm=', l); + if n >= 0 then + realm := UnQuoteStr(Trim(SeparateRight(l[n], 'realm=')), '"'); + cnonce := IntToHex(GetTick, 8); + nc := '00000001'; + qop := 'auth'; + uri := 'ldap/' + FSock.ResolveIpToName(FSock.GetRemoteSinIP); + a1 := md5(FUsername + ':' + realm + ':' + FPassword) + + ':' + nonce + ':' + cnonce; + a2 := 'AUTHENTICATE:' + uri; + s := strtohex(md5(a1))+':' + nonce + ':' + nc + ':' + cnonce + ':' + + qop +':'+strtohex(md5(a2)); + response := strtohex(md5(s)); + + Result := 'username="' + Fusername + '",realm="' + realm + '",nonce="'; + Result := Result + nonce + '",cnonce="' + cnonce + '",nc=' + nc + ',qop='; + Result := Result + qop + ',digest-uri="' + uri + '",response=' + response; + finally + l.Free; + end; +end; + +function TLDAPSend.TranslateFilter(Value: AnsiString): AnsiString; +var + x: integer; + s, t, l: AnsiString; + r: string; + c: Ansichar; + attr, rule: AnsiString; + dn: Boolean; +begin + Result := ''; + if Value = '' then + Exit; + s := Value; + if Value[1] = '(' then + begin + x := RPos(')', Value); + s := Copy(Value, 2, x - 2); + end; + if s = '' then + Exit; + case s[1] of + '!': + // NOT rule (recursive call) + begin + Result := ASNOBject(TranslateFilter(GetBetween('(', ')', s)), $A2); + end; + '&': + // AND rule (recursive call) + begin + repeat + t := GetBetween('(', ')', s); + s := Trim(SeparateRight(s, t)); + if s <> '' then + if s[1] = ')' then + {$IFDEF CIL}Borland.Delphi.{$ENDIF}System.Delete(s, 1, 1); + Result := Result + TranslateFilter(t); + until s = ''; + Result := ASNOBject(Result, $A0); + end; + '|': + // OR rule (recursive call) + begin + repeat + t := GetBetween('(', ')', s); + s := Trim(SeparateRight(s, t)); + if s <> '' then + if s[1] = ')' then + {$IFDEF CIL}Borland.Delphi.{$ENDIF}System.Delete(s, 1, 1); + Result := Result + TranslateFilter(t); + until s = ''; + Result := ASNOBject(Result, $A1); + end; + else + begin + l := Trim(SeparateLeft(s, '=')); + r := Trim(SeparateRight(s, '=')); + if l <> '' then + begin + c := l[Length(l)]; + case c of + ':': + // Extensible match + begin + {$IFDEF CIL}Borland.Delphi.{$ENDIF}System.Delete(l, Length(l), 1); + dn := False; + attr := ''; + rule := ''; + if Pos(':dn', l) > 0 then + begin + dn := True; + l := ReplaceString(l, ':dn', ''); + end; + attr := Trim(SeparateLeft(l, ':')); + rule := Trim(SeparateRight(l, ':')); + if rule = l then + rule := ''; + if rule <> '' then + Result := ASNObject(rule, $81); + if attr <> '' then + Result := Result + ASNObject(attr, $82); + Result := Result + ASNObject(DecodeTriplet(r, '\'), $83); + if dn then + Result := Result + ASNObject(AsnEncInt($ff), $84) + else + Result := Result + ASNObject(AsnEncInt(0), $84); + Result := ASNOBject(Result, $a9); + end; + '~': + // Approx match + begin + {$IFDEF CIL}Borland.Delphi.{$ENDIF}System.Delete(l, Length(l), 1); + Result := ASNOBject(l, ASN1_OCTSTR) + + ASNOBject(DecodeTriplet(r, '\'), ASN1_OCTSTR); + Result := ASNOBject(Result, $a8); + end; + '>': + // Greater or equal match + begin + {$IFDEF CIL}Borland.Delphi.{$ENDIF}System.Delete(l, Length(l), 1); + Result := ASNOBject(l, ASN1_OCTSTR) + + ASNOBject(DecodeTriplet(r, '\'), ASN1_OCTSTR); + Result := ASNOBject(Result, $a5); + end; + '<': + // Less or equal match + begin + {$IFDEF CIL}Borland.Delphi.{$ENDIF}System.Delete(l, Length(l), 1); + Result := ASNOBject(l, ASN1_OCTSTR) + + ASNOBject(DecodeTriplet(r, '\'), ASN1_OCTSTR); + Result := ASNOBject(Result, $a6); + end; + else + // present + if r = '*' then + Result := ASNOBject(l, $87) + else + if Pos('*', r) > 0 then + // substrings + begin + s := Fetch(r, '*'); + if s <> '' then + Result := ASNOBject(DecodeTriplet(s, '\'), $80); + while r <> '' do + begin + if Pos('*', r) <= 0 then + break; + s := Fetch(r, '*'); + Result := Result + ASNOBject(DecodeTriplet(s, '\'), $81); + end; + if r <> '' then + Result := Result + ASNOBject(DecodeTriplet(r, '\'), $82); + Result := ASNOBject(l, ASN1_OCTSTR) + + ASNOBject(Result, ASN1_SEQ); + Result := ASNOBject(Result, $a4); + end + else + begin + // Equality match + Result := ASNOBject(l, ASN1_OCTSTR) + + ASNOBject(DecodeTriplet(r, '\'), ASN1_OCTSTR); + Result := ASNOBject(Result, $a3); + end; + end; + end; + end; + end; +end; + +function TLDAPSend.Login: Boolean; +begin + Result := False; + if not Connect then + Exit; + Result := True; + if FAutoTLS then + Result := StartTLS; +end; + +function TLDAPSend.Bind: Boolean; +var + s: AnsiString; +begin + s := ASNObject(ASNEncInt(FVersion), ASN1_INT) + + ASNObject(FUsername, ASN1_OCTSTR) + + ASNObject(FPassword, $80); + s := ASNObject(s, LDAP_ASN1_BIND_REQUEST); + Fsock.SendString(BuildPacket(s)); + s := ReceiveResponse; + DecodeResponse(s); + Result := FResultCode = 0; +end; + +function TLDAPSend.BindSasl: Boolean; +var + s, t: AnsiString; + x, xt: integer; + digreq: AnsiString; +begin + Result := False; + if FPassword = '' then + Result := Bind + else + begin + digreq := ASNObject(ASNEncInt(FVersion), ASN1_INT) + + ASNObject('', ASN1_OCTSTR) + + ASNObject(ASNObject('DIGEST-MD5', ASN1_OCTSTR), $A3); + digreq := ASNObject(digreq, LDAP_ASN1_BIND_REQUEST); + Fsock.SendString(BuildPacket(digreq)); + s := ReceiveResponse; + t := DecodeResponse(s); + if FResultCode = 14 then + begin + s := t; + x := 1; + t := ASNItem(x, s, xt); + s := ASNObject(ASNEncInt(FVersion), ASN1_INT) + + ASNObject('', ASN1_OCTSTR) + + ASNObject(ASNObject('DIGEST-MD5', ASN1_OCTSTR) + + ASNObject(LdapSasl(t), ASN1_OCTSTR), $A3); + s := ASNObject(s, LDAP_ASN1_BIND_REQUEST); + Fsock.SendString(BuildPacket(s)); + s := ReceiveResponse; + DecodeResponse(s); + if FResultCode = 14 then + begin + Fsock.SendString(BuildPacket(digreq)); + s := ReceiveResponse; + DecodeResponse(s); + end; + Result := FResultCode = 0; + end; + end; +end; + +function TLDAPSend.Logout: Boolean; +begin + Fsock.SendString(BuildPacket(ASNObject('', LDAP_ASN1_UNBIND_REQUEST))); + FSock.CloseSocket; + Result := True; +end; + +function TLDAPSend.Modify(obj: AnsiString; Op: TLDAPModifyOp; const Value: TLDAPAttribute): Boolean; +var + s: AnsiString; + n: integer; +begin + s := ''; + for n := 0 to Value.Count -1 do + s := s + ASNObject(Value[n], ASN1_OCTSTR); + s := ASNObject(Value.AttributeName, ASN1_OCTSTR) + ASNObject(s, ASN1_SETOF); + s := ASNObject(ASNEncInt(Ord(Op)), ASN1_ENUM) + ASNObject(s, ASN1_SEQ); + s := ASNObject(s, ASN1_SEQ); + s := ASNObject(obj, ASN1_OCTSTR) + ASNObject(s, ASN1_SEQ); + s := ASNObject(s, LDAP_ASN1_MODIFY_REQUEST); + Fsock.SendString(BuildPacket(s)); + s := ReceiveResponse; + DecodeResponse(s); + Result := FResultCode = 0; +end; + +function TLDAPSend.Add(obj: AnsiString; const Value: TLDAPAttributeList): Boolean; +var + s, t: AnsiString; + n, m: integer; +begin + s := ''; + for n := 0 to Value.Count - 1 do + begin + t := ''; + for m := 0 to Value[n].Count - 1 do + t := t + ASNObject(Value[n][m], ASN1_OCTSTR); + t := ASNObject(Value[n].AttributeName, ASN1_OCTSTR) + + ASNObject(t, ASN1_SETOF); + s := s + ASNObject(t, ASN1_SEQ); + end; + s := ASNObject(obj, ASN1_OCTSTR) + ASNObject(s, ASN1_SEQ); + s := ASNObject(s, LDAP_ASN1_ADD_REQUEST); + Fsock.SendString(BuildPacket(s)); + s := ReceiveResponse; + DecodeResponse(s); + Result := FResultCode = 0; +end; + +function TLDAPSend.Delete(obj: AnsiString): Boolean; +var + s: AnsiString; +begin + s := ASNObject(obj, LDAP_ASN1_DEL_REQUEST); + Fsock.SendString(BuildPacket(s)); + s := ReceiveResponse; + DecodeResponse(s); + Result := FResultCode = 0; +end; + +function TLDAPSend.ModifyDN(obj, newRDN, newSuperior: AnsiString; DeleteOldRDN: Boolean): Boolean; +var + s: AnsiString; +begin + s := ASNObject(obj, ASN1_OCTSTR) + ASNObject(newRDN, ASN1_OCTSTR); + if DeleteOldRDN then + s := s + ASNObject(ASNEncInt($ff), ASN1_BOOL) + else + s := s + ASNObject(ASNEncInt(0), ASN1_BOOL); + if newSuperior <> '' then + s := s + ASNObject(newSuperior, $80); + s := ASNObject(s, LDAP_ASN1_MODIFYDN_REQUEST); + Fsock.SendString(BuildPacket(s)); + s := ReceiveResponse; + DecodeResponse(s); + Result := FResultCode = 0; +end; + +function TLDAPSend.Compare(obj, AttributeValue: AnsiString): Boolean; +var + s: AnsiString; +begin + s := ASNObject(Trim(SeparateLeft(AttributeValue, '=')), ASN1_OCTSTR) + + ASNObject(Trim(SeparateRight(AttributeValue, '=')), ASN1_OCTSTR); + s := ASNObject(obj, ASN1_OCTSTR) + ASNObject(s, ASN1_SEQ); + s := ASNObject(s, LDAP_ASN1_COMPARE_REQUEST); + Fsock.SendString(BuildPacket(s)); + s := ReceiveResponse; + DecodeResponse(s); + Result := FResultCode = 0; +end; + +function TLDAPSend.Search(obj: AnsiString; TypesOnly: Boolean; Filter: AnsiString; + const Attributes: TStrings): Boolean; +var + s, t, u: AnsiString; + n, i, x: integer; + r: TLDAPResult; + a: TLDAPAttribute; +begin + FSearchResult.Clear; + FReferals.Clear; + s := ASNObject(obj, ASN1_OCTSTR); + s := s + ASNObject(ASNEncInt(Ord(FSearchScope)), ASN1_ENUM); + s := s + ASNObject(ASNEncInt(Ord(FSearchAliases)), ASN1_ENUM); + s := s + ASNObject(ASNEncInt(FSearchSizeLimit), ASN1_INT); + s := s + ASNObject(ASNEncInt(FSearchTimeLimit), ASN1_INT); + if TypesOnly then + s := s + ASNObject(ASNEncInt($ff), ASN1_BOOL) + else + s := s + ASNObject(ASNEncInt(0), ASN1_BOOL); + if Filter = '' then + Filter := '(objectclass=*)'; + t := TranslateFilter(Filter); + if t = '' then + s := s + ASNObject('', ASN1_NULL) + else + s := s + t; + t := ''; + for n := 0 to Attributes.Count - 1 do + t := t + ASNObject(Attributes[n], ASN1_OCTSTR); + s := s + ASNObject(t, ASN1_SEQ); + s := ASNObject(s, LDAP_ASN1_SEARCH_REQUEST); + Fsock.SendString(BuildPacket(s)); + repeat + s := ReceiveResponse; + t := DecodeResponse(s); + if FResponseCode = LDAP_ASN1_SEARCH_ENTRY then + begin + //dekoduj zaznam + r := FSearchResult.Add; + n := 1; + r.ObjectName := ASNItem(n, t, x); + ASNItem(n, t, x); + if x = ASN1_SEQ then + begin + while n < Length(t) do + begin + s := ASNItem(n, t, x); + if x = ASN1_SEQ then + begin + i := n + Length(s); + a := r.Attributes.Add; + u := ASNItem(n, t, x); + a.AttributeName := u; + ASNItem(n, t, x); + if x = ASN1_SETOF then + while n < i do + begin + u := ASNItem(n, t, x); + a.Add(u); + end; + end; + end; + end; + end; + if FResponseCode = LDAP_ASN1_SEARCH_REFERENCE then + begin + n := 1; + while n < Length(t) do + FReferals.Add(ASNItem(n, t, x)); + end; + until FResponseCode = LDAP_ASN1_SEARCH_DONE; + Result := FResultCode = 0; +end; + +function TLDAPSend.Extended(const Name, Value: AnsiString): Boolean; +var + s, t: AnsiString; + x, xt: integer; +begin + s := ASNObject(Name, $80); + if Value <> '' then + s := s + ASNObject(Value, $81); + s := ASNObject(s, LDAP_ASN1_EXT_REQUEST); + Fsock.SendString(BuildPacket(s)); + s := ReceiveResponse; + t := DecodeResponse(s); + Result := FResultCode = 0; + if Result then + begin + x := 1; + FExtName := ASNItem(x, t, xt); + FExtValue := ASNItem(x, t, xt); + end; +end; + + +function TLDAPSend.StartTLS: Boolean; +begin + Result := Extended('1.3.6.1.4.1.1466.20037', ''); + if Result then + begin + Fsock.SSLDoConnect; + Result := FSock.LastError = 0; + end; +end; + +{==============================================================================} +function LDAPResultDump(const Value: TLDAPResultList): AnsiString; +var + n, m, o: integer; + r: TLDAPResult; + a: TLDAPAttribute; +begin + Result := 'Results: ' + IntToStr(Value.Count) + CRLF +CRLF; + for n := 0 to Value.Count - 1 do + begin + Result := Result + 'Result: ' + IntToStr(n) + CRLF; + r := Value[n]; + Result := Result + ' Object: ' + r.ObjectName + CRLF; + for m := 0 to r.Attributes.Count - 1 do + begin + a := r.Attributes[m]; + Result := Result + ' Attribute: ' + a.AttributeName + CRLF; + for o := 0 to a.Count - 1 do + Result := Result + ' ' + a[o] + CRLF; + end; + end; +end; + +end. diff --git a/synapse/licence.txt b/synapse/licence.txt new file mode 100644 index 0000000..f1f9255 --- /dev/null +++ b/synapse/licence.txt @@ -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. diff --git a/synapse/mimeinln.pas b/synapse/mimeinln.pas new file mode 100644 index 0000000..924dd5f --- /dev/null +++ b/synapse/mimeinln.pas @@ -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. diff --git a/synapse/mimemess.pas b/synapse/mimemess.pas new file mode 100644 index 0000000..0ad814d --- /dev/null +++ b/synapse/mimemess.pas @@ -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. diff --git a/synapse/mimepart.pas b/synapse/mimepart.pas new file mode 100644 index 0000000..a637e67 --- /dev/null +++ b/synapse/mimepart.pas @@ -0,0 +1,1227 @@ +{==============================================================================| +| Project : Ararat Synapse | 002.009.000 | +|==============================================================================| +| Content: MIME support procedures and functions | +|==============================================================================| +| Copyright (c)1999-200812 | +| | +| 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 part handling) +Handling with MIME parts. + +Used RFC: RFC-2045 +} + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$H+} +{$Q-} +{$R-} +{$M+} + +{$IFDEF UNICODE} + {$WARN IMPLICIT_STRING_CAST OFF} + {$WARN IMPLICIT_STRING_CAST_LOSS OFF} +{$ENDIF} + +unit mimepart; + +interface + +uses + SysUtils, Classes, + synafpc, + synachar, synacode, synautil, mimeinln; + +type + + TMimePart = class; + + {:@abstract(Procedural type for @link(TMimepart.Walkpart) hook). This hook is used for + easy walking through MIME subparts.} + THookWalkPart = procedure(const Sender: TMimePart) of object; + + {:The four types of MIME parts. (textual, multipart, message or any other + binary data.)} + TMimePrimary = (MP_TEXT, MP_MULTIPART, MP_MESSAGE, MP_BINARY); + + {:The various types of possible part encodings.} + TMimeEncoding = (ME_7BIT, ME_8BIT, ME_QUOTED_PRINTABLE, + ME_BASE64, ME_UU, ME_XX); + + {:@abstract(Object for working with parts of MIME e-mail.) + Each TMimePart object can handle any number of nested subparts as new + TMimepart objects. It can handle any tree hierarchy structure of nested MIME + subparts itself. + + Basic tasks are: + + Decoding of MIME message: + - store message into Lines property + - call DecomposeParts. Now you have decomposed MIME parts in all nested levels! + - now you can explore all properties and subparts. (You can use WalkPart method) + - if you need decode part, call DecodePart. + + Encoding of MIME message: + + - if you need multipart message, you must create subpart by AddSubPart. + - set all properties of all parts. + - set content of part into DecodedLines stream + - encode this stream by EncodePart. + - compose full message by ComposeParts. (it build full MIME message from all subparts. Do not call this method for each subpart! It is needed on root part!) + - encoded MIME message is stored in Lines property. + } + TMimePart = class(TObject) + private + FPrimary: string; + FPrimaryCode: TMimePrimary; + FSecondary: string; + FEncoding: string; + FEncodingCode: TMimeEncoding; + FDefaultCharset: string; + FCharset: string; + FCharsetCode: TMimeChar; + FTargetCharset: TMimeChar; + FDescription: string; + FDisposition: string; + FContentID: string; + FBoundary: string; + FFileName: string; + FLines: TStringList; + FPartBody: TStringList; + FHeaders: TStringList; + FPrePart: TStringList; + FPostPart: TStringList; + FDecodedLines: TMemoryStream; + FSubParts: TList; + FOnWalkPart: THookWalkPart; + FMaxLineLength: integer; + FSubLevel: integer; + FMaxSubLevel: integer; + FAttachInside: boolean; + FConvertCharset: Boolean; + FForcedHTMLConvert: Boolean; + FBinaryDecomposer: boolean; + procedure SetPrimary(Value: string); + procedure SetEncoding(Value: string); + procedure SetCharset(Value: string); + function IsUUcode(Value: string): boolean; + public + constructor Create; + destructor Destroy; override; + + {:Assign content of another object to this object. (Only this part, + not subparts!)} + procedure Assign(Value: TMimePart); + + {:Assign content of another object to this object. (With all subparts!)} + procedure AssignSubParts(Value: TMimePart); + + {:Clear all data values to default values. It also call @link(ClearSubparts).} + procedure Clear; + + {:Decode Mime part from @link(Lines) to @link(DecodedLines).} + procedure DecodePart; + + {:Parse header lines from Headers property into another properties.} + procedure DecodePartHeader; + + {:Encode mime part from @link(DecodedLines) to @link(Lines) and build mime + headers.} + procedure EncodePart; + + {:Build header lines in Headers property from another properties.} + procedure EncodePartHeader; + + {:generate primary and secondary mime type from filename extension in value. + If type not recognised, it return 'Application/octet-string' type.} + procedure MimeTypeFromExt(Value: string); + + {:Return number of decomposed subparts. (On this level! Each of this + subparts can hold any number of their own nested subparts!)} + function GetSubPartCount: integer; + + {:Get nested subpart object as new TMimePart. For getting maximum possible + index you can use @link(GetSubPartCount) method.} + function GetSubPart(index: integer): TMimePart; + + {:delete subpart on given index.} + procedure DeleteSubPart(index: integer); + + {:Clear and destroy all subpart TMimePart objects.} + procedure ClearSubParts; + + {:Add and create new subpart.} + function AddSubPart: TMimePart; + + {:E-mail message in @link(Lines) property is parsed into this object. + E-mail headers are stored in @link(Headers) property and is parsed into + another properties automaticly. Not need call @link(DecodePartHeader)! + Content of message (part) is stored into @link(PartBody) property. This + part is in undecoded form! If you need decode it, then you must call + @link(DecodePart) method by your hands. Lot of another properties is filled + also. + + Decoding of parts you must call separately due performance reasons. (Not + needed to decode all parts in all reasons.) + + For each MIME subpart is created new TMimepart object (accessible via + method @link(GetSubPart)).} + procedure DecomposeParts; + + {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(DecomposeParts). + } + procedure DecomposePartsBinary(AHeader:TStrings; AStx,AEtx:PANSIChar); + {/pf} + + {:This part and all subparts is composed into one MIME message stored in + @link(Lines) property.} + procedure ComposeParts; + + {:By calling this method is called @link(OnWalkPart) event for each part + and their subparts. It is very good for calling some code for each part in + MIME message} + procedure WalkPart; + + {:Return @true when is possible create next subpart. (@link(maxSublevel) + is still not reached)} + function CanSubPart: boolean; + published + {:Primary Mime type of part. (i.e. 'application') Writing to this property + automaticly generate value of @link(PrimaryCode).} + property Primary: string read FPrimary write SetPrimary; + + {:String representation of used Mime encoding in part. (i.e. 'base64') + Writing to this property automaticly generate value of @link(EncodingCode).} + property Encoding: string read FEncoding write SetEncoding; + + {:String representation of used Mime charset in part. (i.e. 'iso-8859-1') + Writing to this property automaticly generate value of @link(CharsetCode). + Charset is used only for text parts.} + property Charset: string read FCharset write SetCharset; + + {:Define default charset for decoding text MIME parts without charset + specification. Default value is 'ISO-8859-1' by RCF documents. + But Microsoft Outlook use windows codings as default. This property allows + properly decode textual parts from some broken versions of Microsoft + Outlook. (this is bad software!)} + property DefaultCharset: string read FDefaultCharset write FDefaultCharset; + + {:Decoded primary type. Possible values are: MP_TEXT, MP_MULTIPART, + MP_MESSAGE and MP_BINARY. If type not recognised, result is MP_BINARY.} + property PrimaryCode: TMimePrimary read FPrimaryCode Write FPrimaryCode; + + {:Decoded encoding type. Possible values are: ME_7BIT, ME_8BIT, + ME_QUOTED_PRINTABLE and ME_BASE64. If type not recognised, result is + ME_7BIT.} + property EncodingCode: TMimeEncoding read FEncodingCode Write FEncodingCode; + + {:Decoded charset type. Possible values are defined in @link(SynaChar) unit.} + property CharsetCode: TMimeChar read FCharsetCode Write FCharsetCode; + + {:System charset type. Default value is charset used by default in your + operating system.} + property TargetCharset: TMimeChar read FTargetCharset Write FTargetCharset; + + {:If @true, then do internal charset translation of part content between @link(CharsetCode) + and @link(TargetCharset)} + property ConvertCharset: Boolean read FConvertCharset Write FConvertCharset; + + {:If @true, then allways do internal charset translation of HTML parts + by MIME even it have their own charset in META tag. Default is @false.} + property ForcedHTMLConvert: Boolean read FForcedHTMLConvert Write FForcedHTMLConvert; + + {:Secondary Mime type of part. (i.e. 'mixed')} + property Secondary: string read FSecondary Write FSecondary; + + {:Description of Mime part.} + property Description: string read FDescription Write FDescription; + + {:Value of content disposition field. (i.e. 'inline' or 'attachment')} + property Disposition: string read FDisposition Write FDisposition; + + {:Content ID.} + property ContentID: string read FContentID Write FContentID; + + {:Boundary delimiter of multipart Mime part. Used only in multipart part.} + property Boundary: string read FBoundary Write FBoundary; + + {:Filename of file in binary part.} + property FileName: string read FFileName Write FFileName; + + {:String list with lines contains mime part (It can be a full message).} + property Lines: TStringList read FLines; + + {:Encoded form of MIME part data.} + property PartBody: TStringList read FPartBody; + + {:All header lines of MIME part.} + property Headers: TStringList read FHeaders; + + {:On multipart this contains part of message between first line of message + and first boundary.} + property PrePart: TStringList read FPrePart; + + {:On multipart this contains part of message between last boundary and end + of message.} + property PostPart: TStringList read FPostPart; + + {:Stream with decoded form of budy part.} + property DecodedLines: TMemoryStream read FDecodedLines; + + {:Show nested level in subpart tree. Value 0 means root part. 1 means + subpart from this root. etc.} + property SubLevel: integer read FSubLevel write FSubLevel; + + {:Specify maximum sublevel value for decomposing.} + property MaxSubLevel: integer read FMaxSubLevel write FMaxSubLevel; + + {:When is @true, then this part maybe(!) have included some uuencoded binary + data.} + property AttachInside: boolean read FAttachInside; + + {:Here you can assign hook procedure for walking through all part and their + subparts.} + property OnWalkPart: THookWalkPart read FOnWalkPart write FOnWalkPart; + + {:Here you can specify maximum line length for encoding of MIME part. + If line is longer, then is splitted by standard of MIME. Correct MIME + mailers can de-split this line into original length.} + property MaxLineLength: integer read FMaxLineLength Write FMaxLineLength; + end; + +const + MaxMimeType = 25; + MimeType: array[0..MaxMimeType, 0..2] of string = + ( + ('AU', 'audio', 'basic'), + ('AVI', 'video', 'x-msvideo'), + ('BMP', 'image', 'BMP'), + ('DOC', 'application', 'MSWord'), + ('EPS', 'application', 'Postscript'), + ('GIF', 'image', 'GIF'), + ('JPEG', 'image', 'JPEG'), + ('JPG', 'image', 'JPEG'), + ('MID', 'audio', 'midi'), + ('MOV', 'video', 'quicktime'), + ('MPEG', 'video', 'MPEG'), + ('MPG', 'video', 'MPEG'), + ('MP2', 'audio', 'mpeg'), + ('MP3', 'audio', 'mpeg'), + ('PDF', 'application', 'PDF'), + ('PNG', 'image', 'PNG'), + ('PS', 'application', 'Postscript'), + ('QT', 'video', 'quicktime'), + ('RA', 'audio', 'x-realaudio'), + ('RTF', 'application', 'RTF'), + ('SND', 'audio', 'basic'), + ('TIF', 'image', 'TIFF'), + ('TIFF', 'image', 'TIFF'), + ('WAV', 'audio', 'x-wav'), + ('WPD', 'application', 'Wordperfect5.1'), + ('ZIP', 'application', 'ZIP') + ); + +{:Generates a unique boundary string.} +function GenerateBoundary: string; + +implementation + +{==============================================================================} + +constructor TMIMEPart.Create; +begin + inherited Create; + FOnWalkPart := nil; + FLines := TStringList.Create; + FPartBody := TStringList.Create; + FHeaders := TStringList.Create; + FPrePart := TStringList.Create; + FPostPart := TStringList.Create; + FDecodedLines := TMemoryStream.Create; + FSubParts := TList.Create; + FTargetCharset := GetCurCP; + //was 'US-ASCII' before, but RFC-ignorant Outlook sometimes using default + //system charset instead. + FDefaultCharset := GetIDFromCP(GetCurCP); + FMaxLineLength := 78; + FSubLevel := 0; + FMaxSubLevel := -1; + FAttachInside := false; + FConvertCharset := true; + FForcedHTMLConvert := false; +end; + +destructor TMIMEPart.Destroy; +begin + ClearSubParts; + FSubParts.Free; + FDecodedLines.Free; + FPartBody.Free; + FLines.Free; + FHeaders.Free; + FPrePart.Free; + FPostPart.Free; + inherited Destroy; +end; + +{==============================================================================} + +procedure TMIMEPart.Clear; +begin + FPrimary := ''; + FEncoding := ''; + FCharset := ''; + FPrimaryCode := MP_TEXT; + FEncodingCode := ME_7BIT; + FCharsetCode := ISO_8859_1; + FTargetCharset := GetCurCP; + FSecondary := ''; + FDisposition := ''; + FContentID := ''; + FDescription := ''; + FBoundary := ''; + FFileName := ''; + FAttachInside := False; + FPartBody.Clear; + FHeaders.Clear; + FPrePart.Clear; + FPostPart.Clear; + FDecodedLines.Clear; + FConvertCharset := true; + FForcedHTMLConvert := false; + ClearSubParts; +end; + +{==============================================================================} + +procedure TMIMEPart.Assign(Value: TMimePart); +begin + Primary := Value.Primary; + Encoding := Value.Encoding; + Charset := Value.Charset; + DefaultCharset := Value.DefaultCharset; + PrimaryCode := Value.PrimaryCode; + EncodingCode := Value.EncodingCode; + CharsetCode := Value.CharsetCode; + TargetCharset := Value.TargetCharset; + Secondary := Value.Secondary; + Description := Value.Description; + Disposition := Value.Disposition; + ContentID := Value.ContentID; + Boundary := Value.Boundary; + FileName := Value.FileName; + Lines.Assign(Value.Lines); + PartBody.Assign(Value.PartBody); + Headers.Assign(Value.Headers); + PrePart.Assign(Value.PrePart); + PostPart.Assign(Value.PostPart); + MaxLineLength := Value.MaxLineLength; + FAttachInside := Value.AttachInside; + FConvertCharset := Value.ConvertCharset; +end; + +{==============================================================================} + +procedure TMIMEPart.AssignSubParts(Value: TMimePart); +var + n: integer; + p: TMimePart; +begin + Assign(Value); + for n := 0 to Value.GetSubPartCount - 1 do + begin + p := AddSubPart; + p.AssignSubParts(Value.GetSubPart(n)); + end; +end; + +{==============================================================================} + +function TMIMEPart.GetSubPartCount: integer; +begin + Result := FSubParts.Count; +end; + +{==============================================================================} + +function TMIMEPart.GetSubPart(index: integer): TMimePart; +begin + Result := nil; + if Index < GetSubPartCount then + Result := TMimePart(FSubParts[Index]); +end; + +{==============================================================================} + +procedure TMIMEPart.DeleteSubPart(index: integer); +begin + if Index < GetSubPartCount then + begin + GetSubPart(Index).Free; + FSubParts.Delete(Index); + end; +end; + +{==============================================================================} + +procedure TMIMEPart.ClearSubParts; +var + n: integer; +begin + for n := 0 to GetSubPartCount - 1 do + TMimePart(FSubParts[n]).Free; + FSubParts.Clear; +end; + +{==============================================================================} + +function TMIMEPart.AddSubPart: TMimePart; +begin + Result := TMimePart.Create; + Result.DefaultCharset := FDefaultCharset; + FSubParts.Add(Result); + Result.SubLevel := FSubLevel + 1; + Result.MaxSubLevel := FMaxSubLevel; +end; + +{==============================================================================} + +procedure TMIMEPart.DecomposeParts; +var + x: integer; + s: string; + Mime: TMimePart; + + procedure SkipEmpty; + begin + while FLines.Count > x do + begin + s := TrimRight(FLines[x]); + if s <> '' then + Break; + Inc(x); + end; + end; + +begin + FBinaryDecomposer := false; + x := 0; + Clear; + //extract headers + while FLines.Count > x do + begin + s := NormalizeHeader(FLines, x); + if s = '' then + Break; + FHeaders.Add(s); + end; + DecodePartHeader; + //extract prepart + if FPrimaryCode = MP_MULTIPART then + begin + while FLines.Count > x do + begin + s := FLines[x]; + Inc(x); + if TrimRight(s) = '--' + FBoundary then + Break; + FPrePart.Add(s); + if not FAttachInside then + FAttachInside := IsUUcode(s); + end; + end; + //extract body part + if FPrimaryCode = MP_MULTIPART then + begin + repeat + if CanSubPart then + begin + Mime := AddSubPart; + while FLines.Count > x do + begin + s := FLines[x]; + Inc(x); + if Pos('--' + FBoundary, s) = 1 then + Break; + Mime.Lines.Add(s); + end; + Mime.DecomposeParts; + end + else + begin + s := FLines[x]; + Inc(x); + FPartBody.Add(s); + end; + if x >= FLines.Count then + break; + until s = '--' + FBoundary + '--'; + end; + if (FPrimaryCode = MP_MESSAGE) and CanSubPart then + begin + Mime := AddSubPart; + SkipEmpty; + while FLines.Count > x do + begin + s := TrimRight(FLines[x]); + Inc(x); + Mime.Lines.Add(s); + end; + Mime.DecomposeParts; + end + else + begin + while FLines.Count > x do + begin + s := FLines[x]; + Inc(x); + FPartBody.Add(s); + if not FAttachInside then + FAttachInside := IsUUcode(s); + end; + end; + //extract postpart + if FPrimaryCode = MP_MULTIPART then + begin + while FLines.Count > x do + begin + s := TrimRight(FLines[x]); + Inc(x); + FPostPart.Add(s); + if not FAttachInside then + FAttachInside := IsUUcode(s); + end; + end; +end; + +procedure TMIMEPart.DecomposePartsBinary(AHeader:TStrings; AStx,AEtx:PANSIChar); +var + x: integer; + s: ANSIString; + Mime: TMimePart; + BOP: PANSIChar; // Beginning of Part + EOP: PANSIChar; // End of Part + + function ___HasUUCode(ALines:TStrings): boolean; + var + x: integer; + begin + Result := FALSE; + for x:=0 to ALines.Count-1 do + if IsUUcode(ALInes[x]) then + begin + Result := TRUE; + exit; + end; + end; + +begin + FBinaryDecomposer := true; + Clear; + // Parse passed headers (THTTPSend returns HTTP headers and body separately) + x := 0; + while x<AHeader.Count do + begin + s := NormalizeHeader(AHeader,x); + if s = '' then + Break; + FHeaders.Add(s); + end; + DecodePartHeader; + // Extract prepart + if FPrimaryCode=MP_MULTIPART then + begin + CopyLinesFromStreamUntilBoundary(AStx,AEtx,FPrePart,FBoundary); + FAttachInside := FAttachInside or ___HasUUCode(FPrePart); + end; + // Extract body part + if FPrimaryCode=MP_MULTIPART then + begin + repeat + if CanSubPart then + begin + Mime := AddSubPart; + BOP := AStx; + EOP := SearchForBoundary(AStx,AEtx,FBoundary); + CopyLinesFromStreamUntilNullLine(BOP,EOP,Mime.Lines); + Mime.DecomposePartsBinary(Mime.Lines,BOP,EOP); + end + else + begin + EOP := SearchForBoundary(AStx,AEtx,FBoundary); + FPartBody.Add(BuildStringFromBuffer(AStx,EOP)); + end; + // + BOP := MatchLastBoundary(EOP,AEtx,FBoundary); + if Assigned(BOP) then + begin + AStx := BOP; + Break; + end; + until FALSE; + end; + // Extract nested MIME message + if (FPrimaryCode=MP_MESSAGE) and CanSubPart then + begin + Mime := AddSubPart; + SkipNullLines(AStx,AEtx); + CopyLinesFromStreamUntilNullLine(AStx,AEtx,Mime.Lines); + Mime.DecomposePartsBinary(Mime.Lines,AStx,AEtx); + end + // Extract body of single part + else + begin + FPartBody.Add(BuildStringFromBuffer(AStx,AEtx)); + FAttachInside := FAttachInside or ___HasUUCode(FPartBody); + end; + // Extract postpart + if FPrimaryCode=MP_MULTIPART then + begin + CopyLinesFromStreamUntilBoundary(AStx,AEtx,FPostPart,''); + FAttachInside := FAttachInside or ___HasUUCode(FPostPart); + end; +end; +{/pf} + +{==============================================================================} + +procedure TMIMEPart.ComposeParts; +var + n: integer; + mime: TMimePart; + s, t: string; + d1, d2, d3: integer; + x: integer; +begin + FLines.Clear; + //add headers + for n := 0 to FHeaders.Count -1 do + begin + s := FHeaders[n]; + repeat + if Length(s) < FMaxLineLength then + begin + t := s; + s := ''; + end + else + begin + d1 := RPosEx('; ', s, FMaxLineLength); + d2 := RPosEx(' ', s, FMaxLineLength); + d3 := RPosEx(', ', s, FMaxLineLength); + if (d1 <= 1) and (d2 <= 1) and (d3 <= 1) then + begin + x := Pos(' ', Copy(s, 2, Length(s) - 1)); + if x < 1 then + x := Length(s); + end + else + if d1 > 0 then + x := d1 + else + if d3 > 0 then + x := d3 + else + x := d2 - 1; + t := Copy(s, 1, x); + Delete(s, 1, x); + end; + Flines.Add(t); + until s = ''; + end; + + Flines.Add(''); + //add body + //if multipart + if FPrimaryCode = MP_MULTIPART then + begin + Flines.AddStrings(FPrePart); + for n := 0 to GetSubPartCount - 1 do + begin + Flines.Add('--' + FBoundary); + mime := GetSubPart(n); + mime.ComposeParts; + FLines.AddStrings(mime.Lines); + end; + Flines.Add('--' + FBoundary + '--'); + Flines.AddStrings(FPostPart); + end; + //if message + if FPrimaryCode = MP_MESSAGE then + begin + if GetSubPartCount > 0 then + begin + mime := GetSubPart(0); + mime.ComposeParts; + FLines.AddStrings(mime.Lines); + end; + end + else + //if normal part + begin + FLines.AddStrings(FPartBody); + end; +end; + +{==============================================================================} + +procedure TMIMEPart.DecodePart; +var + n: Integer; + s, t, t2: string; + b: Boolean; +begin + FDecodedLines.Clear; + {pf} + // The part decomposer passes data via TStringList which appends trailing line + // break inherently. But in a case of native 8-bit data transferred withouth + // encoding (default e.g. for HTTP protocol), the redundant line terminators + // has to be removed + if FBinaryDecomposer and (FPartBody.Count=1) then + begin + case FEncodingCode of + ME_QUOTED_PRINTABLE: + s := DecodeQuotedPrintable(FPartBody[0]); + ME_BASE64: + s := DecodeBase64(FPartBody[0]); + ME_UU, ME_XX: + begin + s := ''; + for n := 0 to FPartBody.Count - 1 do + if FEncodingCode = ME_UU then + s := s + DecodeUU(FPartBody[n]) + else + s := s + DecodeXX(FPartBody[n]); + end; + else + s := FPartBody[0]; + end; + end + else + {/pf} + case FEncodingCode of + ME_QUOTED_PRINTABLE: + s := DecodeQuotedPrintable(FPartBody.Text); + ME_BASE64: + s := DecodeBase64(FPartBody.Text); + ME_UU, ME_XX: + begin + s := ''; + for n := 0 to FPartBody.Count - 1 do + if FEncodingCode = ME_UU then + s := s + DecodeUU(FPartBody[n]) + else + s := s + DecodeXX(FPartBody[n]); + end; + else + s := FPartBody.Text; + end; + if FConvertCharset and (FPrimaryCode = MP_TEXT) then + if (not FForcedHTMLConvert) and (uppercase(FSecondary) = 'HTML') then + begin + b := false; + t2 := uppercase(s); + t := SeparateLeft(t2, '</HEAD>'); + if length(t) <> length(s) then + begin + t := SeparateRight(t, '<HEAD>'); + t := ReplaceString(t, '"', ''); + t := ReplaceString(t, ' ', ''); + b := Pos('HTTP-EQUIV=CONTENT-TYPE', t) > 0; + end; + //workaround for shitty M$ Outlook 11 which is placing this information + //outside <head> section + if not b then + begin + t := Copy(t2, 1, 2048); + t := ReplaceString(t, '"', ''); + t := ReplaceString(t, ' ', ''); + b := Pos('HTTP-EQUIV=CONTENT-TYPE', t) > 0; + end; + if not b then + s := CharsetConversion(s, FCharsetCode, FTargetCharset); + end + else + s := CharsetConversion(s, FCharsetCode, FTargetCharset); + WriteStrToStream(FDecodedLines, s); + FDecodedLines.Seek(0, soFromBeginning); +end; + +{==============================================================================} + +procedure TMIMEPart.DecodePartHeader; +var + n: integer; + s, su, fn: string; + st, st2: string; +begin + Primary := 'text'; + FSecondary := 'plain'; + FDescription := ''; + Charset := FDefaultCharset; + FFileName := ''; + //was 7bit before, but this is more compatible with RFC-ignorant outlook + Encoding := '8BIT'; + FDisposition := ''; + FContentID := ''; + fn := ''; + for n := 0 to FHeaders.Count - 1 do + if FHeaders[n] <> '' then + begin + s := FHeaders[n]; + su := UpperCase(s); + if Pos('CONTENT-TYPE:', su) = 1 then + begin + st := Trim(SeparateRight(su, ':')); + st2 := Trim(SeparateLeft(st, ';')); + Primary := Trim(SeparateLeft(st2, '/')); + FSecondary := Trim(SeparateRight(st2, '/')); + if (FSecondary = Primary) and (Pos('/', st2) < 1) then + FSecondary := ''; + case FPrimaryCode of + MP_TEXT: + begin + Charset := UpperCase(GetParameter(s, 'charset')); + FFileName := GetParameter(s, 'name'); + end; + MP_MULTIPART: + FBoundary := GetParameter(s, 'Boundary'); + MP_MESSAGE: + begin + end; + MP_BINARY: + FFileName := GetParameter(s, 'name'); + end; + end; + if Pos('CONTENT-TRANSFER-ENCODING:', su) = 1 then + Encoding := Trim(SeparateRight(su, ':')); + if Pos('CONTENT-DESCRIPTION:', su) = 1 then + FDescription := Trim(SeparateRight(s, ':')); + if Pos('CONTENT-DISPOSITION:', su) = 1 then + begin + FDisposition := SeparateRight(su, ':'); + FDisposition := Trim(SeparateLeft(FDisposition, ';')); + fn := GetParameter(s, 'FileName'); + end; + if Pos('CONTENT-ID:', su) = 1 then + FContentID := Trim(SeparateRight(s, ':')); + end; + if fn <> '' then + FFileName := fn; + FFileName := InlineDecode(FFileName, FTargetCharset); + FFileName := ExtractFileName(FFileName); +end; + +{==============================================================================} + +procedure TMIMEPart.EncodePart; +var + l: TStringList; + s, t: string; + n, x: Integer; + d1, d2: integer; +begin + if (FEncodingCode = ME_UU) or (FEncodingCode = ME_XX) then + Encoding := 'base64'; + l := TStringList.Create; + FPartBody.Clear; + FDecodedLines.Seek(0, soFromBeginning); + try + case FPrimaryCode of + MP_MULTIPART, MP_MESSAGE: + FPartBody.LoadFromStream(FDecodedLines); + MP_TEXT, MP_BINARY: + begin + s := ReadStrFromStream(FDecodedLines, FDecodedLines.Size); + if FConvertCharset and (FPrimaryCode = MP_TEXT) and (FEncodingCode <> ME_7BIT) then + s := GetBOM(FCharSetCode) + CharsetConversion(s, FTargetCharset, FCharsetCode); + if FEncodingCode = ME_BASE64 then + begin + x := 1; + while x <= length(s) do + begin + t := copy(s, x, 54); + x := x + length(t); + t := EncodeBase64(t); + FPartBody.Add(t); + end; + end + else + begin + if FPrimaryCode = MP_BINARY then + l.Add(s) + else + l.Text := s; + for n := 0 to l.Count - 1 do + begin + s := l[n]; + if FEncodingCode = ME_QUOTED_PRINTABLE then + begin + s := EncodeQuotedPrintable(s); + repeat + if Length(s) < FMaxLineLength then + begin + t := s; + s := ''; + end + else + begin + d1 := RPosEx('=', s, FMaxLineLength); + d2 := RPosEx(' ', s, FMaxLineLength); + if (d1 = 0) and (d2 = 0) then + x := FMaxLineLength + else + if d1 > d2 then + x := d1 - 1 + else + x := d2 - 1; + if x = 0 then + x := FMaxLineLength; + t := Copy(s, 1, x); + Delete(s, 1, x); + if s <> '' then + t := t + '='; + end; + FPartBody.Add(t); + until s = ''; + end + else + FPartBody.Add(s); + end; + if (FPrimaryCode = MP_BINARY) + and (FEncodingCode = ME_QUOTED_PRINTABLE) then + FPartBody[FPartBody.Count - 1] := FPartBody[FPartBody.Count - 1] + '='; + end; + end; + end; + finally + l.Free; + end; +end; + +{==============================================================================} + +procedure TMIMEPart.EncodePartHeader; +var + s: string; +begin + FHeaders.Clear; + if FSecondary = '' then + case FPrimaryCode of + MP_TEXT: + FSecondary := 'plain'; + MP_MULTIPART: + FSecondary := 'mixed'; + MP_MESSAGE: + FSecondary := 'rfc822'; + MP_BINARY: + FSecondary := 'octet-stream'; + end; + if FDescription <> '' then + FHeaders.Insert(0, 'Content-Description: ' + FDescription); + if FDisposition <> '' then + begin + s := ''; + if FFileName <> '' then + s := '; FileName=' + QuoteStr(InlineCodeEx(FileName, FTargetCharset), '"'); + FHeaders.Insert(0, 'Content-Disposition: ' + LowerCase(FDisposition) + s); + end; + if FContentID <> '' then + FHeaders.Insert(0, 'Content-ID: ' + FContentID); + + case FEncodingCode of + ME_7BIT: + s := '7bit'; + ME_8BIT: + s := '8bit'; + ME_QUOTED_PRINTABLE: + s := 'Quoted-printable'; + ME_BASE64: + s := 'Base64'; + end; + case FPrimaryCode of + MP_TEXT, + MP_BINARY: FHeaders.Insert(0, 'Content-Transfer-Encoding: ' + s); + end; + case FPrimaryCode of + MP_TEXT: + s := FPrimary + '/' + FSecondary + '; charset=' + GetIDfromCP(FCharsetCode); + MP_MULTIPART: + s := FPrimary + '/' + FSecondary + '; boundary="' + FBoundary + '"'; + MP_MESSAGE, MP_BINARY: + s := FPrimary + '/' + FSecondary; + end; + if FFileName <> '' then + s := s + '; name=' + QuoteStr(InlineCodeEx(FileName, FTargetCharset), '"'); + FHeaders.Insert(0, 'Content-type: ' + s); +end; + +{==============================================================================} + +procedure TMIMEPart.MimeTypeFromExt(Value: string); +var + s: string; + n: Integer; +begin + Primary := ''; + FSecondary := ''; + s := UpperCase(ExtractFileExt(Value)); + if s = '' then + s := UpperCase(Value); + s := SeparateRight(s, '.'); + for n := 0 to MaxMimeType do + if MimeType[n, 0] = s then + begin + Primary := MimeType[n, 1]; + FSecondary := MimeType[n, 2]; + Break; + end; + if Primary = '' then + Primary := 'application'; + if FSecondary = '' then + FSecondary := 'octet-stream'; +end; + +{==============================================================================} + +procedure TMIMEPart.WalkPart; +var + n: integer; + m: TMimepart; +begin + if assigned(OnWalkPart) then + begin + OnWalkPart(self); + for n := 0 to GetSubPartCount - 1 do + begin + m := GetSubPart(n); + m.OnWalkPart := OnWalkPart; + m.WalkPart; + end; + end; +end; + +{==============================================================================} + +procedure TMIMEPart.SetPrimary(Value: string); +var + s: string; +begin + FPrimary := Value; + s := UpperCase(Value); + FPrimaryCode := MP_BINARY; + if Pos('TEXT', s) = 1 then + FPrimaryCode := MP_TEXT; + if Pos('MULTIPART', s) = 1 then + FPrimaryCode := MP_MULTIPART; + if Pos('MESSAGE', s) = 1 then + FPrimaryCode := MP_MESSAGE; +end; + +procedure TMIMEPart.SetEncoding(Value: string); +var + s: string; +begin + FEncoding := Value; + s := UpperCase(Value); + FEncodingCode := ME_7BIT; + if Pos('8BIT', s) = 1 then + FEncodingCode := ME_8BIT; + if Pos('QUOTED-PRINTABLE', s) = 1 then + FEncodingCode := ME_QUOTED_PRINTABLE; + if Pos('BASE64', s) = 1 then + FEncodingCode := ME_BASE64; + if Pos('X-UU', s) = 1 then + FEncodingCode := ME_UU; + if Pos('X-XX', s) = 1 then + FEncodingCode := ME_XX; +end; + +procedure TMIMEPart.SetCharset(Value: string); +begin + if value <> '' then + begin + FCharset := Value; + FCharsetCode := GetCPFromID(Value); + end; +end; + +function TMIMEPart.CanSubPart: boolean; +begin + Result := True; + if FMaxSubLevel <> -1 then + Result := FMaxSubLevel > FSubLevel; +end; + +function TMIMEPart.IsUUcode(Value: string): boolean; +begin + Value := UpperCase(Value); + Result := (pos('BEGIN ', Value) = 1) and (Trim(SeparateRight(Value, ' ')) <> ''); +end; + +{==============================================================================} + +function GenerateBoundary: string; +var + x, y: Integer; +begin + y := GetTick; + x := y; + while TickDelta(y, x) = 0 do + begin + Sleep(1); + x := GetTick; + end; + Randomize; + y := Random(MaxInt); + Result := IntToHex(x, 8) + '_' + IntToHex(y, 8) + '_Synapse_boundary'; +end; + +end. diff --git a/synapse/nntpsend.pas b/synapse/nntpsend.pas new file mode 100644 index 0000000..ec1af16 --- /dev/null +++ b/synapse/nntpsend.pas @@ -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. diff --git a/synapse/pingsend.pas b/synapse/pingsend.pas new file mode 100644 index 0000000..1a4e331 --- /dev/null +++ b/synapse/pingsend.pas @@ -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; +{$IFDEF MSWINDOWS} +var + PingIp6: boolean; + PingHandle: integer; + r: integer; + ipo: TIP_OPTION_INFORMATION; + RBuff: Ansistring; + ip4reply: PICMP_ECHO_REPLY; + ip6reply: PICMPV6_ECHO_REPLY; + ip6: TSockAddrIn6; +begin + Result := False; + PingIp6 := Fsin.sin_family = AF_INET6; + if pingIp6 then + PingHandle := Icmp6CreateFile + else + PingHandle := IcmpCreateFile; + if PingHandle <> -1 then + begin + try + ipo.TTL := FTTL; + ipo.TOS := 0; + ipo.Flags := 0; + ipo.OptionsSize := 0; + ipo.OptionsData := nil; + setlength(RBuff, 4096); + if pingIp6 then + begin + FillChar(ip6, sizeof(ip6), 0); + r := Icmp6SendEcho2(PingHandle, nil, nil, nil, @ip6, @Fsin, + PAnsichar(FBuffer), length(FBuffer), @ipo, pAnsichar(RBuff), length(RBuff), FTimeout); + if r > 0 then + begin + RBuff := #0 + #0 + RBuff; + ip6reply := PICMPV6_ECHO_REPLY(pointer(RBuff)); + FPingTime := ip6reply^.RoundTripTime; + ip6reply^.Address.sin6_family := AF_INET6; + FReplyFrom := GetSinIp(TVarSin(ip6reply^.Address)); + TranslateErrorIpHlp(ip6reply^.Status); + Result := True; + end; + end + else + begin + r := IcmpSendEcho2(PingHandle, nil, nil, nil, Fsin.sin_addr, + PAnsichar(FBuffer), length(FBuffer), @ipo, pAnsichar(RBuff), length(RBuff), FTimeout); + if r > 0 then + begin + ip4reply := PICMP_ECHO_REPLY(pointer(RBuff)); + FPingTime := ip4reply^.RoundTripTime; + FReplyFrom := IpToStr(swapbytes(ip4reply^.Address.S_addr)); + TranslateErrorIpHlp(ip4reply^.Status); + Result := True; + end; + end + finally + IcmpCloseHandle(PingHandle); + end; + end; +end; +{$ELSE} +begin + result := false; +end; +{$ENDIF} + +{==============================================================================} + +function PingHost(const Host: string): Integer; +begin + with TPINGSend.Create do + try + Result := -1; + if Ping(Host) then + if ReplyError = IE_NoError then + Result := PingTime; + finally + Free; + end; +end; + +function TraceRouteHost(const Host: string): string; +var + Ping: TPingSend; + ttl : byte; +begin + Result := ''; + Ping := TPINGSend.Create; + try + ttl := 1; + repeat + ping.TTL := ttl; + inc(ttl); + if ttl > 30 then + Break; + if not ping.Ping(Host) then + begin + Result := Result + cAnyHost+ ' Timeout' + CRLF; + continue; + end; + if (ping.ReplyError <> IE_NoError) + and (ping.ReplyError <> IE_TTLExceed) then + begin + Result := Result + Ping.ReplyFrom + ' ' + Ping.ReplyErrorDesc + CRLF; + break; + end; + Result := Result + Ping.ReplyFrom + ' ' + IntToStr(Ping.PingTime) + CRLF; + until ping.ReplyError = IE_NoError; + finally + Ping.Free; + end; +end; + +{$IFDEF MSWINDOWS} +initialization +begin + IcmpHelper4 := false; + IcmpHelper6 := false; + IcmpDllHandle := LoadLibrary(DLLIcmpName); + if IcmpDllHandle <> 0 then + begin + IcmpCreateFile := GetProcAddress(IcmpDLLHandle, 'IcmpCreateFile'); + IcmpCloseHandle := GetProcAddress(IcmpDLLHandle, 'IcmpCloseHandle'); + IcmpSendEcho2 := GetProcAddress(IcmpDLLHandle, 'IcmpSendEcho2'); + Icmp6CreateFile := GetProcAddress(IcmpDLLHandle, 'Icmp6CreateFile'); + Icmp6SendEcho2 := GetProcAddress(IcmpDLLHandle, 'Icmp6SendEcho2'); + IcmpHelper4 := assigned(IcmpCreateFile) + and assigned(IcmpCloseHandle) + and assigned(IcmpSendEcho2); + IcmpHelper6 := assigned(Icmp6CreateFile) + and assigned(Icmp6SendEcho2); + end; +end; + +finalization +begin + FreeLibrary(IcmpDllHandle); +end; +{$ENDIF} + +end. diff --git a/synapse/pop3send.pas b/synapse/pop3send.pas new file mode 100644 index 0000000..05c5ac0 --- /dev/null +++ b/synapse/pop3send.pas @@ -0,0 +1,483 @@ +{==============================================================================| +| Project : Ararat Synapse | 002.006.002 | +|==============================================================================| +| Content: POP3 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)2001-2010. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +{:@abstract(POP3 protocol client) + +Used RFC: RFC-1734, RFC-1939, RFC-2195, RFC-2449, RFC-2595 +} + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$H+} +{$M+} + +{$IFDEF UNICODE} + {$WARN IMPLICIT_STRING_CAST OFF} + {$WARN IMPLICIT_STRING_CAST_LOSS OFF} +{$ENDIF} + +unit pop3send; + +interface + +uses + SysUtils, Classes, + blcksock, synautil, synacode; + +const + cPop3Protocol = '110'; + +type + + {:The three types of possible authorization methods for "logging in" to a POP3 + server.} + TPOP3AuthType = (POP3AuthAll, POP3AuthLogin, POP3AuthAPOP); + + {:@abstract(Implementation of POP3 client 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!} + TPOP3Send = class(TSynaClient) + private + FSock: TTCPBlockSocket; + FResultCode: Integer; + FResultString: string; + FFullResult: TStringList; + FStatCount: Integer; + FStatSize: Integer; + FListSize: Integer; + FTimeStamp: string; + FAuthType: TPOP3AuthType; + FPOP3cap: TStringList; + FAutoTLS: Boolean; + FFullSSL: Boolean; + function ReadResult(Full: Boolean): Integer; + function Connect: Boolean; + function AuthLogin: Boolean; + function AuthApop: Boolean; + public + constructor Create; + destructor Destroy; override; + + {:You can call any custom by this method. Call Command without trailing CRLF. + If MultiLine parameter is @true, multilined response are expected. + Result is @true on sucess.} + function CustomCommand(const Command: string; MultiLine: Boolean): boolean; + + {:Call CAPA command for get POP3 server capabilites. + note: not all servers support this command!} + function Capability: Boolean; + + {:Connect to remote POP3 host. If all OK, result is @true.} + function Login: Boolean; + + {:Disconnects from POP3 server.} + function Logout: Boolean; + + {:Send RSET command. If all OK, result is @true.} + function Reset: Boolean; + + {:Send NOOP command. If all OK, result is @true.} + function NoOp: Boolean; + + {:Send STAT command and fill @link(StatCount) and @link(StatSize) property. + If all OK, result is @true.} + function Stat: Boolean; + + {:Send LIST command. If Value is 0, LIST is for all messages. After + successful operation is listing in FullResult. If all OK, result is @True.} + function List(Value: Integer): Boolean; + + {:Send RETR command. After successful operation dowloaded message in + @link(FullResult). If all OK, result is @true.} + function Retr(Value: Integer): Boolean; + + {:Send RETR command. After successful operation dowloaded message in + @link(Stream). If all OK, result is @true.} + function RetrStream(Value: Integer; Stream: TStream): Boolean; + + {:Send DELE command for delete specified message. If all OK, result is @true.} + function Dele(Value: Integer): Boolean; + + {:Send TOP command. After successful operation dowloaded headers of message + and maxlines count of message in @link(FullResult). If all OK, result is + @true.} + function Top(Value, Maxlines: Integer): Boolean; + + {:Send UIDL command. If Value is 0, UIDL is for all messages. After + successful operation is listing in FullResult. If all OK, result is @True.} + function Uidl(Value: Integer): Boolean; + + {:Call STLS command for upgrade connection to SSL/TLS mode.} + function StartTLS: Boolean; + + {:Try to find given capabily in capabilty string returned from POP3 server + by CAPA command.} + function FindCap(const Value: string): string; + published + {:Result code of last POP3 operation. 0 - error, 1 - OK.} + property ResultCode: Integer read FResultCode; + + {:Result string of last POP3 operation.} + property ResultString: string read FResultString; + + {:Stringlist with full lines returned as result of POP3 operation. I.e. if + operation is LIST, this property is filled by list of messages. If + operation is RETR, this property have downloaded message.} + property FullResult: TStringList read FFullResult; + + {:After STAT command is there count of messages in inbox.} + property StatCount: Integer read FStatCount; + + {:After STAT command is there size of all messages in inbox.} + property StatSize: Integer read FStatSize; + + {:After LIST 0 command size of all messages on server, After LIST x size of message x on server} + property ListSize: Integer read FListSize; + + {:If server support this, after comnnect is in this property timestamp of + remote server.} + property TimeStamp: string read FTimeStamp; + + {:Type of authorisation for login to POP3 server. Dafault is autodetect one + of possible authorisation. Autodetect do this: + + If remote POP3 server support APOP, try login by APOP method. If APOP is + not supported, or if APOP login failed, try classic USER+PASS login method.} + property AuthType: TPOP3AuthType read FAuthType Write FAuthType; + + {: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 TPOP3Send.Create; +begin + inherited Create; + FFullResult := TStringList.Create; + FPOP3cap := TStringList.Create; + FSock := TTCPBlockSocket.Create; + FSock.Owner := self; + FSock.ConvertLineEnd := true; + FTimeout := 60000; + FTargetPort := cPop3Protocol; + FStatCount := 0; + FStatSize := 0; + FListSize := 0; + FAuthType := POP3AuthAll; + FAutoTLS := False; + FFullSSL := False; +end; + +destructor TPOP3Send.Destroy; +begin + FSock.Free; + FPOP3cap.Free; + FullResult.Free; + inherited Destroy; +end; + +function TPOP3Send.ReadResult(Full: Boolean): Integer; +var + s: AnsiString; +begin + Result := 0; + FFullResult.Clear; + s := FSock.RecvString(FTimeout); + if Pos('+OK', s) = 1 then + Result := 1; + FResultString := s; + if Full and (Result = 1) then + repeat + s := FSock.RecvString(FTimeout); + if s = '.' then + Break; + if s <> '' then + if s[1] = '.' then + Delete(s, 1, 1); + FFullResult.Add(s); + until FSock.LastError <> 0; + if not Full and (Result = 1) then + FFullResult.Add(SeparateRight(FResultString, ' ')); + if FSock.LastError <> 0 then + Result := 0; + FResultCode := Result; +end; + +function TPOP3Send.CustomCommand(const Command: string; MultiLine: Boolean): boolean; +begin + FSock.SendString(Command + CRLF); + Result := ReadResult(MultiLine) <> 0; +end; + +function TPOP3Send.AuthLogin: Boolean; +begin + Result := False; + if not CustomCommand('USER ' + FUserName, False) then + exit; + Result := CustomCommand('PASS ' + FPassword, False) +end; + +function TPOP3Send.AuthAPOP: Boolean; +var + s: string; +begin + s := StrToHex(MD5(FTimeStamp + FPassWord)); + Result := CustomCommand('APOP ' + FUserName + ' ' + s, False); +end; + +function TPOP3Send.Connect: Boolean; +begin + // Do not call this function! It is calling by LOGIN method! + FStatCount := 0; + FStatSize := 0; + FSock.CloseSocket; + FSock.LineBuffer := ''; + 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 TPOP3Send.Capability: Boolean; +begin + FPOP3cap.Clear; + Result := CustomCommand('CAPA', True); + if Result then + FPOP3cap.AddStrings(FFullResult); +end; + +function TPOP3Send.Login: Boolean; +var + s, s1: string; +begin + Result := False; + FTimeStamp := ''; + if not Connect then + Exit; + if ReadResult(False) <> 1 then + Exit; + s := SeparateRight(FResultString, '<'); + if s <> FResultString then + begin + s1 := Trim(SeparateLeft(s, '>')); + if s1 <> s then + FTimeStamp := '<' + s1 + '>'; + end; + Result := False; + if Capability then + if FAutoTLS and (Findcap('STLS') <> '') then + if StartTLS then + Capability + else + begin + Result := False; + Exit; + end; + if (FTimeStamp <> '') and not (FAuthType = POP3AuthLogin) then + begin + Result := AuthApop; + if not Result then + begin + if not Connect then + Exit; + if ReadResult(False) <> 1 then + Exit; + end; + end; + if not Result and not (FAuthType = POP3AuthAPOP) then + Result := AuthLogin; +end; + +function TPOP3Send.Logout: Boolean; +begin + Result := CustomCommand('QUIT', False); + FSock.CloseSocket; +end; + +function TPOP3Send.Reset: Boolean; +begin + Result := CustomCommand('RSET', False); +end; + +function TPOP3Send.NoOp: Boolean; +begin + Result := CustomCommand('NOOP', False); +end; + +function TPOP3Send.Stat: Boolean; +var + s: string; +begin + Result := CustomCommand('STAT', False); + if Result then + begin + s := SeparateRight(ResultString, '+OK '); + FStatCount := StrToIntDef(Trim(SeparateLeft(s, ' ')), 0); + FStatSize := StrToIntDef(Trim(SeparateRight(s, ' ')), 0); + end; +end; + +function TPOP3Send.List(Value: Integer): Boolean; +var + s: string; + n: integer; +begin + if Value = 0 then + s := 'LIST' + else + s := 'LIST ' + IntToStr(Value); + Result := CustomCommand(s, Value = 0); + FListSize := 0; + if Result then + if Value <> 0 then + begin + s := SeparateRight(ResultString, '+OK '); + FListSize := StrToIntDef(SeparateLeft(SeparateRight(s, ' '), ' '), 0); + end + else + for n := 0 to FFullResult.Count - 1 do + FListSize := FListSize + StrToIntDef(SeparateLeft(SeparateRight(s, ' '), ' '), 0); +end; + +function TPOP3Send.Retr(Value: Integer): Boolean; +begin + Result := CustomCommand('RETR ' + IntToStr(Value), True); +end; + +//based on code by Miha Vrhovnik +function TPOP3Send.RetrStream(Value: Integer; Stream: TStream): Boolean; +var + s: string; +begin + Result := False; + FFullResult.Clear; + Stream.Size := 0; + FSock.SendString('RETR ' + IntToStr(Value) + CRLF); + + s := FSock.RecvString(FTimeout); + if Pos('+OK', s) = 1 then + Result := True; + FResultString := s; + if Result then begin + repeat + s := FSock.RecvString(FTimeout); + if s = '.' then + Break; + if s <> '' then begin + if s[1] = '.' then + Delete(s, 1, 1); + end; + WriteStrToStream(Stream, s); + WriteStrToStream(Stream, CRLF); + until FSock.LastError <> 0; + end; + + if Result then + FResultCode := 1 + else + FResultCode := 0; +end; + +function TPOP3Send.Dele(Value: Integer): Boolean; +begin + Result := CustomCommand('DELE ' + IntToStr(Value), False); +end; + +function TPOP3Send.Top(Value, Maxlines: Integer): Boolean; +begin + Result := CustomCommand('TOP ' + IntToStr(Value) + ' ' + IntToStr(Maxlines), True); +end; + +function TPOP3Send.Uidl(Value: Integer): Boolean; +var + s: string; +begin + if Value = 0 then + s := 'UIDL' + else + s := 'UIDL ' + IntToStr(Value); + Result := CustomCommand(s, Value = 0); +end; + +function TPOP3Send.StartTLS: Boolean; +begin + Result := False; + if CustomCommand('STLS', False) then + begin + Fsock.SSLDoConnect; + Result := FSock.LastError = 0; + end; +end; + +function TPOP3Send.FindCap(const Value: string): string; +var + n: Integer; + s: string; +begin + s := UpperCase(Value); + Result := ''; + for n := 0 to FPOP3cap.Count - 1 do + if Pos(s, UpperCase(FPOP3cap[n])) = 1 then + begin + Result := FPOP3cap[n]; + Break; + end; +end; + +end. diff --git a/synapse/slogsend.pas b/synapse/slogsend.pas new file mode 100644 index 0000000..900f6c0 --- /dev/null +++ b/synapse/slogsend.pas @@ -0,0 +1,320 @@ +{==============================================================================| +| Project : Ararat Synapse | 001.002.003 | +|==============================================================================| +| Content: SysLog 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)2001-2010. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +| Christian Brosius | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +{:@abstract(BSD SYSLOG protocol) + +Used RFC: RFC-3164 +} + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$Q-} +{$H+} + +unit slogsend; + +interface + +uses + SysUtils, Classes, + blcksock, synautil; + +const + cSysLogProtocol = '514'; + + FCL_Kernel = 0; + FCL_UserLevel = 1; + FCL_MailSystem = 2; + FCL_System = 3; + FCL_Security = 4; + FCL_Syslogd = 5; + FCL_Printer = 6; + FCL_News = 7; + FCL_UUCP = 8; + FCL_Clock = 9; + FCL_Authorization = 10; + FCL_FTP = 11; + FCL_NTP = 12; + FCL_LogAudit = 13; + FCL_LogAlert = 14; + FCL_Time = 15; + FCL_Local0 = 16; + FCL_Local1 = 17; + FCL_Local2 = 18; + FCL_Local3 = 19; + FCL_Local4 = 20; + FCL_Local5 = 21; + FCL_Local6 = 22; + FCL_Local7 = 23; + +type + {:@abstract(Define possible priority of Syslog message)} + TSyslogSeverity = (Emergency, Alert, Critical, Error, Warning, Notice, Info, + Debug); + + {:@abstract(encoding or decoding of SYSLOG message)} + TSyslogMessage = class(TObject) + private + FFacility:Byte; + FSeverity:TSyslogSeverity; + FDateTime:TDateTime; + FTag:String; + FMessage:String; + FLocalIP:String; + function GetPacketBuf:String; + procedure SetPacketBuf(Value:String); + public + {:Reset values to defaults} + procedure Clear; + published + {:Define facilicity of Syslog message. For specify you may use predefined + FCL_* constants. Default is "FCL_Local0".} + property Facility:Byte read FFacility write FFacility; + + {:Define possible priority of Syslog message. Default is "Debug".} + property Severity:TSyslogSeverity read FSeverity write FSeverity; + + {:date and time of Syslog message} + property DateTime:TDateTime read FDateTime write FDateTime; + + {:This is used for identify process of this message. Default is filename + of your executable file.} + property Tag:String read FTag write FTag; + + {:Text of your message for log.} + property LogMessage:String read FMessage write FMessage; + + {:IP address of message sender.} + property LocalIP:String read FLocalIP write FLocalIP; + + {:This property holds encoded binary SYSLOG packet} + property PacketBuf:String read GetPacketBuf write SetPacketBuf; + end; + + {:@abstract(This object implement BSD SysLog client) + + Note: Are you missing properties for specify server address and port? Look to + parent @link(TSynaClient) too!} + TSyslogSend = class(TSynaClient) + private + FSock: TUDPBlockSocket; + FSysLogMessage: TSysLogMessage; + public + constructor Create; + destructor Destroy; override; + {:Send Syslog UDP packet defined by @link(SysLogMessage).} + function DoIt: Boolean; + published + {:Syslog message for send} + property SysLogMessage:TSysLogMessage read FSysLogMessage write FSysLogMessage; + end; + +{:Simply send packet to specified Syslog server.} +function ToSysLog(const SyslogServer: string; Facil: Byte; + Sever: TSyslogSeverity; const Content: string): Boolean; + +implementation + +function TSyslogMessage.GetPacketBuf:String; +begin + Result := '<' + IntToStr((FFacility * 8) + Ord(FSeverity)) + '>'; + Result := Result + CDateTime(FDateTime) + ' '; + Result := Result + FLocalIP + ' '; + Result := Result + FTag + ': ' + FMessage; +end; + +procedure TSyslogMessage.SetPacketBuf(Value:String); +var StrBuf:String; + IntBuf,Pos:Integer; +begin + if Length(Value) < 1 then exit; + Pos := 1; + if Value[Pos] <> '<' then exit; + Inc(Pos); + // Facility and Severity + StrBuf := ''; + while (Value[Pos] <> '>')do + begin + StrBuf := StrBuf + Value[Pos]; + Inc(Pos); + end; + IntBuf := StrToInt(StrBuf); + FFacility := IntBuf div 8; + case (IntBuf mod 8)of + 0:FSeverity := Emergency; + 1:FSeverity := Alert; + 2:FSeverity := Critical; + 3:FSeverity := Error; + 4:FSeverity := Warning; + 5:FSeverity := Notice; + 6:FSeverity := Info; + 7:FSeverity := Debug; + end; + // DateTime + Inc(Pos); + StrBuf := ''; + // Month + while (Value[Pos] <> ' ')do + begin + StrBuf := StrBuf + Value[Pos]; + Inc(Pos); + end; + StrBuf := StrBuf + Value[Pos]; + Inc(Pos); + // Day + while (Value[Pos] <> ' ')do + begin + StrBuf := StrBuf + Value[Pos]; + Inc(Pos); + end; + StrBuf := StrBuf + Value[Pos]; + Inc(Pos); + // Time + while (Value[Pos] <> ' ')do + begin + StrBuf := StrBuf + Value[Pos]; + Inc(Pos); + end; + FDateTime := DecodeRFCDateTime(StrBuf); + Inc(Pos); + + // LocalIP + StrBuf := ''; + while (Value[Pos] <> ' ')do + begin + StrBuf := StrBuf + Value[Pos]; + Inc(Pos); + end; + FLocalIP := StrBuf; + Inc(Pos); + // Tag + StrBuf := ''; + while (Value[Pos] <> ':')do + begin + StrBuf := StrBuf + Value[Pos]; + Inc(Pos); + end; + FTag := StrBuf; + // LogMessage + Inc(Pos); + StrBuf := ''; + while (Pos <= Length(Value))do + begin + StrBuf := StrBuf + Value[Pos]; + Inc(Pos); + end; + FMessage := TrimSP(StrBuf); +end; + +procedure TSysLogMessage.Clear; +begin + FFacility := FCL_Local0; + FSeverity := Debug; + FTag := ExtractFileName(ParamStr(0)); + FMessage := ''; + FLocalIP := '0.0.0.0'; +end; + +//------------------------------------------------------------------------------ + +constructor TSyslogSend.Create; +begin + inherited Create; + FSock := TUDPBlockSocket.Create; + FSock.Owner := self; + FSysLogMessage := TSysLogMessage.Create; + FTargetPort := cSysLogProtocol; +end; + +destructor TSyslogSend.Destroy; +begin + FSock.Free; + FSysLogMessage.Free; + inherited Destroy; +end; + +function TSyslogSend.DoIt: Boolean; +var + L: TStringList; +begin + Result := False; + L := TStringList.Create; + try + FSock.ResolveNameToIP(FSock.Localname, L); + if L.Count < 1 then + FSysLogMessage.LocalIP := '0.0.0.0' + else + FSysLogMessage.LocalIP := L[0]; + finally + L.Free; + end; + FSysLogMessage.DateTime := Now; + if Length(FSysLogMessage.PacketBuf) <= 1024 then + begin + FSock.Connect(FTargetHost, FTargetPort); + FSock.SendString(FSysLogMessage.PacketBuf); + Result := FSock.LastError = 0; + end; +end; + +{==============================================================================} + +function ToSysLog(const SyslogServer: string; Facil: Byte; + Sever: TSyslogSeverity; const Content: string): Boolean; +begin + with TSyslogSend.Create do + try + TargetHost :=SyslogServer; + SysLogMessage.Facility := Facil; + SysLogMessage.Severity := Sever; + SysLogMessage.LogMessage := Content; + Result := DoIt; + finally + Free; + end; +end; + +end. diff --git a/synapse/smtpsend.pas b/synapse/smtpsend.pas new file mode 100644 index 0000000..e023a38 --- /dev/null +++ b/synapse/smtpsend.pas @@ -0,0 +1,724 @@ +{==============================================================================| +| Project : Ararat Synapse | 003.005.001 | +|==============================================================================| +| Content: SMTP 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) 1999-2010. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +{:@abstract(SMTP client) + +Used RFC: RFC-1869, RFC-1870, RFC-1893, RFC-2034, RFC-2104, RFC-2195, RFC-2487, + RFC-2554, RFC-2821 +} + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$H+} + +{$IFDEF UNICODE} + {$WARN IMPLICIT_STRING_CAST OFF} + {$WARN IMPLICIT_STRING_CAST_LOSS OFF} +{$ENDIF} + +unit smtpsend; + +interface + +uses + SysUtils, Classes, + blcksock, synautil, synacode; + +const + cSmtpProtocol = '25'; + +type + {:@abstract(Implementation of SMTP and ESMTP procotol), + include some ESMTP extensions, include SSL/TLS too. + + Note: Are you missing properties for setting Username and Password for ESMTP? + Look to parent @link(TSynaClient) object! + + Are you missing properties for specify server address and port? Look to + parent @link(TSynaClient) too!} + TSMTPSend = class(TSynaClient) + private + FSock: TTCPBlockSocket; + FResultCode: Integer; + FResultString: string; + FFullResult: TStringList; + FESMTPcap: TStringList; + FESMTP: Boolean; + FAuthDone: Boolean; + FESMTPSize: Boolean; + FMaxSize: Integer; + FEnhCode1: Integer; + FEnhCode2: Integer; + FEnhCode3: Integer; + FSystemName: string; + FAutoTLS: Boolean; + FFullSSL: Boolean; + procedure EnhancedCode(const Value: string); + function ReadResult: Integer; + function AuthLogin: Boolean; + function AuthCram: Boolean; + function AuthPlain: Boolean; + function Helo: Boolean; + function Ehlo: Boolean; + function Connect: Boolean; + public + constructor Create; + destructor Destroy; override; + + {:Connects to SMTP server (defined in @link(TSynaClient.TargetHost)) and + begin SMTP session. (First try ESMTP EHLO, next old HELO handshake). Parses + ESMTP capabilites and if you specified Username and password and remote + server can handle AUTH command, try login by AUTH command. Preffered login + method is CRAM-MD5 (if safer!). If all OK, result is @true, else result is + @false.} + function Login: Boolean; + + {:Close SMTP session (QUIT command) and disconnect from SMTP server.} + function Logout: Boolean; + + {:Send RSET SMTP command for reset SMTP session. If all OK, result is @true, + else result is @false.} + function Reset: Boolean; + + {:Send NOOP SMTP command for keep SMTP session. If all OK, result is @true, + else result is @false.} + function NoOp: Boolean; + + {:Send MAIL FROM SMTP command for set sender e-mail address. If sender's + e-mail address is empty string, transmited message is error message. + + If size not 0 and remote server can handle SIZE parameter, append SIZE + parameter to request. If all OK, result is @true, else result is @false.} + function MailFrom(const Value: string; Size: Integer): Boolean; + + {:Send RCPT TO SMTP command for set receiver e-mail address. It cannot be an + empty string. If all OK, result is @true, else result is @false.} + function MailTo(const Value: string): Boolean; + + {:Send DATA SMTP command and transmit message data. If all OK, result is + @true, else result is @false.} + function MailData(const Value: Tstrings): Boolean; + + {:Send ETRN SMTP command for start sending of remote queue for domain in + Value. If all OK, result is @true, else result is @false.} + function Etrn(const Value: string): Boolean; + + {:Send VRFY SMTP command for check receiver e-mail address. It cannot be + an empty string. If all OK, result is @true, else result is @false.} + function Verify(const Value: string): Boolean; + + {:Call STARTTLS command for upgrade connection to SSL/TLS mode.} + function StartTLS: Boolean; + + {:Return string descriptive text for enhanced result codes stored in + @link(EnhCode1), @link(EnhCode2) and @link(EnhCode3).} + function EnhCodeString: string; + + {:Try to find specified capability in ESMTP response.} + function FindCap(const Value: string): string; + published + {:result code of last SMTP command.} + property ResultCode: Integer read FResultCode; + + {:result string of last SMTP command (begin with string representation of + result code).} + property ResultString: string read FResultString; + + {:All result strings of last SMTP command (result is maybe multiline!).} + property FullResult: TStringList read FFullResult; + + {:List of ESMTP capabilites of remote ESMTP server. (If you connect to ESMTP + server only!).} + property ESMTPcap: TStringList read FESMTPcap; + + {:@TRUE if you successfuly logged to ESMTP server.} + property ESMTP: Boolean read FESMTP; + + {:@TRUE if you successfuly pass authorisation to remote server.} + property AuthDone: Boolean read FAuthDone; + + {:@TRUE if remote server can handle SIZE parameter.} + property ESMTPSize: Boolean read FESMTPSize; + + {:When @link(ESMTPsize) is @TRUE, contains max length of message that remote + server can handle.} + property MaxSize: Integer read FMaxSize; + + {:First digit of Enhanced result code. If last operation does not have + enhanced result code, values is 0.} + property EnhCode1: Integer read FEnhCode1; + + {:Second digit of Enhanced result code. If last operation does not have + enhanced result code, values is 0.} + property EnhCode2: Integer read FEnhCode2; + + {:Third digit of Enhanced result code. If last operation does not have + enhanced result code, values is 0.} + property EnhCode3: Integer read FEnhCode3; + + {:name of our system used in HELO and EHLO command. Implicit value is + internet address of your machine.} + property SystemName: string read FSystemName Write FSystemName; + + {: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; + +{:A very useful function and example of its use would be found in the TSMTPsend + object. Send maildata (text of e-mail with all SMTP headers! For example when + text of message is created by @link(TMimemess) object) from "MailFrom" e-mail + address to "MailTo" e-mail address (If you need more then one receiver, then + separate their addresses by comma). + + Function sends e-mail to a SMTP server defined in "SMTPhost" parameter. + Username and password are used for authorization to the "SMTPhost". If you + don't want authorization, set "Username" and "Password" to empty strings. If + e-mail message is successfully sent, the result returns @true. + + If you need use different port number then standard, then add this port number + to SMTPhost after colon. (i.e. '127.0.0.1:1025')} +function SendToRaw(const MailFrom, MailTo, SMTPHost: string; + const MailData: TStrings; const Username, Password: string): Boolean; + +{:A very useful function and example of its use would be found in the TSMTPsend + object. Send "Maildata" (text of e-mail without any SMTP headers!) from + "MailFrom" e-mail address to "MailTo" e-mail address with "Subject". (If you + need more then one receiver, then separate their addresses by comma). + + This function constructs all needed SMTP headers (with DATE header) and sends + the e-mail to the SMTP server defined in the "SMTPhost" parameter. If the + e-mail message is successfully sent, the result will be @TRUE. + + If you need use different port number then standard, then add this port number + to SMTPhost after colon. (i.e. '127.0.0.1:1025')} +function SendTo(const MailFrom, MailTo, Subject, SMTPHost: string; + const MailData: TStrings): Boolean; + +{:A very useful function and example of its use would be found in the TSMTPsend + object. Sends "MailData" (text of e-mail without any SMTP headers!) from + "MailFrom" e-mail address to "MailTo" e-mail address (If you need more then one + receiver, then separate their addresses by comma). + + This function sends the e-mail to the SMTP server defined in the "SMTPhost" + parameter. Username and password are used for authorization to the "SMTPhost". + If you dont want authorization, set "Username" and "Password" to empty Strings. + If the e-mail message is successfully sent, the result will be @TRUE. + + If you need use different port number then standard, then add this port number + to SMTPhost after colon. (i.e. '127.0.0.1:1025')} +function SendToEx(const MailFrom, MailTo, Subject, SMTPHost: string; + const MailData: TStrings; const Username, Password: string): Boolean; + +implementation + +constructor TSMTPSend.Create; +begin + inherited Create; + FFullResult := TStringList.Create; + FESMTPcap := TStringList.Create; + FSock := TTCPBlockSocket.Create; + FSock.Owner := self; + FSock.ConvertLineEnd := true; + FTimeout := 60000; + FTargetPort := cSmtpProtocol; + FSystemName := FSock.LocalName; + FAutoTLS := False; + FFullSSL := False; +end; + +destructor TSMTPSend.Destroy; +begin + FSock.Free; + FESMTPcap.Free; + FFullResult.Free; + inherited Destroy; +end; + +procedure TSMTPSend.EnhancedCode(const Value: string); +var + s, t: string; + e1, e2, e3: Integer; +begin + FEnhCode1 := 0; + FEnhCode2 := 0; + FEnhCode3 := 0; + s := Copy(Value, 5, Length(Value) - 4); + t := Trim(SeparateLeft(s, '.')); + s := Trim(SeparateRight(s, '.')); + if t = '' then + Exit; + if Length(t) > 1 then + Exit; + e1 := StrToIntDef(t, 0); + if e1 = 0 then + Exit; + t := Trim(SeparateLeft(s, '.')); + s := Trim(SeparateRight(s, '.')); + if t = '' then + Exit; + if Length(t) > 3 then + Exit; + e2 := StrToIntDef(t, 0); + t := Trim(SeparateLeft(s, ' ')); + if t = '' then + Exit; + if Length(t) > 3 then + Exit; + e3 := StrToIntDef(t, 0); + FEnhCode1 := e1; + FEnhCode2 := e2; + FEnhCode3 := e3; +end; + +function TSMTPSend.ReadResult: Integer; +var + s: String; +begin + Result := 0; + FFullResult.Clear; + repeat + s := FSock.RecvString(FTimeout); + FResultString := s; + FFullResult.Add(s); + if FSock.LastError <> 0 then + Break; + until Pos('-', s) <> 4; + s := FFullResult[0]; + if Length(s) >= 3 then + Result := StrToIntDef(Copy(s, 1, 3), 0); + FResultCode := Result; + EnhancedCode(s); +end; + +function TSMTPSend.AuthLogin: Boolean; +begin + Result := False; + FSock.SendString('AUTH LOGIN' + CRLF); + if ReadResult <> 334 then + Exit; + FSock.SendString(EncodeBase64(FUsername) + CRLF); + if ReadResult <> 334 then + Exit; + FSock.SendString(EncodeBase64(FPassword) + CRLF); + Result := ReadResult = 235; +end; + +function TSMTPSend.AuthCram: Boolean; +var + s: ansistring; +begin + Result := False; + FSock.SendString('AUTH CRAM-MD5' + CRLF); + if ReadResult <> 334 then + Exit; + s := Copy(FResultString, 5, Length(FResultString) - 4); + s := DecodeBase64(s); + s := HMAC_MD5(s, FPassword); + s := FUsername + ' ' + StrToHex(s); + FSock.SendString(EncodeBase64(s) + CRLF); + Result := ReadResult = 235; +end; + +function TSMTPSend.AuthPlain: Boolean; +var + s: ansistring; +begin + s := ansichar(0) + FUsername + ansichar(0) + FPassword; + FSock.SendString('AUTH PLAIN ' + EncodeBase64(s) + CRLF); + Result := ReadResult = 235; +end; + +function TSMTPSend.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 TSMTPSend.Helo: Boolean; +var + x: Integer; +begin + FSock.SendString('HELO ' + FSystemName + CRLF); + x := ReadResult; + Result := (x >= 250) and (x <= 259); +end; + +function TSMTPSend.Ehlo: Boolean; +var + x: Integer; +begin + FSock.SendString('EHLO ' + FSystemName + CRLF); + x := ReadResult; + Result := (x >= 250) and (x <= 259); +end; + +function TSMTPSend.Login: Boolean; +var + n: Integer; + auths: string; + s: string; +begin + Result := False; + FESMTP := True; + FAuthDone := False; + FESMTPcap.clear; + FESMTPSize := False; + FMaxSize := 0; + if not Connect then + Exit; + if ReadResult <> 220 then + Exit; + if not Ehlo then + begin + FESMTP := False; + if not Helo then + Exit; + end; + Result := True; + if FESMTP then + begin + for n := 1 to FFullResult.Count - 1 do + FESMTPcap.Add(Copy(FFullResult[n], 5, Length(FFullResult[n]) - 4)); + if (not FullSSL) and FAutoTLS and (FindCap('STARTTLS') <> '') then + if StartTLS then + begin + Ehlo; + FESMTPcap.Clear; + for n := 1 to FFullResult.Count - 1 do + FESMTPcap.Add(Copy(FFullResult[n], 5, Length(FFullResult[n]) - 4)); + end + else + begin + Result := False; + Exit; + end; + if not ((FUsername = '') and (FPassword = '')) then + begin + s := FindCap('AUTH '); + if s = '' then + s := FindCap('AUTH='); + auths := UpperCase(s); + if s <> '' then + begin + if Pos('CRAM-MD5', auths) > 0 then + FAuthDone := AuthCram; + if (not FauthDone) and (Pos('PLAIN', auths) > 0) then + FAuthDone := AuthPlain; + if (not FauthDone) and (Pos('LOGIN', auths) > 0) then + FAuthDone := AuthLogin; + end; + end; + s := FindCap('SIZE'); + if s <> '' then + begin + FESMTPsize := True; + FMaxSize := StrToIntDef(Copy(s, 6, Length(s) - 5), 0); + end; + end; +end; + +function TSMTPSend.Logout: Boolean; +begin + FSock.SendString('QUIT' + CRLF); + Result := ReadResult = 221; + FSock.CloseSocket; +end; + +function TSMTPSend.Reset: Boolean; +begin + FSock.SendString('RSET' + CRLF); + Result := ReadResult div 100 = 2; +end; + +function TSMTPSend.NoOp: Boolean; +begin + FSock.SendString('NOOP' + CRLF); + Result := ReadResult div 100 = 2; +end; + +function TSMTPSend.MailFrom(const Value: string; Size: Integer): Boolean; +var + s: string; +begin + s := 'MAIL FROM:<' + Value + '>'; + if FESMTPsize and (Size > 0) then + s := s + ' SIZE=' + IntToStr(Size); + FSock.SendString(s + CRLF); + Result := ReadResult div 100 = 2; +end; + +function TSMTPSend.MailTo(const Value: string): Boolean; +begin + FSock.SendString('RCPT TO:<' + Value + '>' + CRLF); + Result := ReadResult div 100 = 2; +end; + +function TSMTPSend.MailData(const Value: TStrings): Boolean; +var + n: Integer; + s: string; + t: string; + x: integer; +begin + Result := False; + FSock.SendString('DATA' + CRLF); + if ReadResult <> 354 then + Exit; + t := ''; + x := 1500; + for n := 0 to Value.Count - 1 do + begin + s := Value[n]; + if Length(s) >= 1 then + if s[1] = '.' then + s := '.' + s; + if Length(t) + Length(s) >= x then + begin + FSock.SendString(t); + t := ''; + end; + t := t + s + CRLF; + end; + if t <> '' then + FSock.SendString(t); + FSock.SendString('.' + CRLF); + Result := ReadResult div 100 = 2; +end; + +function TSMTPSend.Etrn(const Value: string): Boolean; +var + x: Integer; +begin + FSock.SendString('ETRN ' + Value + CRLF); + x := ReadResult; + Result := (x >= 250) and (x <= 259); +end; + +function TSMTPSend.Verify(const Value: string): Boolean; +var + x: Integer; +begin + FSock.SendString('VRFY ' + Value + CRLF); + x := ReadResult; + Result := (x >= 250) and (x <= 259); +end; + +function TSMTPSend.StartTLS: Boolean; +begin + Result := False; + if FindCap('STARTTLS') <> '' then + begin + FSock.SendString('STARTTLS' + CRLF); + if (ReadResult = 220) and (FSock.LastError = 0) then + begin + Fsock.SSLDoConnect; + Result := FSock.LastError = 0; + end; + end; +end; + +function TSMTPSend.EnhCodeString: string; +var + s, t: string; +begin + s := IntToStr(FEnhCode2) + '.' + IntToStr(FEnhCode3); + t := ''; + if s = '0.0' then t := 'Other undefined Status'; + if s = '1.0' then t := 'Other address status'; + if s = '1.1' then t := 'Bad destination mailbox address'; + if s = '1.2' then t := 'Bad destination system address'; + if s = '1.3' then t := 'Bad destination mailbox address syntax'; + if s = '1.4' then t := 'Destination mailbox address ambiguous'; + if s = '1.5' then t := 'Destination mailbox address valid'; + if s = '1.6' then t := 'Mailbox has moved'; + if s = '1.7' then t := 'Bad sender''s mailbox address syntax'; + if s = '1.8' then t := 'Bad sender''s system address'; + if s = '2.0' then t := 'Other or undefined mailbox status'; + if s = '2.1' then t := 'Mailbox disabled, not accepting messages'; + if s = '2.2' then t := 'Mailbox full'; + if s = '2.3' then t := 'Message Length exceeds administrative limit'; + if s = '2.4' then t := 'Mailing list expansion problem'; + if s = '3.0' then t := 'Other or undefined mail system status'; + if s = '3.1' then t := 'Mail system full'; + if s = '3.2' then t := 'System not accepting network messages'; + if s = '3.3' then t := 'System not capable of selected features'; + if s = '3.4' then t := 'Message too big for system'; + if s = '3.5' then t := 'System incorrectly configured'; + if s = '4.0' then t := 'Other or undefined network or routing status'; + if s = '4.1' then t := 'No answer from host'; + if s = '4.2' then t := 'Bad connection'; + if s = '4.3' then t := 'Routing server failure'; + if s = '4.4' then t := 'Unable to route'; + if s = '4.5' then t := 'Network congestion'; + if s = '4.6' then t := 'Routing loop detected'; + if s = '4.7' then t := 'Delivery time expired'; + if s = '5.0' then t := 'Other or undefined protocol status'; + if s = '5.1' then t := 'Invalid command'; + if s = '5.2' then t := 'Syntax error'; + if s = '5.3' then t := 'Too many recipients'; + if s = '5.4' then t := 'Invalid command arguments'; + if s = '5.5' then t := 'Wrong protocol version'; + if s = '6.0' then t := 'Other or undefined media error'; + if s = '6.1' then t := 'Media not supported'; + if s = '6.2' then t := 'Conversion required and prohibited'; + if s = '6.3' then t := 'Conversion required but not supported'; + if s = '6.4' then t := 'Conversion with loss performed'; + if s = '6.5' then t := 'Conversion failed'; + if s = '7.0' then t := 'Other or undefined security status'; + if s = '7.1' then t := 'Delivery not authorized, message refused'; + if s = '7.2' then t := 'Mailing list expansion prohibited'; + if s = '7.3' then t := 'Security conversion required but not possible'; + if s = '7.4' then t := 'Security features not supported'; + if s = '7.5' then t := 'Cryptographic failure'; + if s = '7.6' then t := 'Cryptographic algorithm not supported'; + if s = '7.7' then t := 'Message integrity failure'; + s := '???-'; + if FEnhCode1 = 2 then s := 'Success-'; + if FEnhCode1 = 4 then s := 'Persistent Transient Failure-'; + if FEnhCode1 = 5 then s := 'Permanent Failure-'; + Result := s + t; +end; + +function TSMTPSend.FindCap(const Value: string): string; +var + n: Integer; + s: string; +begin + s := UpperCase(Value); + Result := ''; + for n := 0 to FESMTPcap.Count - 1 do + if Pos(s, UpperCase(FESMTPcap[n])) = 1 then + begin + Result := FESMTPcap[n]; + Break; + end; +end; + +{==============================================================================} + +function SendToRaw(const MailFrom, MailTo, SMTPHost: string; + const MailData: TStrings; const Username, Password: string): Boolean; +var + SMTP: TSMTPSend; + s, t: string; +begin + Result := False; + SMTP := TSMTPSend.Create; + try +// if you need SOCKS5 support, uncomment next lines: + // SMTP.Sock.SocksIP := '127.0.0.1'; + // SMTP.Sock.SocksPort := '1080'; +// if you need support for upgrade session to TSL/SSL, uncomment next lines: + // SMTP.AutoTLS := True; +// if you need support for TSL/SSL tunnel, uncomment next lines: + // SMTP.FullSSL := True; + SMTP.TargetHost := Trim(SeparateLeft(SMTPHost, ':')); + s := Trim(SeparateRight(SMTPHost, ':')); + if (s <> '') and (s <> SMTPHost) then + SMTP.TargetPort := s; + SMTP.Username := Username; + SMTP.Password := Password; + if SMTP.Login then + begin + if SMTP.MailFrom(GetEmailAddr(MailFrom), Length(MailData.Text)) then + begin + s := MailTo; + repeat + t := GetEmailAddr(Trim(FetchEx(s, ',', '"'))); + if t <> '' then + Result := SMTP.MailTo(t); + if not Result then + Break; + until s = ''; + if Result then + Result := SMTP.MailData(MailData); + end; + SMTP.Logout; + end; + finally + SMTP.Free; + end; +end; + +function SendToEx(const MailFrom, MailTo, Subject, SMTPHost: string; + const MailData: TStrings; const Username, Password: string): Boolean; +var + t: TStrings; +begin + t := TStringList.Create; + try + t.Assign(MailData); + t.Insert(0, ''); + t.Insert(0, 'X-mailer: Synapse - Delphi & Kylix TCP/IP library by Lukas Gebauer'); + t.Insert(0, 'Subject: ' + Subject); + t.Insert(0, 'Date: ' + Rfc822DateTime(now)); + t.Insert(0, 'To: ' + MailTo); + t.Insert(0, 'From: ' + MailFrom); + Result := SendToRaw(MailFrom, MailTo, SMTPHost, t, Username, Password); + finally + t.Free; + end; +end; + +function SendTo(const MailFrom, MailTo, Subject, SMTPHost: string; + const MailData: TStrings): Boolean; +begin + Result := SendToEx(MailFrom, MailTo, Subject, SMTPHost, MailData, '', ''); +end; + +end. diff --git a/synapse/snmpsend.pas b/synapse/snmpsend.pas new file mode 100644 index 0000000..6e44c04 --- /dev/null +++ b/synapse/snmpsend.pas @@ -0,0 +1,1266 @@ +{==============================================================================| +| Project : Ararat Synapse | 004.000.000 | +|==============================================================================| +| Content: SNMP 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)2000-2011. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +| Jean-Fabien Connault (cycocrew@worldnet.fr) | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +{:@abstract(SNMP client) +Supports SNMPv1 include traps, SNMPv2c and SNMPv3 include authorization +and privacy encryption. + +Used RFC: RFC-1157, RFC-1901, RFC-3412, RFC-3414, RFC-3416, RFC-3826 + +Supported Authorization hashes: MD5, SHA1 +Supported Privacy encryptions: DES, 3DES, AES +} + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$Q-} +{$H+} + +{$IFDEF UNICODE} + {$WARN IMPLICIT_STRING_CAST OFF} + {$WARN IMPLICIT_STRING_CAST_LOSS OFF} +{$ENDIF} + +unit snmpsend; + +interface + +uses + Classes, SysUtils, + blcksock, synautil, asn1util, synaip, synacode, synacrypt; + +const + cSnmpProtocol = '161'; + cSnmpTrapProtocol = '162'; + + SNMP_V1 = 0; + SNMP_V2C = 1; + SNMP_V3 = 3; + + //PDU type + PDUGetRequest = $A0; + PDUGetNextRequest = $A1; + PDUGetResponse = $A2; + PDUSetRequest = $A3; + PDUTrap = $A4; //Obsolete + //for SNMPv2 + PDUGetBulkRequest = $A5; + PDUInformRequest = $A6; + PDUTrapV2 = $A7; + PDUReport = $A8; + + //errors + ENoError = 0; + ETooBig = 1; + ENoSuchName = 2; + EBadValue = 3; + EReadOnly = 4; + EGenErr = 5; + //errors SNMPv2 + ENoAccess = 6; + EWrongType = 7; + EWrongLength = 8; + EWrongEncoding = 9; + EWrongValue = 10; + ENoCreation = 11; + EInconsistentValue = 12; + EResourceUnavailable = 13; + ECommitFailed = 14; + EUndoFailed = 15; + EAuthorizationError = 16; + ENotWritable = 17; + EInconsistentName = 18; + +type + + {:@abstract(Possible values for SNMPv3 flags.) + This flags specify level of authorization and encryption.} + TV3Flags = ( + NoAuthNoPriv, + AuthNoPriv, + AuthPriv); + + {:@abstract(Type of SNMPv3 authorization)} + TV3Auth = ( + AuthMD5, + AuthSHA1); + + {:@abstract(Type of SNMPv3 privacy)} + TV3Priv = ( + PrivDES, + Priv3DES, + PrivAES); + + {:@abstract(Data object with one record of MIB OID and corresponding values.)} + TSNMPMib = class(TObject) + protected + FOID: AnsiString; + FValue: AnsiString; + FValueType: Integer; + published + {:OID number in string format.} + property OID: AnsiString read FOID write FOID; + + {:Value of OID object in string format.} + property Value: AnsiString read FValue write FValue; + + {:Define type of Value. Supported values are defined in @link(asn1util). + For queries use ASN1_NULL, becouse you don't know type in response!} + property ValueType: Integer read FValueType write FValueType; + end; + + {:@abstract(It holding all information for SNMPv3 agent synchronization) + Used internally.} + TV3Sync = record + EngineID: AnsiString; + EngineBoots: integer; + EngineTime: integer; + EngineStamp: Cardinal; + end; + + {:@abstract(Data object abstracts SNMP data packet)} + TSNMPRec = class(TObject) + protected + FVersion: Integer; + FPDUType: Integer; + FID: Integer; + FErrorStatus: Integer; + FErrorIndex: Integer; + FCommunity: AnsiString; + FSNMPMibList: TList; + FMaxSize: Integer; + FFlags: TV3Flags; + FFlagReportable: Boolean; + FContextEngineID: AnsiString; + FContextName: AnsiString; + FAuthMode: TV3Auth; + FAuthEngineID: AnsiString; + FAuthEngineBoots: integer; + FAuthEngineTime: integer; + FAuthEngineTimeStamp: cardinal; + FUserName: AnsiString; + FPassword: AnsiString; + FAuthKey: AnsiString; + FPrivMode: TV3Priv; + FPrivPassword: AnsiString; + FPrivKey: AnsiString; + FPrivSalt: AnsiString; + FPrivSaltCounter: integer; + FOldTrapEnterprise: AnsiString; + FOldTrapHost: AnsiString; + FOldTrapGen: Integer; + FOldTrapSpec: Integer; + FOldTrapTimeTicks: Integer; + function Pass2Key(const Value: AnsiString): AnsiString; + function EncryptPDU(const value: AnsiString): AnsiString; + function DecryptPDU(const value: AnsiString): AnsiString; + public + constructor Create; + destructor Destroy; override; + + {:Decode SNMP packet in buffer to object properties.} + function DecodeBuf(Buffer: AnsiString): Boolean; + + {:Encode obeject properties to SNMP packet.} + function EncodeBuf: AnsiString; + + {:Clears all object properties to default values.} + procedure Clear; + + {:Add entry to @link(SNMPMibList). For queries use value as empty string, + and ValueType as ASN1_NULL.} + procedure MIBAdd(const MIB, Value: AnsiString; ValueType: Integer); + + {:Delete entry from @link(SNMPMibList).} + procedure MIBDelete(Index: Integer); + + {:Search @link(SNMPMibList) list for MIB and return correspond value.} + function MIBGet(const MIB: AnsiString): AnsiString; + + {:return number of entries in MIB array.} + function MIBCount: integer; + + {:Return MIB information from given row of MIB array.} + function MIBByIndex(Index: Integer): TSNMPMib; + + {:List of @link(TSNMPMib) objects.} + property SNMPMibList: TList read FSNMPMibList; + published + {:Version of SNMP packet. Default value is 0 (SNMP ver. 1). You can use + value 1 for SNMPv2c or value 3 for SNMPv3.} + property Version: Integer read FVersion write FVersion; + + {:Community string for autorize access to SNMP server. (Case sensitive!) + Community string is not used in SNMPv3! Use @link(Username) and + @link(password) instead!} + property Community: AnsiString read FCommunity write FCommunity; + + {:Define type of SNMP operation.} + property PDUType: Integer read FPDUType write FPDUType; + + {:Contains ID number. Not need to use.} + property ID: Integer read FID write FID; + + {:When packet is reply, contains error code. Supported values are defined by + E* constants.} + property ErrorStatus: Integer read FErrorStatus write FErrorStatus; + + {:Point to error position in reply packet. Not usefull for users. It only + good for debugging!} + property ErrorIndex: Integer read FErrorIndex write FErrorIndex; + + {:special value for GetBulkRequest of SNMPv2 and v3.} + property NonRepeaters: Integer read FErrorStatus write FErrorStatus; + + {:special value for GetBulkRequest of SNMPv2 and v3.} + property MaxRepetitions: Integer read FErrorIndex write FErrorIndex; + + {:Maximum message size in bytes for SNMPv3. For sending is default 1472 bytes.} + property MaxSize: Integer read FMaxSize write FMaxSize; + + {:Specify if message is authorised or encrypted. Used only in SNMPv3.} + property Flags: TV3Flags read FFlags write FFlags; + + {:For SNMPv3.... If is @true, SNMP agent must send reply (at least with some + error).} + property FlagReportable: Boolean read FFlagReportable write FFlagReportable; + + {:For SNMPv3. If not specified, is used value from @link(AuthEngineID)} + property ContextEngineID: AnsiString read FContextEngineID write FContextEngineID; + + {:For SNMPv3.} + property ContextName: AnsiString read FContextName write FContextName; + + {:For SNMPv3. Specify Authorization mode. (specify used hash for + authorization)} + property AuthMode: TV3Auth read FAuthMode write FAuthMode; + + {:For SNMPv3. Specify Privacy mode.} + property PrivMode: TV3Priv read FPrivMode write FPrivMode; + + {:value used by SNMPv3 authorisation for synchronization with SNMP agent.} + property AuthEngineID: AnsiString read FAuthEngineID write FAuthEngineID; + + {:value used by SNMPv3 authorisation for synchronization with SNMP agent.} + property AuthEngineBoots: Integer read FAuthEngineBoots write FAuthEngineBoots; + + {:value used by SNMPv3 authorisation for synchronization with SNMP agent.} + property AuthEngineTime: Integer read FAuthEngineTime write FAuthEngineTime; + + {:value used by SNMPv3 authorisation for synchronization with SNMP agent.} + property AuthEngineTimeStamp: Cardinal read FAuthEngineTimeStamp Write FAuthEngineTimeStamp; + + {:SNMPv3 authorization username} + property UserName: AnsiString read FUserName write FUserName; + + {:SNMPv3 authorization password} + property Password: AnsiString read FPassword write FPassword; + + {:For SNMPv3. Computed Athorization key from @link(password).} + property AuthKey: AnsiString read FAuthKey write FAuthKey; + + {:SNMPv3 privacy password} + property PrivPassword: AnsiString read FPrivPassword write FPrivPassword; + + {:For SNMPv3. Computed Privacy key from @link(PrivPassword).} + property PrivKey: AnsiString read FPrivKey write FPrivKey; + + {:MIB value to identify the object that sent the TRAPv1.} + property OldTrapEnterprise: AnsiString read FOldTrapEnterprise write FOldTrapEnterprise; + + {:Address of TRAPv1 sender (IP address).} + property OldTrapHost: AnsiString read FOldTrapHost write FOldTrapHost; + + {:Generic TRAPv1 identification.} + property OldTrapGen: Integer read FOldTrapGen write FOldTrapGen; + + {:Specific TRAPv1 identification.} + property OldTrapSpec: Integer read FOldTrapSpec write FOldTrapSpec; + + {:Number of 1/100th of seconds since last reboot or power up. (for TRAPv1)} + property OldTrapTimeTicks: Integer read FOldTrapTimeTicks write FOldTrapTimeTicks; + end; + + {:@abstract(Implementation of SNMP protocol.) + + Note: Are you missing properties for specify server address and port? Look to + parent @link(TSynaClient) too!} + TSNMPSend = class(TSynaClient) + protected + FSock: TUDPBlockSocket; + FBuffer: AnsiString; + FHostIP: AnsiString; + FQuery: TSNMPRec; + FReply: TSNMPRec; + function InternalSendSnmp(const Value: TSNMPRec): Boolean; + function InternalRecvSnmp(const Value: TSNMPRec): Boolean; + function InternalSendRequest(const QValue, RValue: TSNMPRec): Boolean; + function GetV3EngineID: AnsiString; + function GetV3Sync: TV3Sync; + public + constructor Create; + destructor Destroy; override; + + {:Connects to a Host and send there query. If in timeout SNMP server send + back query, result is @true. If is used SNMPv3, then it synchronize self + with SNMPv3 agent first. (It is needed for SNMPv3 auhorization!)} + function SendRequest: Boolean; + + {:Send SNMP packet only, but not waits for reply. Good for sending traps.} + function SendTrap: Boolean; + + {:Receive SNMP packet only. Good for receiving traps.} + function RecvTrap: Boolean; + + {:Mapped to @link(SendRequest) internally. This function is only for + backward compatibility.} + function DoIt: Boolean; + published + {:contains raw binary form of SNMP packet. Good for debugging.} + property Buffer: AnsiString read FBuffer write FBuffer; + + {:After SNMP operation hold IP address of remote side.} + property HostIP: AnsiString read FHostIP; + + {:Data object contains SNMP query.} + property Query: TSNMPRec read FQuery; + + {:Data object contains SNMP reply.} + property Reply: TSNMPRec read FReply; + + {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.} + property Sock: TUDPBlockSocket read FSock; + end; + +{:A very useful function and example of its use would be found in the TSNMPSend + object. It implements basic GET method of the SNMP protocol. The MIB value is + located in the "OID" variable, and is sent to the requested "SNMPHost" with + the proper "Community" access identifier. Upon a successful retrieval, "Value" + will contain the information requested. If the SNMP operation is successful, + the result returns @true.} +function SNMPGet(const OID, Community, SNMPHost: AnsiString; var Value: AnsiString): Boolean; + +{:This is useful function and example of use TSNMPSend object. It implements + the basic SET method of the SNMP protocol. If the SNMP operation is successful, + the result is @true. "Value" is value of MIB Oid for "SNMPHost" with "Community" + access identifier. You must specify "ValueType" too.} +function SNMPSet(const OID, Community, SNMPHost, Value: AnsiString; ValueType: Integer): Boolean; + +{:A very useful function and example of its use would be found in the TSNMPSend + object. It implements basic GETNEXT method of the SNMP protocol. The MIB value + is located in the "OID" variable, and is sent to the requested "SNMPHost" with + the proper "Community" access identifier. Upon a successful retrieval, "Value" + will contain the information requested. If the SNMP operation is successful, + the result returns @true.} +function SNMPGetNext(var OID: AnsiString; const Community, SNMPHost: AnsiString; var Value: AnsiString): Boolean; + +{:A very useful function and example of its use would be found in the TSNMPSend + object. It implements basic read of SNMP MIB tables. As BaseOID you must + specify basic MIB OID of requested table (base IOD is OID without row and + column specificator!) + Table is readed into stringlist, where each string is comma delimited string. + + Warning: this function is not have best performance. For better performance + you must write your own function. best performace you can get by knowledge + of structuture of table and by more then one MIB on one query. } +function SNMPGetTable(const BaseOID, Community, SNMPHost: AnsiString; const Value: TStrings): Boolean; + +{:A very useful function and example of its use would be found in the TSNMPSend + object. It implements basic read of SNMP MIB table element. As BaseOID you must + specify basic MIB OID of requested table (base IOD is OID without row and + column specificator!) + As next you must specify identificator of row and column for specify of needed + field of table.} +function SNMPGetTableElement(const BaseOID, RowID, ColID, Community, SNMPHost: AnsiString; var Value: AnsiString): Boolean; + +{:A very useful function and example of its use would be found in the TSNMPSend + object. It implements a TRAPv1 to send with all data in the parameters.} +function SendTrap(const Dest, Source, Enterprise, Community: AnsiString; + Generic, Specific, Seconds: Integer; const MIBName, MIBValue: AnsiString; + MIBtype: Integer): Integer; + +{:A very useful function and example of its use would be found in the TSNMPSend + object. It receives a TRAPv1 and returns all the data that comes with it.} +function RecvTrap(var Dest, Source, Enterprise, Community: AnsiString; + var Generic, Specific, Seconds: Integer; const MIBName, + MIBValue: TStringList): Integer; + +implementation + +{==============================================================================} + +constructor TSNMPRec.Create; +begin + inherited Create; + FSNMPMibList := TList.Create; + Clear; + FAuthMode := AuthMD5; + FPassword := ''; + FPrivMode := PrivDES; + FPrivPassword := ''; + FID := 1; + FMaxSize := 1472; +end; + +destructor TSNMPRec.Destroy; +var + i: Integer; +begin + for i := 0 to FSNMPMibList.Count - 1 do + TSNMPMib(FSNMPMibList[i]).Free; + FSNMPMibList.Clear; + FSNMPMibList.Free; + inherited Destroy; +end; + +function TSNMPRec.Pass2Key(const Value: AnsiString): AnsiString; +var + key: AnsiString; +begin + case FAuthMode of + AuthMD5: + begin + key := MD5LongHash(Value, 1048576); + Result := MD5(key + FAuthEngineID + key); + end; + AuthSHA1: + begin + key := SHA1LongHash(Value, 1048576); + Result := SHA1(key + FAuthEngineID + key); + end; + else + Result := ''; + end; +end; + +function TSNMPRec.DecryptPDU(const value: AnsiString): AnsiString; +var + des: TSynaDes; + des3: TSyna3Des; + aes: TSynaAes; + s: string; +begin + FPrivKey := ''; + if FFlags <> AuthPriv then + Result := value + else + begin + case FPrivMode of + Priv3DES: + begin + FPrivKey := Pass2Key(FPrivPassword); + FPrivKey := FPrivKey + Pass2Key(FPrivKey); + des3 := TSyna3Des.Create(PadString(FPrivKey, 24, #0)); + try + s := PadString(FPrivKey, 32, #0); + delete(s, 1, 24); + des3.SetIV(xorstring(s, FPrivSalt)); + s := des3.DecryptCBC(value); + Result := s; + finally + des3.free; + end; + end; + PrivAES: + begin + FPrivKey := Pass2Key(FPrivPassword); + aes := TSynaAes.Create(PadString(FPrivKey, 16, #0)); + try + s := CodeLongInt(FAuthEngineBoots) + CodeLongInt(FAuthEngineTime) + FPrivSalt; + aes.SetIV(s); + s := aes.DecryptCFBblock(value); + Result := s; + finally + aes.free; + end; + end; + else //PrivDES as default + begin + FPrivKey := Pass2Key(FPrivPassword); + des := TSynaDes.Create(PadString(FPrivKey, 8, #0)); + try + s := PadString(FPrivKey, 16, #0); + delete(s, 1, 8); + des.SetIV(xorstring(s, FPrivSalt)); + s := des.DecryptCBC(value); + Result := s; + finally + des.free; + end; + end; + end; + end; +end; + +function TSNMPRec.DecodeBuf(Buffer: AnsiString): Boolean; +var + Pos: Integer; + EndPos: Integer; + sm, sv: AnsiString; + Svt: Integer; + s: AnsiString; + Spos: integer; + x: Byte; +begin + Clear; + Result := False; + if Length(Buffer) < 2 then + Exit; + if (Ord(Buffer[1]) and $20) = 0 then + Exit; + Pos := 2; + EndPos := ASNDecLen(Pos, Buffer); + if Length(Buffer) < (EndPos + 2) then + Exit; + Self.FVersion := StrToIntDef(ASNItem(Pos, Buffer, Svt), 0); + + if FVersion = 3 then + begin + ASNItem(Pos, Buffer, Svt); //header data seq + ASNItem(Pos, Buffer, Svt); //ID + FMaxSize := StrToIntDef(ASNItem(Pos, Buffer, Svt), 0); + s := ASNItem(Pos, Buffer, Svt); + x := 0; + if s <> '' then + x := Ord(s[1]); + FFlagReportable := (x and 4) > 0; + x := x and 3; + case x of + 1: + FFlags := AuthNoPriv; + 3: + FFlags := AuthPriv; + else + FFlags := NoAuthNoPriv; + end; + + x := StrToIntDef(ASNItem(Pos, Buffer, Svt), 0); + s := ASNItem(Pos, Buffer, Svt); //SecurityParameters + //if SecurityModel is USM, then try to decode SecurityParameters + if (x = 3) and (s <> '') then + begin + spos := 1; + ASNItem(SPos, s, Svt); + FAuthEngineID := ASNItem(SPos, s, Svt); + FAuthEngineBoots := StrToIntDef(ASNItem(SPos, s, Svt), 0); + FAuthEngineTime := StrToIntDef(ASNItem(SPos, s, Svt), 0); + FAuthEngineTimeStamp := GetTick; + FUserName := ASNItem(SPos, s, Svt); + FAuthKey := ASNItem(SPos, s, Svt); + FPrivSalt := ASNItem(SPos, s, Svt); + end; + //scopedPDU + if FFlags = AuthPriv then + begin + x := Pos; + s := ASNItem(Pos, Buffer, Svt); + if Svt <> ASN1_OCTSTR then + exit; + s := DecryptPDU(s); + //replace encoded content by decoded version and continue + Buffer := copy(Buffer, 1, x - 1); + Buffer := Buffer + s; + Pos := x; + if length(Buffer) < EndPos then + EndPos := length(buffer); + end; + ASNItem(Pos, Buffer, Svt); //skip sequence mark + FContextEngineID := ASNItem(Pos, Buffer, Svt); + FContextName := ASNItem(Pos, Buffer, Svt); + end + else + begin + //old packet + Self.FCommunity := ASNItem(Pos, Buffer, Svt); + end; + + ASNItem(Pos, Buffer, Svt); + Self.FPDUType := Svt; + if Self.FPDUType = PDUTrap then + begin + FOldTrapEnterprise := ASNItem(Pos, Buffer, Svt); + FOldTrapHost := ASNItem(Pos, Buffer, Svt); + FOldTrapGen := StrToIntDef(ASNItem(Pos, Buffer, Svt), 0); + FOldTrapSpec := StrToIntDef(ASNItem(Pos, Buffer, Svt), 0); + FOldTrapTimeTicks := StrToIntDef(ASNItem(Pos, Buffer, Svt), 0); + end + else + begin + Self.FID := StrToIntDef(ASNItem(Pos, Buffer, Svt), 0); + Self.FErrorStatus := StrToIntDef(ASNItem(Pos, Buffer, Svt), 0); + Self.FErrorIndex := StrToIntDef(ASNItem(Pos, Buffer, Svt), 0); + end; + ASNItem(Pos, Buffer, Svt); + while Pos < EndPos do + begin + ASNItem(Pos, Buffer, Svt); + Sm := ASNItem(Pos, Buffer, Svt); + Sv := ASNItem(Pos, Buffer, Svt); + if sm <> '' then + Self.MIBAdd(sm, sv, Svt); + end; + Result := True; +end; + +function TSNMPRec.EncryptPDU(const value: AnsiString): AnsiString; +var + des: TSynaDes; + des3: TSyna3Des; + aes: TSynaAes; + s: string; + x: integer; +begin + FPrivKey := ''; + if FFlags <> AuthPriv then + Result := Value + else + begin + case FPrivMode of + Priv3DES: + begin + FPrivKey := Pass2Key(FPrivPassword); + FPrivKey := FPrivKey + Pass2Key(FPrivKey); + des3 := TSyna3Des.Create(PadString(FPrivKey, 24, #0)); + try + s := PadString(FPrivKey, 32, #0); + delete(s, 1, 24); + FPrivSalt := CodeLongInt(FAuthEngineBoots) + CodeLongInt(FPrivSaltCounter); + inc(FPrivSaltCounter); + s := xorstring(s, FPrivSalt); + des3.SetIV(s); + x := length(value) mod 8; + x := 8 - x; + if x = 8 then + x := 0; + s := des3.EncryptCBC(value + Stringofchar(#0, x)); + Result := ASNObject(s, ASN1_OCTSTR); + finally + des3.free; + end; + end; + PrivAES: + begin + FPrivKey := Pass2Key(FPrivPassword); + aes := TSynaAes.Create(PadString(FPrivKey, 16, #0)); + try + FPrivSalt := CodeLongInt(0) + CodeLongInt(FPrivSaltCounter); + inc(FPrivSaltCounter); + s := CodeLongInt(FAuthEngineBoots) + CodeLongInt(FAuthEngineTime) + FPrivSalt; + aes.SetIV(s); + s := aes.EncryptCFBblock(value); + Result := ASNObject(s, ASN1_OCTSTR); + finally + aes.free; + end; + end; + else //PrivDES as default + begin + FPrivKey := Pass2Key(FPrivPassword); + des := TSynaDes.Create(PadString(FPrivKey, 8, #0)); + try + s := PadString(FPrivKey, 16, #0); + delete(s, 1, 8); + FPrivSalt := CodeLongInt(FAuthEngineBoots) + CodeLongInt(FPrivSaltCounter); + inc(FPrivSaltCounter); + s := xorstring(s, FPrivSalt); + des.SetIV(s); + x := length(value) mod 8; + x := 8 - x; + if x = 8 then + x := 0; + s := des.EncryptCBC(value + Stringofchar(#0, x)); + Result := ASNObject(s, ASN1_OCTSTR); + finally + des.free; + end; + end; + end; + end; +end; + +function TSNMPRec.EncodeBuf: AnsiString; +var + s: AnsiString; + SNMPMib: TSNMPMib; + n: Integer; + pdu, head, auth, authbeg: AnsiString; + x: Byte; +begin + pdu := ''; + for n := 0 to FSNMPMibList.Count - 1 do + begin + SNMPMib := TSNMPMib(FSNMPMibList[n]); + case SNMPMib.ValueType of + ASN1_INT: + s := ASNObject(MibToID(SNMPMib.OID), ASN1_OBJID) + + ASNObject(ASNEncInt(StrToIntDef(SNMPMib.Value, 0)), SNMPMib.ValueType); + ASN1_COUNTER, ASN1_GAUGE, ASN1_TIMETICKS: + s := ASNObject(MibToID(SNMPMib.OID), ASN1_OBJID) + + ASNObject(ASNEncUInt(StrToIntDef(SNMPMib.Value, 0)), SNMPMib.ValueType); + ASN1_OBJID: + s := ASNObject(MibToID(SNMPMib.OID), ASN1_OBJID) + + ASNObject(MibToID(SNMPMib.Value), SNMPMib.ValueType); + ASN1_IPADDR: + s := ASNObject(MibToID(SNMPMib.OID), ASN1_OBJID) + + ASNObject(IPToID(SNMPMib.Value), SNMPMib.ValueType); + ASN1_NULL: + s := ASNObject(MibToID(SNMPMib.OID), ASN1_OBJID) + + ASNObject('', ASN1_NULL); + else + s := ASNObject(MibToID(SNMPMib.OID), ASN1_OBJID) + + ASNObject(SNMPMib.Value, SNMPMib.ValueType); + end; + pdu := pdu + ASNObject(s, ASN1_SEQ); + end; + pdu := ASNObject(pdu, ASN1_SEQ); + + if Self.FPDUType = PDUTrap then + pdu := ASNObject(MibToID(FOldTrapEnterprise), ASN1_OBJID) + + ASNObject(IPToID(FOldTrapHost), ASN1_IPADDR) + + ASNObject(ASNEncInt(FOldTrapGen), ASN1_INT) + + ASNObject(ASNEncInt(FOldTrapSpec), ASN1_INT) + + ASNObject(ASNEncUInt(FOldTrapTimeTicks), ASN1_TIMETICKS) + + pdu + else + pdu := ASNObject(ASNEncInt(Self.FID), ASN1_INT) + + ASNObject(ASNEncInt(Self.FErrorStatus), ASN1_INT) + + ASNObject(ASNEncInt(Self.FErrorIndex), ASN1_INT) + + pdu; + pdu := ASNObject(pdu, Self.FPDUType); + + if FVersion = 3 then + begin + if FContextEngineID = '' then + FContextEngineID := FAuthEngineID; + //complete PDUv3... + pdu := ASNObject(FContextEngineID, ASN1_OCTSTR) + + ASNObject(FContextName, ASN1_OCTSTR) + + pdu; + pdu := ASNObject(pdu, ASN1_SEQ); + //encrypt PDU if Priv mode is enabled + pdu := EncryptPDU(pdu); + + //prepare flags + case FFlags of + AuthNoPriv: + x := 1; + AuthPriv: + x := 3; + else + x := 0; + end; + if FFlagReportable then + x := x or 4; + head := ASNObject(ASNEncInt(Self.FVersion), ASN1_INT); + s := ASNObject(ASNEncInt(FID), ASN1_INT) + + ASNObject(ASNEncInt(FMaxSize), ASN1_INT) + + ASNObject(AnsiChar(x), ASN1_OCTSTR) + //encode security model USM + + ASNObject(ASNEncInt(3), ASN1_INT); + head := head + ASNObject(s, ASN1_SEQ); + + //compute engine time difference + if FAuthEngineTimeStamp = 0 then //out of sync + x := 0 + else + x := TickDelta(FAuthEngineTimeStamp, GetTick) div 1000; + + authbeg := ASNObject(FAuthEngineID, ASN1_OCTSTR) + + ASNObject(ASNEncInt(FAuthEngineBoots), ASN1_INT) + + ASNObject(ASNEncInt(FAuthEngineTime + x), ASN1_INT) + + ASNObject(FUserName, ASN1_OCTSTR); + + + case FFlags of + AuthNoPriv, + AuthPriv: + begin + s := authbeg + ASNObject(StringOfChar(#0, 12), ASN1_OCTSTR) + + ASNObject(FPrivSalt, ASN1_OCTSTR); + s := ASNObject(s, ASN1_SEQ); + s := head + ASNObject(s, ASN1_OCTSTR); + s := ASNObject(s + pdu, ASN1_SEQ); + //in s is entire packet without auth info... + case FAuthMode of + AuthMD5: + begin + s := HMAC_MD5(s, Pass2Key(FPassword) + StringOfChar(#0, 48)); + //strip to HMAC-MD5-96 + delete(s, 13, 4); + end; + AuthSHA1: + begin + s := HMAC_SHA1(s, Pass2Key(FPassword) + StringOfChar(#0, 44)); + //strip to HMAC-SHA-96 + delete(s, 13, 8); + end; + else + s := ''; + end; + FAuthKey := s; + end; + end; + + auth := authbeg + ASNObject(FAuthKey, ASN1_OCTSTR) + + ASNObject(FPrivSalt, ASN1_OCTSTR); + auth := ASNObject(auth, ASN1_SEQ); + + head := head + ASNObject(auth, ASN1_OCTSTR); + Result := ASNObject(head + pdu, ASN1_SEQ); + end + else + begin + head := ASNObject(ASNEncInt(Self.FVersion), ASN1_INT) + + ASNObject(Self.FCommunity, ASN1_OCTSTR); + Result := ASNObject(head + pdu, ASN1_SEQ); + end; + inc(self.FID); +end; + +procedure TSNMPRec.Clear; +var + i: Integer; +begin + FVersion := SNMP_V1; + FCommunity := 'public'; + FUserName := ''; + FPDUType := 0; + FErrorStatus := 0; + FErrorIndex := 0; + for i := 0 to FSNMPMibList.Count - 1 do + TSNMPMib(FSNMPMibList[i]).Free; + FSNMPMibList.Clear; + FOldTrapEnterprise := ''; + FOldTrapHost := ''; + FOldTrapGen := 0; + FOldTrapSpec := 0; + FOldTrapTimeTicks := 0; + FFlags := NoAuthNoPriv; + FFlagReportable := false; + FContextEngineID := ''; + FContextName := ''; + FAuthEngineID := ''; + FAuthEngineBoots := 0; + FAuthEngineTime := 0; + FAuthEngineTimeStamp := 0; + FAuthKey := ''; + FPrivKey := ''; + FPrivSalt := ''; + FPrivSaltCounter := random(maxint); +end; + +procedure TSNMPRec.MIBAdd(const MIB, Value: AnsiString; ValueType: Integer); +var + SNMPMib: TSNMPMib; +begin + SNMPMib := TSNMPMib.Create; + SNMPMib.OID := MIB; + SNMPMib.Value := Value; + SNMPMib.ValueType := ValueType; + FSNMPMibList.Add(SNMPMib); +end; + +procedure TSNMPRec.MIBDelete(Index: Integer); +begin + if (Index >= 0) and (Index < MIBCount) then + begin + TSNMPMib(FSNMPMibList[Index]).Free; + FSNMPMibList.Delete(Index); + end; +end; + +function TSNMPRec.MIBCount: integer; +begin + Result := FSNMPMibList.Count; +end; + +function TSNMPRec.MIBByIndex(Index: Integer): TSNMPMib; +begin + Result := nil; + if (Index >= 0) and (Index < MIBCount) then + Result := TSNMPMib(FSNMPMibList[Index]); +end; + +function TSNMPRec.MIBGet(const MIB: AnsiString): AnsiString; +var + i: Integer; +begin + Result := ''; + for i := 0 to MIBCount - 1 do + begin + if ((TSNMPMib(FSNMPMibList[i])).OID = MIB) then + begin + Result := (TSNMPMib(FSNMPMibList[i])).Value; + Break; + end; + end; +end; + +{==============================================================================} + +constructor TSNMPSend.Create; +begin + inherited Create; + FQuery := TSNMPRec.Create; + FReply := TSNMPRec.Create; + FQuery.Clear; + FReply.Clear; + FSock := TUDPBlockSocket.Create; + FSock.Owner := self; + FTimeout := 5000; + FTargetPort := cSnmpProtocol; + FHostIP := ''; +end; + +destructor TSNMPSend.Destroy; +begin + FSock.Free; + FReply.Free; + FQuery.Free; + inherited Destroy; +end; + +function TSNMPSend.InternalSendSnmp(const Value: TSNMPRec): Boolean; +begin + FBuffer := Value.EncodeBuf; + FSock.SendString(FBuffer); + Result := FSock.LastError = 0; +end; + +function TSNMPSend.InternalRecvSnmp(const Value: TSNMPRec): Boolean; +begin + Result := False; + FReply.Clear; + FHostIP := cAnyHost; + FBuffer := FSock.RecvPacket(FTimeout); + if FSock.LastError = 0 then + begin + FHostIP := FSock.GetRemoteSinIP; + Result := Value.DecodeBuf(FBuffer); + end; +end; + +function TSNMPSend.InternalSendRequest(const QValue, RValue: TSNMPRec): Boolean; +begin + Result := False; + RValue.AuthMode := QValue.AuthMode; + RValue.Password := QValue.Password; + RValue.PrivMode := QValue.PrivMode; + RValue.PrivPassword := QValue.PrivPassword; + FSock.Bind(FIPInterface, cAnyPort); + FSock.Connect(FTargetHost, FTargetPort); + if InternalSendSnmp(QValue) then + Result := InternalRecvSnmp(RValue); +end; + +function TSNMPSend.SendRequest: Boolean; +var + sync: TV3Sync; +begin + Result := False; + if FQuery.FVersion = 3 then + begin + sync := GetV3Sync; + FQuery.AuthEngineBoots := Sync.EngineBoots; + FQuery.AuthEngineTime := Sync.EngineTime; + FQuery.AuthEngineTimeStamp := Sync.EngineStamp; + FQuery.AuthEngineID := Sync.EngineID; + end; + Result := InternalSendRequest(FQuery, FReply); +end; + +function TSNMPSend.SendTrap: Boolean; +begin + FSock.Bind(FIPInterface, cAnyPort); + FSock.Connect(FTargetHost, FTargetPort); + Result := InternalSendSnmp(FQuery); +end; + +function TSNMPSend.RecvTrap: Boolean; +begin + FSock.Bind(FIPInterface, FTargetPort); + Result := InternalRecvSnmp(FReply); +end; + +function TSNMPSend.DoIt: Boolean; +begin + Result := SendRequest; +end; + +function TSNMPSend.GetV3EngineID: AnsiString; +var + DisQuery: TSNMPRec; +begin + Result := ''; + DisQuery := TSNMPRec.Create; + try + DisQuery.Version := 3; + DisQuery.UserName := ''; + DisQuery.FlagReportable := True; + DisQuery.PDUType := PDUGetRequest; + if InternalSendRequest(DisQuery, FReply) then + Result := FReply.FAuthEngineID; + finally + DisQuery.Free; + end; +end; + +function TSNMPSend.GetV3Sync: TV3Sync; +var + SyncQuery: TSNMPRec; +begin + Result.EngineID := GetV3EngineID; + Result.EngineBoots := FReply.AuthEngineBoots; + Result.EngineTime := FReply.AuthEngineTime; + Result.EngineStamp := FReply.AuthEngineTimeStamp; + if Result.EngineTime = 0 then + begin + //still not have sync... + SyncQuery := TSNMPRec.Create; + try + SyncQuery.Version := 3; + SyncQuery.UserName := FQuery.UserName; + SyncQuery.Password := FQuery.Password; + SyncQuery.FlagReportable := True; + SyncQuery.Flags := FQuery.Flags; + SyncQuery.AuthMode := FQuery.AuthMode; + SyncQuery.PrivMode := FQuery.PrivMode; + SyncQuery.PrivPassword := FQuery.PrivPassword; + SyncQuery.PDUType := PDUGetRequest; + SyncQuery.AuthEngineID := FReply.FAuthEngineID; + if InternalSendRequest(SyncQuery, FReply) then + begin + Result.EngineBoots := FReply.AuthEngineBoots; + Result.EngineTime := FReply.AuthEngineTime; + Result.EngineStamp := FReply.AuthEngineTimeStamp; + end; + finally + SyncQuery.Free; + end; + end; +end; + +{==============================================================================} + +function SNMPGet(const OID, Community, SNMPHost: AnsiString; var Value: AnsiString): Boolean; +var + SNMPSend: TSNMPSend; +begin + SNMPSend := TSNMPSend.Create; + try + SNMPSend.Query.Clear; + SNMPSend.Query.Community := Community; + SNMPSend.Query.PDUType := PDUGetRequest; + SNMPSend.Query.MIBAdd(OID, '', ASN1_NULL); + SNMPSend.TargetHost := SNMPHost; + Result := SNMPSend.SendRequest; + Value := ''; + if Result then + Value := SNMPSend.Reply.MIBGet(OID); + finally + SNMPSend.Free; + end; +end; + +function SNMPSet(const OID, Community, SNMPHost, Value: AnsiString; ValueType: Integer): Boolean; +var + SNMPSend: TSNMPSend; +begin + SNMPSend := TSNMPSend.Create; + try + SNMPSend.Query.Clear; + SNMPSend.Query.Community := Community; + SNMPSend.Query.PDUType := PDUSetRequest; + SNMPSend.Query.MIBAdd(OID, Value, ValueType); + SNMPSend.TargetHost := SNMPHost; + Result := SNMPSend.Sendrequest = True; + finally + SNMPSend.Free; + end; +end; + +function InternalGetNext(const SNMPSend: TSNMPSend; var OID: AnsiString; + const Community: AnsiString; var Value: AnsiString): Boolean; +begin + SNMPSend.Query.Clear; + SNMPSend.Query.ID := SNMPSend.Query.ID + 1; + SNMPSend.Query.Community := Community; + SNMPSend.Query.PDUType := PDUGetNextRequest; + SNMPSend.Query.MIBAdd(OID, '', ASN1_NULL); + Result := SNMPSend.Sendrequest; + Value := ''; + if Result then + if SNMPSend.Reply.SNMPMibList.Count > 0 then + begin + OID := TSNMPMib(SNMPSend.Reply.SNMPMibList[0]).OID; + Value := TSNMPMib(SNMPSend.Reply.SNMPMibList[0]).Value; + end; +end; + +function SNMPGetNext(var OID: AnsiString; const Community, SNMPHost: AnsiString; var Value: AnsiString): Boolean; +var + SNMPSend: TSNMPSend; +begin + SNMPSend := TSNMPSend.Create; + try + SNMPSend.TargetHost := SNMPHost; + Result := InternalGetNext(SNMPSend, OID, Community, Value); + finally + SNMPSend.Free; + end; +end; + +function SNMPGetTable(const BaseOID, Community, SNMPHost: AnsiString; const Value: TStrings): Boolean; +var + OID: AnsiString; + s: AnsiString; + col,row: String; + x: integer; + SNMPSend: TSNMPSend; + RowList: TStringList; +begin + Value.Clear; + SNMPSend := TSNMPSend.Create; + RowList := TStringList.Create; + try + SNMPSend.TargetHost := SNMPHost; + OID := BaseOID; + repeat + Result := InternalGetNext(SNMPSend, OID, Community, s); + if Pos(BaseOID, OID) <> 1 then + break; + row := separateright(oid, baseoid + '.'); + col := fetch(row, '.'); + + if IsBinaryString(s) then + s := StrToHex(s); + x := RowList.indexOf(Row); + if x < 0 then + begin + x := RowList.add(Row); + Value.Add(''); + end; + if (Value[x] <> '') then + Value[x] := Value[x] + ','; + Value[x] := Value[x] + AnsiQuotedStr(s, '"'); + until not result; + finally + SNMPSend.Free; + RowList.Free; + end; +end; + +function SNMPGetTableElement(const BaseOID, RowID, ColID, Community, SNMPHost: AnsiString; var Value: AnsiString): Boolean; +var + s: AnsiString; +begin + s := BaseOID + '.' + ColID + '.' + RowID; + Result := SnmpGet(s, Community, SNMPHost, Value); +end; + +function SendTrap(const Dest, Source, Enterprise, Community: AnsiString; + Generic, Specific, Seconds: Integer; const MIBName, MIBValue: AnsiString; + MIBtype: Integer): Integer; +var + SNMPSend: TSNMPSend; +begin + SNMPSend := TSNMPSend.Create; + try + SNMPSend.TargetHost := Dest; + SNMPSend.TargetPort := cSnmpTrapProtocol; + SNMPSend.Query.Community := Community; + SNMPSend.Query.Version := SNMP_V1; + SNMPSend.Query.PDUType := PDUTrap; + SNMPSend.Query.OldTrapHost := Source; + SNMPSend.Query.OldTrapEnterprise := Enterprise; + SNMPSend.Query.OldTrapGen := Generic; + SNMPSend.Query.OldTrapSpec := Specific; + SNMPSend.Query.OldTrapTimeTicks := Seconds; + SNMPSend.Query.MIBAdd(MIBName, MIBValue, MIBType); + Result := Ord(SNMPSend.SendTrap); + finally + SNMPSend.Free; + end; +end; + +function RecvTrap(var Dest, Source, Enterprise, Community: AnsiString; + var Generic, Specific, Seconds: Integer; + const MIBName, MIBValue: TStringList): Integer; +var + SNMPSend: TSNMPSend; + i: Integer; +begin + SNMPSend := TSNMPSend.Create; + try + Result := 0; + SNMPSend.TargetPort := cSnmpTrapProtocol; + if SNMPSend.RecvTrap then + begin + Result := 1; + Dest := SNMPSend.HostIP; + Community := SNMPSend.Reply.Community; + Source := SNMPSend.Reply.OldTrapHost; + Enterprise := SNMPSend.Reply.OldTrapEnterprise; + Generic := SNMPSend.Reply.OldTrapGen; + Specific := SNMPSend.Reply.OldTrapSpec; + Seconds := SNMPSend.Reply.OldTrapTimeTicks; + MIBName.Clear; + MIBValue.Clear; + for i := 0 to SNMPSend.Reply.SNMPMibList.Count - 1 do + begin + MIBName.Add(TSNMPMib(SNMPSend.Reply.SNMPMibList[i]).OID); + MIBValue.Add(TSNMPMib(SNMPSend.Reply.SNMPMibList[i]).Value); + end; + end; + finally + SNMPSend.Free; + end; +end; + + +end. + + diff --git a/synapse/sntpsend.pas b/synapse/sntpsend.pas new file mode 100644 index 0000000..4aa0bbf --- /dev/null +++ b/synapse/sntpsend.pas @@ -0,0 +1,374 @@ +{==============================================================================| +| Project : Ararat Synapse | 003.000.003 | +|==============================================================================| +| Content: SNTP 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): | +| Patrick Chevalley | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +{:@abstract( NTP and SNTP client) + +Used RFC: RFC-1305, RFC-2030 +} + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$Q-} +{$H+} + +unit sntpsend; + +interface + +uses + SysUtils, + synsock, blcksock, synautil; + +const + cNtpProtocol = '123'; + +type + + {:@abstract(Record containing the NTP packet.)} + TNtp = packed record + mode: Byte; + stratum: Byte; + poll: Byte; + Precision: Byte; + RootDelay: Longint; + RootDisperson: Longint; + RefID: Longint; + Ref1: Longint; + Ref2: Longint; + Org1: Longint; + Org2: Longint; + Rcv1: Longint; + Rcv2: Longint; + Xmit1: Longint; + Xmit2: Longint; + end; + + {:@abstract(Implementation of NTP and SNTP client protocol), + include time synchronisation. It can send NTP or SNTP time queries, or it + can receive NTP broadcasts too. + + Note: Are you missing properties for specify server address and port? Look to + parent @link(TSynaClient) too!} + TSNTPSend = class(TSynaClient) + private + FNTPReply: TNtp; + FNTPTime: TDateTime; + FNTPOffset: double; + FNTPDelay: double; + FMaxSyncDiff: double; + FSyncTime: Boolean; + FSock: TUDPBlockSocket; + FBuffer: AnsiString; + FLi, FVn, Fmode : byte; + function StrToNTP(const Value: AnsiString): TNtp; + function NTPtoStr(const Value: Tntp): AnsiString; + procedure ClearNTP(var Value: Tntp); + public + constructor Create; + destructor Destroy; override; + + {:Decode 128 bit timestamp used in NTP packet to TDateTime type.} + function DecodeTs(Nsec, Nfrac: Longint): TDateTime; + + {:Decode TDateTime type to 128 bit timestamp used in NTP packet.} + procedure EncodeTs(dt: TDateTime; var Nsec, Nfrac: Longint); + + {:Send request to @link(TSynaClient.TargetHost) and wait for reply. If all + is OK, then result is @true and @link(NTPReply) and @link(NTPTime) are + valid.} + function GetSNTP: Boolean; + + {:Send request to @link(TSynaClient.TargetHost) and wait for reply. If all + is OK, then result is @true and @link(NTPReply) and @link(NTPTime) are + valid. Result time is after all needed corrections.} + function GetNTP: Boolean; + + {:Wait for broadcast NTP packet. If all OK, result is @true and + @link(NTPReply) and @link(NTPTime) are valid.} + function GetBroadcastNTP: Boolean; + + {:Holds last received NTP packet.} + property NTPReply: TNtp read FNTPReply; + published + {:Date and time of remote NTP or SNTP server. (UTC time!!!)} + property NTPTime: TDateTime read FNTPTime; + + {:Offset between your computer and remote NTP or SNTP server.} + property NTPOffset: Double read FNTPOffset; + + {:Delay between your computer and remote NTP or SNTP server.} + property NTPDelay: Double read FNTPDelay; + + {:Define allowed maximum difference between your time and remote time for + synchronising time. If difference is bigger, your system time is not + changed!} + property MaxSyncDiff: double read FMaxSyncDiff write FMaxSyncDiff; + + {:If @true, after successfull getting time is local computer clock + synchronised to given time. + For synchronising time you must have proper rights! (Usually Administrator)} + property SyncTime: Boolean read FSyncTime write FSyncTime; + + {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.} + property Sock: TUDPBlockSocket read FSock; + end; + +implementation + +constructor TSNTPSend.Create; +begin + inherited Create; + FSock := TUDPBlockSocket.Create; + FSock.Owner := self; + FTimeout := 5000; + FTargetPort := cNtpProtocol; + FMaxSyncDiff := 3600; + FSyncTime := False; +end; + +destructor TSNTPSend.Destroy; +begin + FSock.Free; + inherited Destroy; +end; + +function TSNTPSend.StrToNTP(const Value: AnsiString): TNtp; +begin + if length(FBuffer) >= SizeOf(Result) then + begin + Result.mode := ord(Value[1]); + Result.stratum := ord(Value[2]); + Result.poll := ord(Value[3]); + Result.Precision := ord(Value[4]); + Result.RootDelay := DecodeLongInt(value, 5); + Result.RootDisperson := DecodeLongInt(value, 9); + Result.RefID := DecodeLongInt(value, 13); + Result.Ref1 := DecodeLongInt(value, 17); + Result.Ref2 := DecodeLongInt(value, 21); + Result.Org1 := DecodeLongInt(value, 25); + Result.Org2 := DecodeLongInt(value, 29); + Result.Rcv1 := DecodeLongInt(value, 33); + Result.Rcv2 := DecodeLongInt(value, 37); + Result.Xmit1 := DecodeLongInt(value, 41); + Result.Xmit2 := DecodeLongInt(value, 45); + end; + +end; + +function TSNTPSend.NTPtoStr(const Value: Tntp): AnsiString; +begin + SetLength(Result, 4); + Result[1] := AnsiChar(Value.mode); + Result[2] := AnsiChar(Value.stratum); + Result[3] := AnsiChar(Value.poll); + Result[4] := AnsiChar(Value.precision); + Result := Result + CodeLongInt(Value.RootDelay); + Result := Result + CodeLongInt(Value.RootDisperson); + Result := Result + CodeLongInt(Value.RefID); + Result := Result + CodeLongInt(Value.Ref1); + Result := Result + CodeLongInt(Value.Ref2); + Result := Result + CodeLongInt(Value.Org1); + Result := Result + CodeLongInt(Value.Org2); + Result := Result + CodeLongInt(Value.Rcv1); + Result := Result + CodeLongInt(Value.Rcv2); + Result := Result + CodeLongInt(Value.Xmit1); + Result := Result + CodeLongInt(Value.Xmit2); +end; + +procedure TSNTPSend.ClearNTP(var Value: Tntp); +begin + Value.mode := 0; + Value.stratum := 0; + Value.poll := 0; + Value.Precision := 0; + Value.RootDelay := 0; + Value.RootDisperson := 0; + Value.RefID := 0; + Value.Ref1 := 0; + Value.Ref2 := 0; + Value.Org1 := 0; + Value.Org2 := 0; + Value.Rcv1 := 0; + Value.Rcv2 := 0; + Value.Xmit1 := 0; + Value.Xmit2 := 0; +end; + +function TSNTPSend.DecodeTs(Nsec, Nfrac: Longint): TDateTime; +const + maxi = 4294967295.0; +var + d, d1: Double; +begin + d := Nsec; + if d < 0 then + d := maxi + d + 1; + d1 := Nfrac; + if d1 < 0 then + d1 := maxi + d1 + 1; + d1 := d1 / maxi; + d1 := Trunc(d1 * 10000) / 10000; + Result := (d + d1) / 86400; + Result := Result + 2; +end; + +procedure TSNTPSend.EncodeTs(dt: TDateTime; var Nsec, Nfrac: Longint); +const + maxi = 4294967295.0; + maxilongint = 2147483647; +var + d, d1: Double; +begin + d := (dt - 2) * 86400; + d1 := frac(d); + if d > maxilongint then + d := d - maxi - 1; + d := trunc(d); + d1 := Trunc(d1 * 10000) / 10000; + d1 := d1 * maxi; + if d1 > maxilongint then + d1 := d1 - maxi - 1; + Nsec:=trunc(d); + Nfrac:=trunc(d1); +end; + +function TSNTPSend.GetBroadcastNTP: Boolean; +var + x: Integer; +begin + Result := False; + FSock.Bind(FIPInterface, FTargetPort); + FBuffer := FSock.RecvPacket(FTimeout); + if FSock.LastError = 0 then + begin + x := Length(FBuffer); + if (FTargetHost = '0.0.0.0') or (FSock.GetRemoteSinIP = FSock.ResolveName(FTargetHost)) then + if x >= SizeOf(NTPReply) then + begin + FNTPReply := StrToNTP(FBuffer); + FNTPTime := DecodeTs(NTPReply.Xmit1, NTPReply.Xmit2); + if FSyncTime and ((abs(FNTPTime - GetUTTime) * 86400) <= FMaxSyncDiff) then + SetUTTime(FNTPTime); + Result := True; + end; + end; +end; + +function TSNTPSend.GetSNTP: Boolean; +var + q: TNtp; + x: Integer; +begin + Result := False; + FSock.CloseSocket; + FSock.Bind(FIPInterface, cAnyPort); + FSock.Connect(FTargetHost, FTargetPort); + ClearNtp(q); + q.mode := $1B; + FBuffer := NTPtoStr(q); + FSock.SendString(FBuffer); + FBuffer := FSock.RecvPacket(FTimeout); + if FSock.LastError = 0 then + begin + x := Length(FBuffer); + if x >= SizeOf(NTPReply) then + begin + FNTPReply := StrToNTP(FBuffer); + FNTPTime := DecodeTs(NTPReply.Xmit1, NTPReply.Xmit2); + if FSyncTime and ((abs(FNTPTime - GetUTTime) * 86400) <= FMaxSyncDiff) then + SetUTTime(FNTPTime); + Result := True; + end; + end; +end; + +function TSNTPSend.GetNTP: Boolean; +var + q: TNtp; + x: Integer; + t1, t2, t3, t4 : TDateTime; +begin + Result := False; + FSock.CloseSocket; + FSock.Bind(FIPInterface, cAnyPort); + FSock.Connect(FTargetHost, FTargetPort); + ClearNtp(q); + q.mode := $1B; + t1 := GetUTTime; + EncodeTs(t1, q.org1, q.org2); + FBuffer := NTPtoStr(q); + FSock.SendString(FBuffer); + FBuffer := FSock.RecvPacket(FTimeout); + if FSock.LastError = 0 then + begin + x := Length(FBuffer); + t4 := GetUTTime; + if x >= SizeOf(NTPReply) then + begin + FNTPReply := StrToNTP(FBuffer); + FLi := (NTPReply.mode and $C0) shr 6; + FVn := (NTPReply.mode and $38) shr 3; + Fmode := NTPReply.mode and $07; + if (Fli < 3) and (Fmode = 4) and + (NTPReply.stratum >= 1) and (NTPReply.stratum <= 15) and + (NTPReply.Rcv1 <> 0) and (NTPReply.Xmit1 <> 0) + then begin + t2 := DecodeTs(NTPReply.Rcv1, NTPReply.Rcv2); + t3 := DecodeTs(NTPReply.Xmit1, NTPReply.Xmit2); + FNTPDelay := (T4 - T1) - (T2 - T3); + FNTPTime := t3 + FNTPDelay / 2; + FNTPOffset := (((T2 - T1) + (T3 - T4)) / 2) * 86400; + FNTPDelay := FNTPDelay * 86400; + if FSyncTime and ((abs(FNTPTime - t1) * 86400) <= FMaxSyncDiff) then + SetUTTime(FNTPTime); + Result := True; + end + else result:=false; + end; + end; +end; + +end. diff --git a/synapse/ssdotnet.inc b/synapse/ssdotnet.inc new file mode 100644 index 0000000..8a54cd8 --- /dev/null +++ b/synapse/ssdotnet.inc @@ -0,0 +1,1099 @@ +{==============================================================================| +| Project : Ararat Synapse | 001.000.002 | +|==============================================================================| +| Content: Socket Independent Platform Layer - .NET definition include | +|==============================================================================| +| Copyright (c)2004, 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)2004. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +{:@exclude} + +{$IFDEF CIL} + +interface + +uses + SyncObjs, SysUtils, Classes, + System.Net, + System.Net.Sockets; + +const + DLLStackName = ''; + WinsockLevel = $0202; + +function InitSocketInterface(stack: string): Boolean; +function DestroySocketInterface: Boolean; + +type + u_char = Char; + u_short = Word; + u_int = Integer; + u_long = Longint; + pu_long = ^u_long; + pu_short = ^u_short; + PSockAddr = IPEndPoint; + DWORD = integer; + ULong = cardinal; + TMemory = Array of byte; + TLinger = LingerOption; + TSocket = socket; + TAddrFamily = AddressFamily; + +const + WSADESCRIPTION_LEN = 256; + WSASYS_STATUS_LEN = 128; +type + PWSAData = ^TWSAData; + TWSAData = packed record + wVersion: Word; + wHighVersion: Word; + szDescription: array[0..WSADESCRIPTION_LEN] of Char; + szSystemStatus: array[0..WSASYS_STATUS_LEN] of Char; + iMaxSockets: Word; + iMaxUdpDg: Word; +// lpVendorInfo: PChar; + end; + +const + MSG_NOSIGNAL = 0; + INVALID_SOCKET = nil; + AF_UNSPEC = AddressFamily.Unspecified; + AF_INET = AddressFamily.InterNetwork; + AF_INET6 = AddressFamily.InterNetworkV6; + SOCKET_ERROR = integer(-1); + + FIONREAD = integer($4004667f); + FIONBIO = integer($8004667e); + FIOASYNC = integer($8004667d); + + SOMAXCONN = integer($7fffffff); + + IPPROTO_IP = ProtocolType.IP; + IPPROTO_ICMP = ProtocolType.Icmp; + IPPROTO_IGMP = ProtocolType.Igmp; + IPPROTO_TCP = ProtocolType.Tcp; + IPPROTO_UDP = ProtocolType.Udp; + IPPROTO_RAW = ProtocolType.Raw; + IPPROTO_IPV6 = ProtocolType.IPV6; +// + IPPROTO_ICMPV6 = ProtocolType.Icmp; //?? + + SOCK_STREAM = SocketType.Stream; + SOCK_DGRAM = SocketType.Dgram; + SOCK_RAW = SocketType.Raw; + SOCK_RDM = SocketType.Rdm; + SOCK_SEQPACKET = SocketType.Seqpacket; + + SOL_SOCKET = SocketOptionLevel.Socket; + SOL_IP = SocketOptionLevel.Ip; + + + IP_OPTIONS = SocketOptionName.IPOptions; + IP_HDRINCL = SocketOptionName.HeaderIncluded; + IP_TOS = SocketOptionName.TypeOfService; { set/get IP Type Of Service } + IP_TTL = SocketOptionName.IpTimeToLive; { set/get IP Time To Live } + IP_MULTICAST_IF = SocketOptionName.MulticastInterface; { set/get IP multicast interface } + IP_MULTICAST_TTL = SocketOptionName.MulticastTimeToLive; { set/get IP multicast timetolive } + IP_MULTICAST_LOOP = SocketOptionName.MulticastLoopback; { set/get IP multicast loopback } + IP_ADD_MEMBERSHIP = SocketOptionName.AddMembership; { add an IP group membership } + IP_DROP_MEMBERSHIP = SocketOptionName.DropMembership; { drop an IP group membership } + IP_DONTFRAGMENT = SocketOptionName.DontFragment; { set/get IP Don't Fragment flag } + + IPV6_UNICAST_HOPS = 8; // TTL + IPV6_MULTICAST_IF = 9; // set/get IP multicast i/f + IPV6_MULTICAST_HOPS = 10; // set/get IP multicast ttl + IPV6_MULTICAST_LOOP = 11; // set/get IP multicast loopback + IPV6_JOIN_GROUP = 12; // add an IP group membership + IPV6_LEAVE_GROUP = 13; // drop an IP group membership + + SO_DEBUG = SocketOptionName.Debug; { turn on debugging info recording } + SO_ACCEPTCONN = SocketOptionName.AcceptConnection; { socket has had listen() } + SO_REUSEADDR = SocketOptionName.ReuseAddress; { allow local address reuse } + SO_KEEPALIVE = SocketOptionName.KeepAlive; { keep connections alive } + SO_DONTROUTE = SocketOptionName.DontRoute; { just use interface addresses } + SO_BROADCAST = SocketOptionName.Broadcast; { permit sending of broadcast msgs } + SO_USELOOPBACK = SocketOptionName.UseLoopback; { bypass hardware when possible } + SO_LINGER = SocketOptionName.Linger; { linger on close if data present } + SO_OOBINLINE = SocketOptionName.OutOfBandInline; { leave received OOB data in line } + SO_DONTLINGER = SocketOptionName.DontLinger; +{ Additional options. } + SO_SNDBUF = SocketOptionName.SendBuffer; { send buffer size } + SO_RCVBUF = SocketOptionName.ReceiveBuffer; { receive buffer size } + SO_SNDLOWAT = SocketOptionName.SendLowWater; { send low-water mark } + SO_RCVLOWAT = SocketOptionName.ReceiveLowWater; { receive low-water mark } + SO_SNDTIMEO = SocketOptionName.SendTimeout; { send timeout } + SO_RCVTIMEO = SocketOptionName.ReceiveTimeout; { receive timeout } + SO_ERROR = SocketOptionName.Error; { get error status and clear } + SO_TYPE = SocketOptionName.Type; { get socket type } + +{ WinSock 2 extension -- new options } +// SO_GROUP_ID = $2001; { ID of a socket group} +// SO_GROUP_PRIORITY = $2002; { the relative priority within a group} +// SO_MAX_MSG_SIZE = $2003; { maximum message size } +// SO_PROTOCOL_INFOA = $2004; { WSAPROTOCOL_INFOA structure } +// SO_PROTOCOL_INFOW = $2005; { WSAPROTOCOL_INFOW structure } +// SO_PROTOCOL_INFO = SO_PROTOCOL_INFOA; +// PVD_CONFIG = $3001; {configuration info for service provider } +{ Option for opening sockets for synchronous access. } +// SO_OPENTYPE = $7008; +// SO_SYNCHRONOUS_ALERT = $10; +// SO_SYNCHRONOUS_NONALERT = $20; +{ Other NT-specific options. } +// SO_MAXDG = $7009; +// SO_MAXPATHDG = $700A; +// SO_UPDATE_ACCEPT_CONTEXT = $700B; +// SO_CONNECT_TIME = $700C; + + + { All Windows Sockets error constants are biased by WSABASEERR from the "normal" } + WSABASEERR = 10000; + +{ Windows Sockets definitions of regular Microsoft C error constants } + + WSAEINTR = (WSABASEERR+4); + WSAEBADF = (WSABASEERR+9); + WSAEACCES = (WSABASEERR+13); + WSAEFAULT = (WSABASEERR+14); + WSAEINVAL = (WSABASEERR+22); + WSAEMFILE = (WSABASEERR+24); + +{ Windows Sockets definitions of regular Berkeley error constants } + + WSAEWOULDBLOCK = (WSABASEERR+35); + WSAEINPROGRESS = (WSABASEERR+36); + WSAEALREADY = (WSABASEERR+37); + WSAENOTSOCK = (WSABASEERR+38); + WSAEDESTADDRREQ = (WSABASEERR+39); + WSAEMSGSIZE = (WSABASEERR+40); + WSAEPROTOTYPE = (WSABASEERR+41); + WSAENOPROTOOPT = (WSABASEERR+42); + WSAEPROTONOSUPPORT = (WSABASEERR+43); + WSAESOCKTNOSUPPORT = (WSABASEERR+44); + WSAEOPNOTSUPP = (WSABASEERR+45); + WSAEPFNOSUPPORT = (WSABASEERR+46); + WSAEAFNOSUPPORT = (WSABASEERR+47); + WSAEADDRINUSE = (WSABASEERR+48); + WSAEADDRNOTAVAIL = (WSABASEERR+49); + WSAENETDOWN = (WSABASEERR+50); + WSAENETUNREACH = (WSABASEERR+51); + WSAENETRESET = (WSABASEERR+52); + WSAECONNABORTED = (WSABASEERR+53); + WSAECONNRESET = (WSABASEERR+54); + WSAENOBUFS = (WSABASEERR+55); + WSAEISCONN = (WSABASEERR+56); + WSAENOTCONN = (WSABASEERR+57); + WSAESHUTDOWN = (WSABASEERR+58); + WSAETOOMANYREFS = (WSABASEERR+59); + WSAETIMEDOUT = (WSABASEERR+60); + WSAECONNREFUSED = (WSABASEERR+61); + WSAELOOP = (WSABASEERR+62); + WSAENAMETOOLONG = (WSABASEERR+63); + WSAEHOSTDOWN = (WSABASEERR+64); + WSAEHOSTUNREACH = (WSABASEERR+65); + WSAENOTEMPTY = (WSABASEERR+66); + WSAEPROCLIM = (WSABASEERR+67); + WSAEUSERS = (WSABASEERR+68); + WSAEDQUOT = (WSABASEERR+69); + WSAESTALE = (WSABASEERR+70); + WSAEREMOTE = (WSABASEERR+71); + +{ Extended Windows Sockets error constant definitions } + + WSASYSNOTREADY = (WSABASEERR+91); + WSAVERNOTSUPPORTED = (WSABASEERR+92); + WSANOTINITIALISED = (WSABASEERR+93); + WSAEDISCON = (WSABASEERR+101); + WSAENOMORE = (WSABASEERR+102); + WSAECANCELLED = (WSABASEERR+103); + WSAEEINVALIDPROCTABLE = (WSABASEERR+104); + WSAEINVALIDPROVIDER = (WSABASEERR+105); + WSAEPROVIDERFAILEDINIT = (WSABASEERR+106); + WSASYSCALLFAILURE = (WSABASEERR+107); + WSASERVICE_NOT_FOUND = (WSABASEERR+108); + WSATYPE_NOT_FOUND = (WSABASEERR+109); + WSA_E_NO_MORE = (WSABASEERR+110); + WSA_E_CANCELLED = (WSABASEERR+111); + WSAEREFUSED = (WSABASEERR+112); + +{ Error return codes from gethostbyname() and gethostbyaddr() + (when using the resolver). Note that these errors are + retrieved via WSAGetLastError() and must therefore follow + the rules for avoiding clashes with error numbers from + specific implementations or language run-time systems. + For this reason the codes are based at WSABASEERR+1001. + Note also that [WSA]NO_ADDRESS is defined only for + compatibility purposes. } + +{ Authoritative Answer: Host not found } + WSAHOST_NOT_FOUND = (WSABASEERR+1001); + HOST_NOT_FOUND = WSAHOST_NOT_FOUND; +{ Non-Authoritative: Host not found, or SERVERFAIL } + WSATRY_AGAIN = (WSABASEERR+1002); + TRY_AGAIN = WSATRY_AGAIN; +{ Non recoverable errors, FORMERR, REFUSED, NOTIMP } + WSANO_RECOVERY = (WSABASEERR+1003); + NO_RECOVERY = WSANO_RECOVERY; +{ Valid name, no data record of requested type } + WSANO_DATA = (WSABASEERR+1004); + NO_DATA = WSANO_DATA; +{ no address, look for MX record } + WSANO_ADDRESS = WSANO_DATA; + NO_ADDRESS = WSANO_ADDRESS; + + EWOULDBLOCK = WSAEWOULDBLOCK; + EINPROGRESS = WSAEINPROGRESS; + EALREADY = WSAEALREADY; + ENOTSOCK = WSAENOTSOCK; + EDESTADDRREQ = WSAEDESTADDRREQ; + EMSGSIZE = WSAEMSGSIZE; + EPROTOTYPE = WSAEPROTOTYPE; + ENOPROTOOPT = WSAENOPROTOOPT; + EPROTONOSUPPORT = WSAEPROTONOSUPPORT; + ESOCKTNOSUPPORT = WSAESOCKTNOSUPPORT; + EOPNOTSUPP = WSAEOPNOTSUPP; + EPFNOSUPPORT = WSAEPFNOSUPPORT; + EAFNOSUPPORT = WSAEAFNOSUPPORT; + EADDRINUSE = WSAEADDRINUSE; + EADDRNOTAVAIL = WSAEADDRNOTAVAIL; + ENETDOWN = WSAENETDOWN; + ENETUNREACH = WSAENETUNREACH; + ENETRESET = WSAENETRESET; + ECONNABORTED = WSAECONNABORTED; + ECONNRESET = WSAECONNRESET; + ENOBUFS = WSAENOBUFS; + EISCONN = WSAEISCONN; + ENOTCONN = WSAENOTCONN; + ESHUTDOWN = WSAESHUTDOWN; + ETOOMANYREFS = WSAETOOMANYREFS; + ETIMEDOUT = WSAETIMEDOUT; + ECONNREFUSED = WSAECONNREFUSED; + ELOOP = WSAELOOP; + ENAMETOOLONG = WSAENAMETOOLONG; + EHOSTDOWN = WSAEHOSTDOWN; + EHOSTUNREACH = WSAEHOSTUNREACH; + ENOTEMPTY = WSAENOTEMPTY; + EPROCLIM = WSAEPROCLIM; + EUSERS = WSAEUSERS; + EDQUOT = WSAEDQUOT; + ESTALE = WSAESTALE; + EREMOTE = WSAEREMOTE; + + +type + TVarSin = IPEndpoint; + +{ function IN6_IS_ADDR_UNSPECIFIED(const a: PInAddr6): boolean; + function IN6_IS_ADDR_LOOPBACK(const a: PInAddr6): boolean; + function IN6_IS_ADDR_LINKLOCAL(const a: PInAddr6): boolean; + function IN6_IS_ADDR_SITELOCAL(const a: PInAddr6): boolean; + function IN6_IS_ADDR_MULTICAST(const a: PInAddr6): boolean; + function IN6_ADDR_EQUAL(const a: PInAddr6; const b: PInAddr6):boolean; + procedure SET_IN6_IF_ADDR_ANY (const a: PInAddr6); + procedure SET_LOOPBACK_ADDR6 (const a: PInAddr6); +var + in6addr_any, in6addr_loopback : TInAddr6; +} + +{procedure FD_CLR(Socket: TSocket; var FDSet: TFDSet); +function FD_ISSET(Socket: TSocket; var FDSet: TFDSet): Boolean; +procedure FD_SET(Socket: TSocket; var FDSet: TFDSet); +procedure FD_ZERO(var FDSet: TFDSet); +} +{=============================================================================} + + function WSAStartup(wVersionRequired: Word; var WSData: TWSAData): Integer; + function WSACleanup: Integer; + function WSAGetLastError: Integer; + function WSAGetLastErrorDesc: String; + function GetHostName: string; + function Shutdown(s: TSocket; how: Integer): Integer; +// function SetSockOpt(s: TSocket; level, optname: Integer; optval: PChar; +// optlen: Integer): Integer; + function SetSockOpt(s: TSocket; level, optname: Integer; optval: TMemory; + optlen: Integer): Integer; + function SetSockOptObj(s: TSocket; level, optname: Integer; optval: TObject): Integer; + function GetSockOpt(s: TSocket; level, optname: Integer; optval: TMemory; + var optlen: Integer): Integer; +// function SendTo(s: TSocket; const Buf; len, flags: Integer; addrto: PSockAddr; +// tolen: Integer): Integer; +/// function SendTo(s: TSocket; const Buf; len, flags: Integer; addrto: TVarSin): Integer; +/// function Send(s: TSocket; const Buf; len, flags: Integer): Integer; +/// function Recv(s: TSocket; var Buf; len, flags: Integer): Integer; +// function RecvFrom(s: TSocket; var Buf; len, flags: Integer; from: PSockAddr; +// var fromlen: Integer): Integer; +/// function RecvFrom(s: TSocket; var Buf; len, flags: Integer; from: TVarSin): Integer; +function Send(s: TSocket; Buf: TMemory; len, flags: Integer): Integer; +function Recv(s: TSocket; Buf: TMemory; len, flags: Integer): Integer; +function SendTo(s: TSocket; Buf: TMemory; len, flags: Integer; addrto: TVarSin): Integer; +function RecvFrom(s: TSocket; Buf: TMemory; len, flags: Integer; var from: TVarSin): Integer; + function ntohs(netshort: u_short): u_short; + function ntohl(netlong: u_long): u_long; + function Listen(s: TSocket; backlog: Integer): Integer; + function IoctlSocket(s: TSocket; cmd: DWORD; var arg: integer): Integer; + function htons(hostshort: u_short): u_short; + function htonl(hostlong: u_long): u_long; +// function GetSockName(s: TSocket; name: PSockAddr; var namelen: Integer): Integer; + function GetSockName(s: TSocket; var name: TVarSin): Integer; +// function GetPeerName(s: TSocket; name: PSockAddr; var namelen: Integer): Integer; + function GetPeerName(s: TSocket; var name: TVarSin): Integer; +// function Connect(s: TSocket; name: PSockAddr; namelen: Integer): Integer; + function Connect(s: TSocket; const name: TVarSin): Integer; + function CloseSocket(s: TSocket): Integer; +// function Bind(s: TSocket; addr: PSockAddr; namelen: Integer): Integer; + function Bind(s: TSocket; const addr: TVarSin): Integer; +// function Accept(s: TSocket; addr: PSockAddr; var addrlen: Integer): TSocket; + function Accept(s: TSocket; var addr: TVarSin): TSocket; + function Socket(af, Struc, Protocol: Integer): TSocket; +// Select = function(nfds: Integer; readfds, writefds, exceptfds: PFDSet; +// timeout: PTimeVal): Longint; +// {$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF}; + +// TWSAIoctl = function (s: TSocket; dwIoControlCode: DWORD; lpvInBuffer: Pointer; +// cbInBuffer: DWORD; lpvOutBuffer: Pointer; cbOutBuffer: DWORD; +// lpcbBytesReturned: PDWORD; lpOverlapped: Pointer; +// lpCompletionRoutine: pointer): u_int; +// stdcall; + + function GetPortService(value: string): integer; + +function IsNewApi(Family: TAddrFamily): Boolean; +function SetVarSin(var Sin: TVarSin; IP, Port: string; Family: TAddrFamily; SockProtocol, SockType: integer; PreferIP4: Boolean): integer; +function GetSinIP(Sin: TVarSin): string; +function GetSinPort(Sin: TVarSin): Integer; +procedure ResolveNameToIP(Name: string; Family: TAddrFamily; SockProtocol, SockType: integer; const IPList: TStrings); +function ResolveIPToName(IP: string; Family: TAddrFamily; SockProtocol, SockType: integer): string; +function ResolvePort(Port: string; Family: TAddrFamily; SockProtocol, SockType: integer): Word; + +var + SynSockCS: SyncObjs.TCriticalSection; + SockEnhancedApi: Boolean; + SockWship6Api: Boolean; + +{==============================================================================} +implementation + +threadvar + WSALastError: integer; + WSALastErrorDesc: string; + +var + services: Array [0..139, 0..1] of string = + ( + ('echo', '7'), + ('discard', '9'), + ('sink', '9'), + ('null', '9'), + ('systat', '11'), + ('users', '11'), + ('daytime', '13'), + ('qotd', '17'), + ('quote', '17'), + ('chargen', '19'), + ('ttytst', '19'), + ('source', '19'), + ('ftp-data', '20'), + ('ftp', '21'), + ('telnet', '23'), + ('smtp', '25'), + ('mail', '25'), + ('time', '37'), + ('timeserver', '37'), + ('rlp', '39'), + ('nameserver', '42'), + ('name', '42'), + ('nickname', '43'), + ('whois', '43'), + ('domain', '53'), + ('bootps', '67'), + ('dhcps', '67'), + ('bootpc', '68'), + ('dhcpc', '68'), + ('tftp', '69'), + ('gopher', '70'), + ('finger', '79'), + ('http', '80'), + ('www', '80'), + ('www-http', '80'), + ('kerberos', '88'), + ('hostname', '101'), + ('hostnames', '101'), + ('iso-tsap', '102'), + ('rtelnet', '107'), + ('pop2', '109'), + ('postoffice', '109'), + ('pop3', '110'), + ('sunrpc', '111'), + ('rpcbind', '111'), + ('portmap', '111'), + ('auth', '113'), + ('ident', '113'), + ('tap', '113'), + ('uucp-path', '117'), + ('nntp', '119'), + ('usenet', '119'), + ('ntp', '123'), + ('epmap', '135'), + ('loc-srv', '135'), + ('netbios-ns', '137'), + ('nbname', '137'), + ('netbios-dgm', '138'), + ('nbdatagram', '138'), + ('netbios-ssn', '139'), + ('nbsession', '139'), + ('imap', '143'), + ('imap4', '143'), + ('pcmail-srv', '158'), + ('snmp', '161'), + ('snmptrap', '162'), + ('snmp-trap', '162'), + ('print-srv', '170'), + ('bgp', '179'), + ('irc', '194'), + ('ipx', '213'), + ('ldap', '389'), + ('https', '443'), + ('mcom', '443'), + ('microsoft-ds', '445'), + ('kpasswd', '464'), + ('isakmp', '500'), + ('ike', '500'), + ('exec', '512'), + ('biff', '512'), + ('comsat', '512'), + ('login', '513'), + ('who', '513'), + ('whod', '513'), + ('cmd', '514'), + ('shell', '514'), + ('syslog', '514'), + ('printer', '515'), + ('spooler', '515'), + ('talk', '517'), + ('ntalk', '517'), + ('efs', '520'), + ('router', '520'), + ('route', '520'), + ('routed', '520'), + ('timed', '525'), + ('timeserver', '525'), + ('tempo', '526'), + ('newdate', '526'), + ('courier', '530'), + ('rpc', '530'), + ('conference', '531'), + ('chat', '531'), + ('netnews', '532'), + ('readnews', '532'), + ('netwall', '533'), + ('uucp', '540'), + ('uucpd', '540'), + ('klogin', '543'), + ('kshell', '544'), + ('krcmd', '544'), + ('new-rwho', '550'), + ('new-who', '550'), + ('remotefs', '556'), + ('rfs', '556'), + ('rfs_server', '556'), + ('rmonitor', '560'), + ('rmonitord', '560'), + ('monitor', '561'), + ('ldaps', '636'), + ('sldap', '636'), + ('doom', '666'), + ('kerberos-adm', '749'), + ('kerberos-iv', '750'), + ('kpop', '1109'), + ('phone', '1167'), + ('ms-sql-s', '1433'), + ('ms-sql-m', '1434'), + ('wins', '1512'), + ('ingreslock', '1524'), + ('ingres', '1524'), + ('l2tp', '1701'), + ('pptp', '1723'), + ('radius', '1812'), + ('radacct', '1813'), + ('nfsd', '2049'), + ('nfs', '2049'), + ('knetd', '2053'), + ('gds_db', '3050'), + ('man', '9535') + ); + +{function IN6_IS_ADDR_UNSPECIFIED(const a: PInAddr6): boolean; +begin + Result := ((a^.s_un_dw.s_dw1 = 0) and (a^.s_un_dw.s_dw2 = 0) and + (a^.s_un_dw.s_dw3 = 0) and (a^.s_un_dw.s_dw4 = 0)); +end; + +function IN6_IS_ADDR_LOOPBACK(const a: PInAddr6): boolean; +begin + Result := ((a^.s_un_dw.s_dw1 = 0) and (a^.s_un_dw.s_dw2 = 0) and + (a^.s_un_dw.s_dw3 = 0) and + (a^.s_un_b.s_b13 = char(0)) and (a^.s_un_b.s_b14 = char(0)) and + (a^.s_un_b.s_b15 = char(0)) and (a^.s_un_b.s_b16 = char(1))); +end; + +function IN6_IS_ADDR_LINKLOCAL(const a: PInAddr6): boolean; +begin + Result := ((a^.s_un_b.s_b1 = u_char($FE)) and (a^.s_un_b.s_b2 = u_char($80))); +end; + +function IN6_IS_ADDR_SITELOCAL(const a: PInAddr6): boolean; +begin + Result := ((a^.s_un_b.s_b1 = u_char($FE)) and (a^.s_un_b.s_b2 = u_char($C0))); +end; + +function IN6_IS_ADDR_MULTICAST(const a: PInAddr6): boolean; +begin + Result := (a^.s_un_b.s_b1 = char($FF)); +end; + +function IN6_ADDR_EQUAL(const a: PInAddr6; const b: PInAddr6): boolean; +begin + Result := (CompareMem( a, b, sizeof(TInAddr6))); +end; + +procedure SET_IN6_IF_ADDR_ANY (const a: PInAddr6); +begin + FillChar(a^, sizeof(TInAddr6), 0); +end; + +procedure SET_LOOPBACK_ADDR6 (const a: PInAddr6); +begin + FillChar(a^, sizeof(TInAddr6), 0); + a^.s_un_b.s_b16 := char(1); +end; +} + +{=============================================================================} + +procedure NullErr; +begin + WSALastError := 0; + WSALastErrorDesc := ''; +end; + +procedure GetErrCode(E: System.Exception); +var + SE: System.Net.Sockets.SocketException; +begin + if E is System.Net.Sockets.SocketException then + begin + SE := E as System.Net.Sockets.SocketException; + WSALastError := SE.ErrorCode; + WSALastErrorDesc := SE.Message; + end +end; + +function WSAStartup(wVersionRequired: Word; var WSData: TWSAData): Integer; +begin + NullErr; + with WSData do + begin + wVersion := wVersionRequired; + wHighVersion := $202; + szDescription := 'Synsock - Synapse Platform Independent Socket Layer'; + szSystemStatus := 'Running on .NET'; + iMaxSockets := 32768; + iMaxUdpDg := 8192; + end; + Result := 0; +end; + +function WSACleanup: Integer; +begin + NullErr; + Result := 0; +end; + +function WSAGetLastError: Integer; +begin + Result := WSALastError; +end; + +function WSAGetLastErrorDesc: String; +begin + Result := WSALastErrorDesc; +end; + +function GetHostName: string; +begin + Result := System.Net.DNS.GetHostName; +end; + +function Shutdown(s: TSocket; how: Integer): Integer; +begin + Result := 0; + NullErr; + try + s.ShutDown(SocketShutdown(how)); + except + on e: System.Net.Sockets.SocketException do + begin + GetErrCode(e); + Result := integer(SOCKET_ERROR); + end; + end; +end; + +function SetSockOpt(s: TSocket; level, optname: Integer; optval: Tmemory; + optlen: Integer): Integer; +begin + Result := 0; + NullErr; + try + s.SetSocketOption(SocketOptionLevel(level), SocketOptionName(optname), optval); + except + on e: System.Net.Sockets.SocketException do + begin + GetErrCode(e); + Result := integer(SOCKET_ERROR); + end; + end; +end; + +function SetSockOptObj(s: TSocket; level, optname: Integer; optval: TObject): Integer; +begin + Result := 0; + NullErr; + try + s.SetSocketOption(SocketOptionLevel(level), SocketOptionName(optname), optval); + except + on e: System.Net.Sockets.SocketException do + begin + GetErrCode(e); + Result := integer(SOCKET_ERROR); + end; + end; +end; + +function GetSockOpt(s: TSocket; level, optname: Integer; optval: Tmemory; + var optlen: Integer): Integer; +begin + Result := 0; + NullErr; + try + s.GetSocketOption(SocketOptionLevel(level), SocketOptionName(optname), optval); + except + on e: System.Net.Sockets.SocketException do + begin + GetErrCode(e); + Result := integer(SOCKET_ERROR); + end; + end; +end; + +function SendTo(s: TSocket; Buf: TMemory; len, flags: Integer; addrto: TVarSin): Integer; +//function SendTo(s: TSocket; const Buf; len, flags: Integer; addrto: TVarSin): Integer; +begin + NullErr; + try + result := s.SendTo(Buf, len, SocketFlags(flags), addrto); + except + on e: System.Net.Sockets.SocketException do + begin + GetErrCode(e); + Result := integer(SOCKET_ERROR); + end; + end; +end; + +function Send(s: TSocket; Buf: TMemory; len, flags: Integer): Integer; +//function Send(s: TSocket; const Buf; len, flags: Integer): Integer; +begin + NullErr; + try + result := s.Send(Buf, len, SocketFlags(flags)); + except + on e: System.Net.Sockets.SocketException do + begin + GetErrCode(e); + Result := integer(SOCKET_ERROR); + end; + end; +end; + +function Recv(s: TSocket; Buf: TMemory; len, flags: Integer): Integer; +//function Recv(s: TSocket; var Buf; len, flags: Integer): Integer; +begin + NullErr; + try + result := s.Receive(Buf, len, SocketFlags(flags)); + except + on e: System.Net.Sockets.SocketException do + begin + GetErrCode(e); + Result := integer(SOCKET_ERROR); + end; + end; +end; + +//function RecvFrom(s: TSocket; var Buf; len, flags: Integer; from: PSockAddr; +// var fromlen: Integer): Integer; +function RecvFrom(s: TSocket; Buf: TMemory; len, flags: Integer; var from: TVarSin): Integer; +//function RecvFrom(s: TSocket; var Buf; len, flags: Integer; from: TVarSin): Integer; +var + EP: EndPoint; +begin + NullErr; + try + EP := from; + result := s.ReceiveFrom(Buf, len, SocketFlags(flags), EndPoint(EP)); + from := EP as IPEndPoint; + except + on e: System.Net.Sockets.SocketException do + begin + GetErrCode(e); + Result := integer(SOCKET_ERROR); + end; + end; +end; + +function ntohs(netshort: u_short): u_short; +begin + Result := IPAddress.NetworkToHostOrder(NetShort); +end; + +function ntohl(netlong: u_long): u_long; +begin + Result := IPAddress.NetworkToHostOrder(NetLong); +end; + +function Listen(s: TSocket; backlog: Integer): Integer; +begin + Result := 0; + NullErr; + try + s.Listen(backlog); + except + on e: System.Net.Sockets.SocketException do + begin + GetErrCode(e); + Result := integer(SOCKET_ERROR); + end; + end; +end; + +function IoctlSocket(s: TSocket; cmd: DWORD; var arg: integer): Integer; +var + inv, outv: TMemory; +begin + Result := 0; + NullErr; + try + if cmd = DWORD(FIONBIO) then + s.Blocking := arg = 0 + else + begin + inv := BitConverter.GetBytes(arg); + outv := BitConverter.GetBytes(integer(0)); + s.IOControl(cmd, inv, outv); + arg := BitConverter.ToInt32(outv, 0); + end; + except + on e: System.Net.Sockets.SocketException do + begin + GetErrCode(e); + Result := integer(SOCKET_ERROR); + end; + end; +end; + +function htons(hostshort: u_short): u_short; +begin + Result := IPAddress.HostToNetworkOrder(Hostshort); +end; + +function htonl(hostlong: u_long): u_long; +begin + Result := IPAddress.HostToNetworkOrder(HostLong); +end; + +//function GetSockName(s: TSocket; name: PSockAddr; var namelen: Integer): Integer; +function GetSockName(s: TSocket; var name: TVarSin): Integer; +begin + Result := 0; + NullErr; + try + Name := s.localEndPoint as IPEndpoint; + except + on e: System.Net.Sockets.SocketException do + begin + GetErrCode(e); + Result := integer(SOCKET_ERROR); + end; + end; +end; + +//function GetPeerName(s: TSocket; name: PSockAddr; var namelen: Integer): Integer; +function GetPeerName(s: TSocket; var name: TVarSin): Integer; +begin + Result := 0; + NullErr; + try + Name := s.RemoteEndPoint as IPEndpoint; + except + on e: System.Net.Sockets.SocketException do + begin + GetErrCode(e); + Result := integer(SOCKET_ERROR); + end; + end; +end; + +//function Connect(s: TSocket; name: PSockAddr; namelen: Integer): Integer; +function Connect(s: TSocket; const name: TVarSin): Integer; +begin + Result := 0; + NullErr; + try + s.Connect(name); + except + on e: System.Net.Sockets.SocketException do + begin + GetErrCode(e); + Result := integer(SOCKET_ERROR); + end; + end; +end; + +function CloseSocket(s: TSocket): Integer; +begin + Result := 0; + NullErr; + try + s.Close; + except + on e: System.Net.Sockets.SocketException do + begin + Result := integer(SOCKET_ERROR); + end; + end; +end; + +//function Bind(s: TSocket; addr: PSockAddr; namelen: Integer): Integer; +function Bind(s: TSocket; const addr: TVarSin): Integer; +begin + Result := 0; + NullErr; + try + s.Bind(addr); + except + on e: System.Net.Sockets.SocketException do + begin + GetErrCode(e); + Result := integer(SOCKET_ERROR); + end; + end; +end; + +//function Accept(s: TSocket; addr: PSockAddr; var addrlen: Integer): TSocket; +function Accept(s: TSocket; var addr: TVarSin): TSocket; +begin + NullErr; + try + result := s.Accept(); + except + on e: System.Net.Sockets.SocketException do + begin + GetErrCode(e); + Result := nil; + end; + end; +end; + +function Socket(af, Struc, Protocol: Integer): TSocket; +begin + NullErr; + try + result := TSocket.Create(AddressFamily(af), SocketType(Struc), ProtocolType(Protocol)); + except + on e: System.Net.Sockets.SocketException do + begin + GetErrCode(e); + Result := nil; + end; + end; +end; + +{=============================================================================} +function GetPortService(value: string): integer; +var + n: integer; +begin + Result := 0; + value := Lowercase(value); + for n := 0 to High(Services) do + if services[n, 0] = value then + begin + Result := strtointdef(services[n, 1], 0); + break; + end; + if Result = 0 then + Result := StrToIntDef(value, 0); +end; + +{=============================================================================} +function IsNewApi(Family: TAddrFamily): Boolean; +begin + Result := true; +end; + +function SetVarSin(var Sin: TVarSin; IP, Port: string; Family: TAddrFamily; SockProtocol, SockType: integer; PreferIP4: Boolean): integer; +var + IPs: array of IPAddress; + n: integer; + ip4, ip6: string; + sip: string; +begin + sip := ''; + ip4 := ''; + ip6 := ''; + IPs := Dns.Resolve(IP).AddressList; + for n :=low(IPs) to high(IPs) do begin + if (ip4 = '') and (IPs[n].AddressFamily = AF_INET) then + ip4 := IPs[n].toString; + if (ip6 = '') and (IPs[n].AddressFamily = AF_INET6) then + ip6 := IPs[n].toString; + if (ip4 <> '') and (ip6 <> '') then + break; + end; + case Family of + AF_UNSPEC: + begin + if (ip4 <> '') and (ip6 <> '') then + begin + if PreferIP4 then + sip := ip4 + else + Sip := ip6; + end + else + begin + sip := ip4; + if (ip6 <> '') then + sip := ip6; + end; + end; + AF_INET: + sip := ip4; + AF_INET6: + sip := ip6; + end; + sin := TVarSin.Create(IPAddress.Parse(sip), GetPortService(Port)); +end; + +function GetSinIP(Sin: TVarSin): string; +begin + Result := Sin.Address.ToString; +end; + +function GetSinPort(Sin: TVarSin): Integer; +begin + Result := Sin.Port; +end; + +procedure ResolveNameToIP(Name: string; Family: TAddrFamily; SockProtocol, SockType: integer; const IPList: TStrings); +var + IPs :array of IPAddress; + n: integer; +begin + IPList.Clear; + IPs := Dns.Resolve(Name).AddressList; + for n := low(IPs) to high(IPs) do + begin + if not(((Family = AF_INET6) and (IPs[n].AddressFamily = AF_INET)) + or ((Family = AF_INET) and (IPs[n].AddressFamily = AF_INET6))) then + begin + IPList.Add(IPs[n].toString); + end; + end; +end; + +function ResolvePort(Port: string; Family: TAddrFamily; SockProtocol, SockType: integer): Word; +var + n: integer; +begin + Result := StrToIntDef(port, 0); + if Result = 0 then + begin + port := Lowercase(port); + for n := 0 to High(Services) do + if services[n, 0] = port then + begin + Result := strtointdef(services[n, 1], 0); + break; + end; + end; +end; + +function ResolveIPToName(IP: string; Family: TAddrFamily; SockProtocol, SockType: integer): string; +begin + Result := Dns.GetHostByAddress(IP).HostName; +end; + + +{=============================================================================} +function InitSocketInterface(stack: string): Boolean; +begin + Result := True; +end; + +function DestroySocketInterface: Boolean; +begin + NullErr; + Result := True; +end; + +initialization +begin + SynSockCS := SyncObjs.TCriticalSection.Create; +// SET_IN6_IF_ADDR_ANY (@in6addr_any); +// SET_LOOPBACK_ADDR6 (@in6addr_loopback); +end; + +finalization +begin + NullErr; + SynSockCS.Free; +end; + +{$ENDIF} diff --git a/synapse/ssfpc.inc b/synapse/ssfpc.inc new file mode 100644 index 0000000..10a434c --- /dev/null +++ b/synapse/ssfpc.inc @@ -0,0 +1,909 @@ +{==============================================================================| +| Project : Ararat Synapse | 001.001.004 | +|==============================================================================| +| Content: Socket Independent Platform Layer - FreePascal definition include | +|==============================================================================| +| Copyright (c)2006-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)2006-2011. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +{:@exclude} + +{$IFDEF FPC} +{For FreePascal 2.x.x} + +//{$DEFINE FORCEOLDAPI} +{Note about define FORCEOLDAPI: +If you activate this compiler directive, then is allways used old socket API +for name resolution. If you leave this directive inactive, then the new API +is used, when running system allows it. + +For IPv6 support you must have new API! +} + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$H+} + +{$ifdef FreeBSD} +{$DEFINE SOCK_HAS_SINLEN} // BSD definition of scoketaddr +{$endif} +{$ifdef darwin} +{$DEFINE SOCK_HAS_SINLEN} // BSD definition of scoketaddr +{$endif} + +interface + +uses + SyncObjs, SysUtils, Classes, + synafpc, BaseUnix, Unix, termio, sockets, netdb; + +function InitSocketInterface(stack: string): Boolean; +function DestroySocketInterface: Boolean; + +const + DLLStackName = ''; + WinsockLevel = $0202; + + cLocalHost = '127.0.0.1'; + cAnyHost = '0.0.0.0'; + c6AnyHost = '::0'; + c6Localhost = '::1'; + cLocalHostStr = 'localhost'; + +type + TSocket = longint; + TAddrFamily = integer; + + TMemory = pointer; + + +type + TFDSet = Baseunix.TFDSet; + PFDSet = ^TFDSet; + Ptimeval = Baseunix.ptimeval; + Ttimeval = Baseunix.ttimeval; + +const + FIONREAD = termio.FIONREAD; + FIONBIO = termio.FIONBIO; + FIOASYNC = termio.FIOASYNC; + +const + IPPROTO_IP = 0; { Dummy } + IPPROTO_ICMP = 1; { Internet Control Message Protocol } + IPPROTO_IGMP = 2; { Internet Group Management Protocol} + IPPROTO_TCP = 6; { TCP } + IPPROTO_UDP = 17; { User Datagram Protocol } + IPPROTO_IPV6 = 41; + IPPROTO_ICMPV6 = 58; + IPPROTO_RM = 113; + + IPPROTO_RAW = 255; + IPPROTO_MAX = 256; + +type + PInAddr = ^TInAddr; + TInAddr = sockets.in_addr; + + PSockAddrIn = ^TSockAddrIn; + TSockAddrIn = sockets.TInetSockAddr; + + + TIP_mreq = record + imr_multiaddr: TInAddr; // IP multicast address of group + imr_interface: TInAddr; // local IP address of interface + end; + + + PInAddr6 = ^TInAddr6; + TInAddr6 = sockets.Tin6_addr; + + PSockAddrIn6 = ^TSockAddrIn6; + TSockAddrIn6 = sockets.TInetSockAddr6; + + + TIPv6_mreq = record + ipv6mr_multiaddr: TInAddr6; // IPv6 multicast address. + ipv6mr_interface: integer; // Interface index. + end; + +const + INADDR_ANY = $00000000; + INADDR_LOOPBACK = $7F000001; + INADDR_BROADCAST = $FFFFFFFF; + INADDR_NONE = $FFFFFFFF; + ADDR_ANY = INADDR_ANY; + INVALID_SOCKET = TSocket(NOT(0)); + SOCKET_ERROR = -1; + +Const + IP_TOS = sockets.IP_TOS; { int; IP type of service and precedence. } + IP_TTL = sockets.IP_TTL; { int; IP time to live. } + IP_HDRINCL = sockets.IP_HDRINCL; { int; Header is included with data. } + IP_OPTIONS = sockets.IP_OPTIONS; { ip_opts; IP per-packet options. } +// IP_ROUTER_ALERT = sockets.IP_ROUTER_ALERT; { bool } + IP_RECVOPTS = sockets.IP_RECVOPTS; { bool } + IP_RETOPTS = sockets.IP_RETOPTS; { bool } +// IP_PKTINFO = sockets.IP_PKTINFO; { bool } +// IP_PKTOPTIONS = sockets.IP_PKTOPTIONS; +// IP_PMTUDISC = sockets.IP_PMTUDISC; { obsolete name? } +// IP_MTU_DISCOVER = sockets.IP_MTU_DISCOVER; { int; see below } +// IP_RECVERR = sockets.IP_RECVERR; { bool } +// IP_RECVTTL = sockets.IP_RECVTTL; { bool } +// IP_RECVTOS = sockets.IP_RECVTOS; { bool } + IP_MULTICAST_IF = sockets.IP_MULTICAST_IF; { in_addr; set/get IP multicast i/f } + IP_MULTICAST_TTL = sockets.IP_MULTICAST_TTL; { u_char; set/get IP multicast ttl } + IP_MULTICAST_LOOP = sockets.IP_MULTICAST_LOOP; { i_char; set/get IP multicast loopback } + IP_ADD_MEMBERSHIP = sockets.IP_ADD_MEMBERSHIP; { ip_mreq; add an IP group membership } + IP_DROP_MEMBERSHIP = sockets.IP_DROP_MEMBERSHIP; { ip_mreq; drop an IP group membership } + + SOL_SOCKET = sockets.SOL_SOCKET; + + SO_DEBUG = sockets.SO_DEBUG; + SO_REUSEADDR = sockets.SO_REUSEADDR; + SO_TYPE = sockets.SO_TYPE; + SO_ERROR = sockets.SO_ERROR; + SO_DONTROUTE = sockets.SO_DONTROUTE; + SO_BROADCAST = sockets.SO_BROADCAST; + SO_SNDBUF = sockets.SO_SNDBUF; + SO_RCVBUF = sockets.SO_RCVBUF; + SO_KEEPALIVE = sockets.SO_KEEPALIVE; + SO_OOBINLINE = sockets.SO_OOBINLINE; +// SO_NO_CHECK = sockets.SO_NO_CHECK; +// SO_PRIORITY = sockets.SO_PRIORITY; + SO_LINGER = sockets.SO_LINGER; +// SO_BSDCOMPAT = sockets.SO_BSDCOMPAT; +// SO_REUSEPORT = sockets.SO_REUSEPORT; +// SO_PASSCRED = sockets.SO_PASSCRED; +// SO_PEERCRED = sockets.SO_PEERCRED; + SO_RCVLOWAT = sockets.SO_RCVLOWAT; + SO_SNDLOWAT = sockets.SO_SNDLOWAT; + SO_RCVTIMEO = sockets.SO_RCVTIMEO; + SO_SNDTIMEO = sockets.SO_SNDTIMEO; +{ Security levels - as per NRL IPv6 - don't actually do anything } +// SO_SECURITY_AUTHENTICATION = sockets.SO_SECURITY_AUTHENTICATION; +// SO_SECURITY_ENCRYPTION_TRANSPORT = sockets.SO_SECURITY_ENCRYPTION_TRANSPORT; +// SO_SECURITY_ENCRYPTION_NETWORK = sockets.SO_SECURITY_ENCRYPTION_NETWORK; +// SO_BINDTODEVICE = sockets.SO_BINDTODEVICE; +{ Socket filtering } +// SO_ATTACH_FILTER = sockets.SO_ATTACH_FILTER; +// SO_DETACH_FILTER = sockets.SO_DETACH_FILTER; + + SOMAXCONN = 1024; + + IPV6_UNICAST_HOPS = sockets.IPV6_UNICAST_HOPS; + IPV6_MULTICAST_IF = sockets.IPV6_MULTICAST_IF; + IPV6_MULTICAST_HOPS = sockets.IPV6_MULTICAST_HOPS; + IPV6_MULTICAST_LOOP = sockets.IPV6_MULTICAST_LOOP; + IPV6_JOIN_GROUP = sockets.IPV6_JOIN_GROUP; + IPV6_LEAVE_GROUP = sockets.IPV6_LEAVE_GROUP; + +const + SOCK_STREAM = 1; { stream socket } + SOCK_DGRAM = 2; { datagram socket } + SOCK_RAW = 3; { raw-protocol interface } + SOCK_RDM = 4; { reliably-delivered message } + SOCK_SEQPACKET = 5; { sequenced packet stream } + +{ TCP options. } + TCP_NODELAY = $0001; + +{ Address families. } + + AF_UNSPEC = 0; { unspecified } + AF_INET = 2; { internetwork: UDP, TCP, etc. } + AF_INET6 = 10; { Internetwork Version 6 } + AF_MAX = 24; + +{ Protocol families, same as address families for now. } + PF_UNSPEC = AF_UNSPEC; + PF_INET = AF_INET; + PF_INET6 = AF_INET6; + PF_MAX = AF_MAX; + +type +{ Structure used for manipulating linger option. } + PLinger = ^TLinger; + TLinger = packed record + l_onoff: integer; + l_linger: integer; + end; + +const + + MSG_OOB = sockets.MSG_OOB; // Process out-of-band data. + MSG_PEEK = sockets.MSG_PEEK; // Peek at incoming messages. + {$ifdef DARWIN} + MSG_NOSIGNAL = $20000; // Do not generate SIGPIPE. + // Works under MAC OS X, but is undocumented, + // So FPC doesn't include it + {$else} + MSG_NOSIGNAL = sockets.MSG_NOSIGNAL; // Do not generate SIGPIPE. + {$endif} + +const + WSAEINTR = ESysEINTR; + WSAEBADF = ESysEBADF; + WSAEACCES = ESysEACCES; + WSAEFAULT = ESysEFAULT; + WSAEINVAL = ESysEINVAL; + WSAEMFILE = ESysEMFILE; + WSAEWOULDBLOCK = ESysEWOULDBLOCK; + WSAEINPROGRESS = ESysEINPROGRESS; + WSAEALREADY = ESysEALREADY; + WSAENOTSOCK = ESysENOTSOCK; + WSAEDESTADDRREQ = ESysEDESTADDRREQ; + WSAEMSGSIZE = ESysEMSGSIZE; + WSAEPROTOTYPE = ESysEPROTOTYPE; + WSAENOPROTOOPT = ESysENOPROTOOPT; + WSAEPROTONOSUPPORT = ESysEPROTONOSUPPORT; + WSAESOCKTNOSUPPORT = ESysESOCKTNOSUPPORT; + WSAEOPNOTSUPP = ESysEOPNOTSUPP; + WSAEPFNOSUPPORT = ESysEPFNOSUPPORT; + WSAEAFNOSUPPORT = ESysEAFNOSUPPORT; + WSAEADDRINUSE = ESysEADDRINUSE; + WSAEADDRNOTAVAIL = ESysEADDRNOTAVAIL; + WSAENETDOWN = ESysENETDOWN; + WSAENETUNREACH = ESysENETUNREACH; + WSAENETRESET = ESysENETRESET; + WSAECONNABORTED = ESysECONNABORTED; + WSAECONNRESET = ESysECONNRESET; + WSAENOBUFS = ESysENOBUFS; + WSAEISCONN = ESysEISCONN; + WSAENOTCONN = ESysENOTCONN; + WSAESHUTDOWN = ESysESHUTDOWN; + WSAETOOMANYREFS = ESysETOOMANYREFS; + WSAETIMEDOUT = ESysETIMEDOUT; + WSAECONNREFUSED = ESysECONNREFUSED; + WSAELOOP = ESysELOOP; + WSAENAMETOOLONG = ESysENAMETOOLONG; + WSAEHOSTDOWN = ESysEHOSTDOWN; + WSAEHOSTUNREACH = ESysEHOSTUNREACH; + WSAENOTEMPTY = ESysENOTEMPTY; + WSAEPROCLIM = -1; + WSAEUSERS = ESysEUSERS; + WSAEDQUOT = ESysEDQUOT; + WSAESTALE = ESysESTALE; + WSAEREMOTE = ESysEREMOTE; + WSASYSNOTREADY = -2; + WSAVERNOTSUPPORTED = -3; + WSANOTINITIALISED = -4; + WSAEDISCON = -5; + WSAHOST_NOT_FOUND = 1; + WSATRY_AGAIN = 2; + WSANO_RECOVERY = 3; + WSANO_DATA = -6; + +const + WSADESCRIPTION_LEN = 256; + WSASYS_STATUS_LEN = 128; +type + PWSAData = ^TWSAData; + TWSAData = packed record + wVersion: Word; + wHighVersion: Word; + szDescription: array[0..WSADESCRIPTION_LEN] of Char; + szSystemStatus: array[0..WSASYS_STATUS_LEN] of Char; + iMaxSockets: Word; + iMaxUdpDg: Word; + lpVendorInfo: PChar; + end; + + function IN6_IS_ADDR_UNSPECIFIED(const a: PInAddr6): boolean; + function IN6_IS_ADDR_LOOPBACK(const a: PInAddr6): boolean; + function IN6_IS_ADDR_LINKLOCAL(const a: PInAddr6): boolean; + function IN6_IS_ADDR_SITELOCAL(const a: PInAddr6): boolean; + function IN6_IS_ADDR_MULTICAST(const a: PInAddr6): boolean; + function IN6_ADDR_EQUAL(const a: PInAddr6; const b: PInAddr6):boolean; + procedure SET_IN6_IF_ADDR_ANY (const a: PInAddr6); + procedure SET_LOOPBACK_ADDR6 (const a: PInAddr6); + +var + in6addr_any, in6addr_loopback : TInAddr6; + +procedure FD_CLR(Socket: TSocket; var FDSet: TFDSet); +function FD_ISSET(Socket: TSocket; var FDSet: TFDSet): Boolean; +procedure FD_SET(Socket: TSocket; var FDSet: TFDSet); +procedure FD_ZERO(var FDSet: TFDSet); + +{=============================================================================} + +var + SynSockCS: SyncObjs.TCriticalSection; + SockEnhancedApi: Boolean; + SockWship6Api: Boolean; + +type + TVarSin = packed record + {$ifdef SOCK_HAS_SINLEN} + sin_len : cuchar; + {$endif} + case integer of + 0: (AddressFamily: sa_family_t); + 1: ( + case sin_family: sa_family_t of + AF_INET: (sin_port: word; + sin_addr: TInAddr; + sin_zero: array[0..7] of Char); + AF_INET6: (sin6_port: word; + sin6_flowinfo: longword; + sin6_addr: TInAddr6; + sin6_scope_id: longword); + ); + end; + +function SizeOfVarSin(sin: TVarSin): integer; + + function WSAStartup(wVersionRequired: Word; var WSData: TWSAData): Integer; + function WSACleanup: Integer; + function WSAGetLastError: Integer; + function GetHostName: string; + function Shutdown(s: TSocket; how: Integer): Integer; + function SetSockOpt(s: TSocket; level, optname: Integer; optval: TMemory; + optlen: Integer): Integer; + function GetSockOpt(s: TSocket; level, optname: Integer; optval: TMemory; + var optlen: Integer): Integer; + function Send(s: TSocket; Buf: TMemory; len, flags: Integer): Integer; + function Recv(s: TSocket; Buf: TMemory; len, flags: Integer): Integer; + function SendTo(s: TSocket; Buf: TMemory; len, flags: Integer; addrto: TVarSin): Integer; + function RecvFrom(s: TSocket; Buf: TMemory; len, flags: Integer; var from: TVarSin): Integer; + function ntohs(netshort: word): word; + function ntohl(netlong: longword): longword; + function Listen(s: TSocket; backlog: Integer): Integer; + function IoctlSocket(s: TSocket; cmd: DWORD; var arg: integer): Integer; + function htons(hostshort: word): word; + function htonl(hostlong: longword): longword; + function GetSockName(s: TSocket; var name: TVarSin): Integer; + function GetPeerName(s: TSocket; var name: TVarSin): Integer; + function Connect(s: TSocket; const name: TVarSin): Integer; + function CloseSocket(s: TSocket): Integer; + function Bind(s: TSocket; const addr: TVarSin): Integer; + function Accept(s: TSocket; var addr: TVarSin): TSocket; + function Socket(af, Struc, Protocol: Integer): TSocket; + function Select(nfds: Integer; readfds, writefds, exceptfds: PFDSet; + timeout: PTimeVal): Longint; + +function IsNewApi(Family: integer): Boolean; +function SetVarSin(var Sin: TVarSin; IP, Port: string; Family, SockProtocol, SockType: integer; PreferIP4: Boolean): integer; +function GetSinIP(Sin: TVarSin): string; +function GetSinPort(Sin: TVarSin): Integer; +procedure ResolveNameToIP(Name: string; Family, SockProtocol, SockType: integer; const IPList: TStrings); +function ResolveIPToName(IP: string; Family, SockProtocol, SockType: integer): string; +function ResolvePort(Port: string; Family, SockProtocol, SockType: integer): Word; + + +{==============================================================================} +implementation + + +function IN6_IS_ADDR_UNSPECIFIED(const a: PInAddr6): boolean; +begin + Result := ((a^.u6_addr32[0] = 0) and (a^.u6_addr32[1] = 0) and + (a^.u6_addr32[2] = 0) and (a^.u6_addr32[3] = 0)); +end; + +function IN6_IS_ADDR_LOOPBACK(const a: PInAddr6): boolean; +begin + Result := ((a^.u6_addr32[0] = 0) and (a^.u6_addr32[1] = 0) and + (a^.u6_addr32[2] = 0) and + (a^.u6_addr8[12] = 0) and (a^.u6_addr8[13] = 0) and + (a^.u6_addr8[14] = 0) and (a^.u6_addr8[15] = 1)); +end; + +function IN6_IS_ADDR_LINKLOCAL(const a: PInAddr6): boolean; +begin + Result := ((a^.u6_addr8[0] = $FE) and (a^.u6_addr8[1] = $80)); +end; + +function IN6_IS_ADDR_SITELOCAL(const a: PInAddr6): boolean; +begin + Result := ((a^.u6_addr8[0] = $FE) and (a^.u6_addr8[1] = $C0)); +end; + +function IN6_IS_ADDR_MULTICAST(const a: PInAddr6): boolean; +begin + Result := (a^.u6_addr8[0] = $FF); +end; + +function IN6_ADDR_EQUAL(const a: PInAddr6; const b: PInAddr6): boolean; +begin + Result := (CompareMem( a, b, sizeof(TInAddr6))); +end; + +procedure SET_IN6_IF_ADDR_ANY (const a: PInAddr6); +begin + FillChar(a^, sizeof(TInAddr6), 0); +end; + +procedure SET_LOOPBACK_ADDR6 (const a: PInAddr6); +begin + FillChar(a^, sizeof(TInAddr6), 0); + a^.u6_addr8[15] := 1; +end; + +{=============================================================================} + +function WSAStartup(wVersionRequired: Word; var WSData: TWSAData): Integer; +begin + with WSData do + begin + wVersion := wVersionRequired; + wHighVersion := $202; + szDescription := 'Synsock - Synapse Platform Independent Socket Layer'; + szSystemStatus := 'Running on Unix/Linux by FreePascal'; + iMaxSockets := 32768; + iMaxUdpDg := 8192; + end; + Result := 0; +end; + +function WSACleanup: Integer; +begin + Result := 0; +end; + +function WSAGetLastError: Integer; +begin + Result := fpGetErrno; +end; + +function FD_ISSET(Socket: TSocket; var fdset: TFDSet): Boolean; +begin + Result := fpFD_ISSET(socket, fdset) <> 0; +end; + +procedure FD_SET(Socket: TSocket; var fdset: TFDSet); +begin + fpFD_SET(Socket, fdset); +end; + +procedure FD_CLR(Socket: TSocket; var fdset: TFDSet); +begin + fpFD_CLR(Socket, fdset); +end; + +procedure FD_ZERO(var fdset: TFDSet); +begin + fpFD_ZERO(fdset); +end; + +{=============================================================================} + +function SizeOfVarSin(sin: TVarSin): integer; +begin + case sin.sin_family of + AF_INET: + Result := SizeOf(TSockAddrIn); + AF_INET6: + Result := SizeOf(TSockAddrIn6); + else + Result := 0; + end; +end; + +{=============================================================================} + +function Bind(s: TSocket; const addr: TVarSin): Integer; +begin + if fpBind(s, @addr, SizeOfVarSin(addr)) = 0 then + Result := 0 + else + Result := SOCKET_ERROR; +end; + +function Connect(s: TSocket; const name: TVarSin): Integer; +begin + if fpConnect(s, @name, SizeOfVarSin(name)) = 0 then + Result := 0 + else + Result := SOCKET_ERROR; +end; + +function GetSockName(s: TSocket; var name: TVarSin): Integer; +var + len: integer; +begin + len := SizeOf(name); + FillChar(name, len, 0); + Result := fpGetSockName(s, @name, @Len); +end; + +function GetPeerName(s: TSocket; var name: TVarSin): Integer; +var + len: integer; +begin + len := SizeOf(name); + FillChar(name, len, 0); + Result := fpGetPeerName(s, @name, @Len); +end; + +function GetHostName: string; +begin + Result := unix.GetHostName; +end; + +function Send(s: TSocket; Buf: TMemory; len, flags: Integer): Integer; +begin + Result := fpSend(s, pointer(Buf), len, flags); +end; + +function Recv(s: TSocket; Buf: TMemory; len, flags: Integer): Integer; +begin + Result := fpRecv(s, pointer(Buf), len, flags); +end; + +function SendTo(s: TSocket; Buf: TMemory; len, flags: Integer; addrto: TVarSin): Integer; +begin + Result := fpSendTo(s, pointer(Buf), len, flags, @addrto, SizeOfVarSin(addrto)); +end; + +function RecvFrom(s: TSocket; Buf: TMemory; len, flags: Integer; var from: TVarSin): Integer; +var + x: integer; +begin + x := SizeOf(from); + Result := fpRecvFrom(s, pointer(Buf), len, flags, @from, @x); +end; + +function Accept(s: TSocket; var addr: TVarSin): TSocket; +var + x: integer; +begin + x := SizeOf(addr); + Result := fpAccept(s, @addr, @x); +end; + +function Shutdown(s: TSocket; how: Integer): Integer; +begin + Result := fpShutdown(s, how); +end; + +function SetSockOpt(s: TSocket; level, optname: Integer; optval: Tmemory; + optlen: Integer): Integer; +begin + Result := fpsetsockopt(s, level, optname, pointer(optval), optlen); +end; + +function GetSockOpt(s: TSocket; level, optname: Integer; optval: Tmemory; + var optlen: Integer): Integer; +begin + Result := fpgetsockopt(s, level, optname, pointer(optval), @optlen); +end; + +function ntohs(netshort: word): word; +begin + Result := sockets.ntohs(NetShort); +end; + +function ntohl(netlong: longword): longword; +begin + Result := sockets.ntohl(NetLong); +end; + +function Listen(s: TSocket; backlog: Integer): Integer; +begin + if fpListen(s, backlog) = 0 then + Result := 0 + else + Result := SOCKET_ERROR; +end; + +function IoctlSocket(s: TSocket; cmd: DWORD; var arg: integer): Integer; +begin + Result := fpIoctl(s, cmd, @arg); +end; + +function htons(hostshort: word): word; +begin + Result := sockets.htons(Hostshort); +end; + +function htonl(hostlong: longword): longword; +begin + Result := sockets.htonl(HostLong); +end; + +function CloseSocket(s: TSocket): Integer; +begin + Result := sockets.CloseSocket(s); +end; + +function Socket(af, Struc, Protocol: Integer): TSocket; +begin + Result := fpSocket(af, struc, protocol); +end; + +function Select(nfds: Integer; readfds, writefds, exceptfds: PFDSet; + timeout: PTimeVal): Longint; +begin + Result := fpSelect(nfds, readfds, writefds, exceptfds, timeout); +end; + +{=============================================================================} +function IsNewApi(Family: integer): Boolean; +begin + Result := SockEnhancedApi; + if not Result then + Result := (Family = AF_INET6) and SockWship6Api; +end; + +function SetVarSin(var Sin: TVarSin; IP, Port: string; Family, SockProtocol, SockType: integer; PreferIP4: Boolean): integer; +var + TwoPass: boolean; + f1, f2: integer; + + function GetAddr(f:integer): integer; + var + a4: array [1..1] of in_addr; + a6: array [1..1] of Tin6_addr; + he: THostEntry; + begin + Result := WSAEPROTONOSUPPORT; + case f of + AF_INET: + begin + if IP = cAnyHost then + begin + Sin.sin_family := AF_INET; + Result := 0; + end + else + begin + if lowercase(IP) = cLocalHostStr then + a4[1].s_addr := htonl(INADDR_LOOPBACK) + else + begin + a4[1].s_addr := 0; + Result := WSAHOST_NOT_FOUND; + a4[1] := StrTonetAddr(IP); + if a4[1].s_addr = INADDR_ANY then + if GetHostByName(ip, he) then + a4[1]:=HostToNet(he.Addr) + else + Resolvename(ip, a4); + end; + if a4[1].s_addr <> INADDR_ANY then + begin + Sin.sin_family := AF_INET; + sin.sin_addr := a4[1]; + Result := 0; + end; + end; + end; + AF_INET6: + begin + if IP = c6AnyHost then + begin + Sin.sin_family := AF_INET6; + Result := 0; + end + else + begin + if lowercase(IP) = cLocalHostStr then + SET_LOOPBACK_ADDR6(@a6[1]) + else + begin + Result := WSAHOST_NOT_FOUND; + SET_IN6_IF_ADDR_ANY(@a6[1]); + a6[1] := StrTonetAddr6(IP); + if IN6_IS_ADDR_UNSPECIFIED(@a6[1]) then + Resolvename6(ip, a6); + end; + if not IN6_IS_ADDR_UNSPECIFIED(@a6[1]) then + begin + Sin.sin_family := AF_INET6; + sin.sin6_addr := a6[1]; + Result := 0; + end; + end; + end; + end; + end; +begin + Result := 0; + FillChar(Sin, Sizeof(Sin), 0); + Sin.sin_port := Resolveport(port, family, SockProtocol, SockType); + TwoPass := False; + if Family = AF_UNSPEC then + begin + if PreferIP4 then + begin + f1 := AF_INET; + f2 := AF_INET6; + TwoPass := True; + end + else + begin + f2 := AF_INET; + f1 := AF_INET6; + TwoPass := True; + end; + end + else + f1 := Family; + Result := GetAddr(f1); + if Result <> 0 then + if TwoPass then + Result := GetAddr(f2); +end; + +function GetSinIP(Sin: TVarSin): string; +begin + Result := ''; + case sin.AddressFamily of + AF_INET: + begin + result := NetAddrToStr(sin.sin_addr); + end; + AF_INET6: + begin + result := NetAddrToStr6(sin.sin6_addr); + end; + end; +end; + +function GetSinPort(Sin: TVarSin): Integer; +begin + if (Sin.sin_family = AF_INET6) then + Result := synsock.ntohs(Sin.sin6_port) + else + Result := synsock.ntohs(Sin.sin_port); +end; + +procedure ResolveNameToIP(Name: string; Family, SockProtocol, SockType: integer; const IPList: TStrings); +var + x, n: integer; + a4: array [1..255] of in_addr; + a6: array [1..255] of Tin6_addr; + he: THostEntry; +begin + IPList.Clear; + if (family = AF_INET) or (family = AF_UNSPEC) then + begin + if lowercase(name) = cLocalHostStr then + IpList.Add(cLocalHost) + else + begin + a4[1] := StrTonetAddr(name); + if a4[1].s_addr = INADDR_ANY then + if GetHostByName(name, he) then + begin + a4[1]:=HostToNet(he.Addr); + x := 1; + end + else + x := Resolvename(name, a4) + else + x := 1; + for n := 1 to x do + IpList.Add(netaddrToStr(a4[n])); + end; + end; + + if (family = AF_INET6) or (family = AF_UNSPEC) then + begin + if lowercase(name) = cLocalHostStr then + IpList.Add(c6LocalHost) + else + begin + a6[1] := StrTonetAddr6(name); + if IN6_IS_ADDR_UNSPECIFIED(@a6[1]) then + x := Resolvename6(name, a6) + else + x := 1; + for n := 1 to x do + IpList.Add(netaddrToStr6(a6[n])); + end; + end; + + if IPList.Count = 0 then + IPList.Add(cLocalHost); +end; + +function ResolvePort(Port: string; Family, SockProtocol, SockType: integer): Word; +var + ProtoEnt: TProtocolEntry; + ServEnt: TServiceEntry; +begin + Result := synsock.htons(StrToIntDef(Port, 0)); + if Result = 0 then + begin + ProtoEnt.Name := ''; + GetProtocolByNumber(SockProtocol, ProtoEnt); + ServEnt.port := 0; + GetServiceByName(Port, ProtoEnt.Name, ServEnt); + Result := ServEnt.port; + end; +end; + +function ResolveIPToName(IP: string; Family, SockProtocol, SockType: integer): string; +var + n: integer; + a4: array [1..1] of in_addr; + a6: array [1..1] of Tin6_addr; + a: array [1..1] of string; +begin + Result := IP; + a4[1] := StrToNetAddr(IP); + if a4[1].s_addr <> INADDR_ANY then + begin +//why ResolveAddress need address in HOST order? :-O + n := ResolveAddress(nettohost(a4[1]), a); + if n > 0 then + Result := a[1]; + end + else + begin + a6[1] := StrToNetAddr6(IP); + n := ResolveAddress6(a6[1], a); + if n > 0 then + Result := a[1]; + end; +end; + +{=============================================================================} + +function InitSocketInterface(stack: string): Boolean; +begin + SockEnhancedApi := False; + SockWship6Api := False; +// Libc.Signal(Libc.SIGPIPE, TSignalHandler(Libc.SIG_IGN)); + Result := True; +end; + +function DestroySocketInterface: Boolean; +begin + Result := True; +end; + +initialization +begin + SynSockCS := SyncObjs.TCriticalSection.Create; + SET_IN6_IF_ADDR_ANY (@in6addr_any); + SET_LOOPBACK_ADDR6 (@in6addr_loopback); +end; + +finalization +begin + SynSockCS.Free; +end; + +{$ENDIF} + diff --git a/synapse/ssl_cryptlib.pas b/synapse/ssl_cryptlib.pas new file mode 100644 index 0000000..b9be4de --- /dev/null +++ b/synapse/ssl_cryptlib.pas @@ -0,0 +1,677 @@ +{==============================================================================| +| Project : Ararat Synapse | 001.001.000 | +|==============================================================================| +| Content: SSL/SSH support by Peter Gutmann's CryptLib | +|==============================================================================| +| 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)2005-2012. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +{:@abstract(SSL/SSH plugin for CryptLib) + +This plugin requires cl32.dll at least version 3.2.0! It can be used on Win32 +and Linux. This library is staticly linked - when you compile your application +with this plugin, you MUST distribute it with Cryptib library, otherwise you +cannot run your application! + +It can work with keys and certificates stored as PKCS#15 only! It must be stored +as disk file only, you cannot load them from memory! Each file can hold multiple +keys and certificates. You must identify it by 'label' stored in +@link(TSSLCryptLib.PrivateKeyLabel). + +If you need to use secure connection and authorize self by certificate +(each SSL/TLS server or client with client authorization), then use +@link(TCustomSSL.PrivateKeyFile), @link(TSSLCryptLib.PrivateKeyLabel) and +@link(TCustomSSL.KeyPassword) properties. + +If you need to use server what verifying client certificates, then use +@link(TCustomSSL.CertCAFile) as PKCS#15 file with public keyas of allowed clients. Clients +with non-matching certificates will be rejected by cryptLib. + +This plugin is capable to create Ad-Hoc certificates. When you start SSL/TLS +server without explicitly assigned key and certificate, then this plugin create +Ad-Hoc key and certificate for each incomming connection by self. It slowdown +accepting of new connections! + +You can use this plugin for SSHv2 connections too! You must explicitly set +@link(TCustomSSL.SSLType) to value LT_SSHv2 and set @link(TCustomSSL.username) +and @link(TCustomSSL.password). You can use special SSH channels too, see +@link(TCustomSSL). +} + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$H+} + +unit ssl_cryptlib; + +interface + +uses + Windows, + SysUtils, + blcksock, synsock, synautil, synacode, + cryptlib; + +type + {:@abstract(class implementing CryptLib SSL/SSH plugin.) + Instance of this class will be created for each @link(TTCPBlockSocket). + You not need to create instance of this class, all is done by Synapse itself!} + TSSLCryptLib = class(TCustomSSL) + protected + FCryptSession: CRYPT_SESSION; + FPrivateKeyLabel: string; + FDelCert: Boolean; + FReadBuffer: string; + FTrustedCAs: array of integer; + function SSLCheck(Value: integer): Boolean; + function Init(server:Boolean): Boolean; + function DeInit: Boolean; + function Prepare(server:Boolean): Boolean; + function GetString(const cryptHandle: CRYPT_HANDLE; const attributeType: CRYPT_ATTRIBUTE_TYPE): string; + function CreateSelfSignedCert(Host: string): Boolean; override; + function PopAll: string; + public + {:See @inherited} + constructor Create(const Value: TTCPBlockSocket); override; + destructor Destroy; override; + {:Load trusted CA's in PEM format} + procedure SetCertCAFile(const Value: string); override; + {:See @inherited} + function LibVersion: String; override; + {:See @inherited} + function LibName: String; override; + {:See @inherited} + procedure Assign(const Value: TCustomSSL); override; + {:See @inherited and @link(ssl_cryptlib) for more details.} + function Connect: boolean; override; + {:See @inherited and @link(ssl_cryptlib) for more details.} + function Accept: boolean; override; + {:See @inherited} + function Shutdown: boolean; override; + {:See @inherited} + function BiShutdown: boolean; override; + {:See @inherited} + function SendBuffer(Buffer: TMemory; Len: Integer): Integer; override; + {:See @inherited} + function RecvBuffer(Buffer: TMemory; Len: Integer): Integer; override; + {:See @inherited} + function WaitingData: Integer; override; + {:See @inherited} + function GetSSLVersion: string; override; + {:See @inherited} + function GetPeerSubject: string; override; + {:See @inherited} + function GetPeerIssuer: string; override; + {:See @inherited} + function GetPeerName: string; override; + {:See @inherited} + function GetPeerFingerprint: string; override; + {:See @inherited} + function GetVerifyCert: integer; override; + published + {:name of certificate/key within PKCS#15 file. It can hold more then one + certificate/key and each certificate/key must have unique label within one file.} + property PrivateKeyLabel: string read FPrivateKeyLabel Write FPrivateKeyLabel; + end; + +implementation + +{==============================================================================} + +constructor TSSLCryptLib.Create(const Value: TTCPBlockSocket); +begin + inherited Create(Value); + FcryptSession := CRYPT_SESSION(CRYPT_SESSION_NONE); + FPrivateKeyLabel := 'synapse'; + FDelCert := false; + FTrustedCAs := nil; +end; + +destructor TSSLCryptLib.Destroy; +begin + SetCertCAFile(''); // destroy certificates + DeInit; + inherited Destroy; +end; + +procedure TSSLCryptLib.Assign(const Value: TCustomSSL); +begin + inherited Assign(Value); + if Value is TSSLCryptLib then + begin + FPrivateKeyLabel := TSSLCryptLib(Value).privatekeyLabel; + end; +end; + +function TSSLCryptLib.GetString(const cryptHandle: CRYPT_HANDLE; const attributeType: CRYPT_ATTRIBUTE_TYPE): string; +var + l: integer; +begin + l := 0; + cryptGetAttributeString(cryptHandle, attributeType, nil, l); + setlength(Result, l); + cryptGetAttributeString(cryptHandle, attributeType, pointer(Result), l); + setlength(Result, l); +end; + +function TSSLCryptLib.LibVersion: String; +var + x: integer; +begin + Result := GetString(CRYPT_UNUSED, CRYPT_OPTION_INFO_DESCRIPTION); + cryptGetAttribute(CRYPT_UNUSED, CRYPT_OPTION_INFO_MAJORVERSION, x); + Result := Result + ' v' + IntToStr(x); + cryptGetAttribute(CRYPT_UNUSED, CRYPT_OPTION_INFO_MINORVERSION, x); + Result := Result + '.' + IntToStr(x); + cryptGetAttribute(CRYPT_UNUSED, CRYPT_OPTION_INFO_STEPPING, x); + Result := Result + '.' + IntToStr(x); +end; + +function TSSLCryptLib.LibName: String; +begin + Result := 'ssl_cryptlib'; +end; + +function TSSLCryptLib.SSLCheck(Value: integer): Boolean; +begin + Result := true; + FLastErrorDesc := ''; + if Value = CRYPT_ERROR_COMPLETE then + Value := 0; + FLastError := Value; + if FLastError <> 0 then + begin + Result := False; +{$IF CRYPTLIB_VERSION >= 3400} + FLastErrorDesc := GetString(FCryptSession, CRYPT_ATTRIBUTE_ERRORMESSAGE); +{$ELSE} + FLastErrorDesc := GetString(FCryptSession, CRYPT_ATTRIBUTE_INT_ERRORMESSAGE); +{$IFEND} + end; +end; + +function TSSLCryptLib.CreateSelfSignedCert(Host: string): Boolean; +var + privateKey: CRYPT_CONTEXT; + keyset: CRYPT_KEYSET; + cert: CRYPT_CERTIFICATE; + publicKey: CRYPT_CONTEXT; +begin + if FPrivatekeyFile = '' then + FPrivatekeyFile := GetTempFile('', 'key'); + cryptCreateContext(privateKey, CRYPT_UNUSED, CRYPT_ALGO_RSA); + cryptSetAttributeString(privateKey, CRYPT_CTXINFO_LABEL, Pointer(FPrivatekeyLabel), + Length(FPrivatekeyLabel)); + cryptSetAttribute(privateKey, CRYPT_CTXINFO_KEYSIZE, 1024); + cryptGenerateKey(privateKey); + cryptKeysetOpen(keyset, CRYPT_UNUSED, CRYPT_KEYSET_FILE, PChar(FPrivatekeyFile), CRYPT_KEYOPT_CREATE); + FDelCert := True; + cryptAddPrivateKey(keyset, privateKey, PChar(FKeyPassword)); + cryptCreateCert(cert, CRYPT_UNUSED, CRYPT_CERTTYPE_CERTIFICATE); + cryptSetAttribute(cert, CRYPT_CERTINFO_XYZZY, 1); + cryptGetPublicKey(keyset, publicKey, CRYPT_KEYID_NAME, PChar(FPrivatekeyLabel)); + cryptSetAttribute(cert, CRYPT_CERTINFO_SUBJECTPUBLICKEYINFO, publicKey); + cryptSetAttributeString(cert, CRYPT_CERTINFO_COMMONNAME, Pointer(host), Length(host)); + cryptSignCert(cert, privateKey); + cryptAddPublicKey(keyset, cert); + cryptKeysetClose(keyset); + cryptDestroyCert(cert); + cryptDestroyContext(privateKey); + cryptDestroyContext(publicKey); + Result := True; +end; + +function TSSLCryptLib.PopAll: string; +const + BufferMaxSize = 32768; +var + Outbuffer: string; + WriteLen: integer; +begin + Result := ''; + repeat + setlength(outbuffer, BufferMaxSize); + Writelen := 0; + SSLCheck(CryptPopData(FCryptSession, @OutBuffer[1], BufferMaxSize, Writelen)); + if FLastError <> 0 then + Break; + if WriteLen > 0 then + begin + setlength(outbuffer, WriteLen); + Result := Result + outbuffer; + end; + until WriteLen = 0; +end; + +function TSSLCryptLib.Init(server:Boolean): Boolean; +var + st: CRYPT_SESSION_TYPE; + keysetobj: CRYPT_KEYSET; + cryptContext: CRYPT_CONTEXT; + x: integer; +begin + Result := False; + FLastErrorDesc := ''; + FLastError := 0; + FDelCert := false; + FcryptSession := CRYPT_SESSION(CRYPT_SESSION_NONE); + if server then + case FSSLType of + LT_all, LT_SSLv3, LT_TLSv1, LT_TLSv1_1: + st := CRYPT_SESSION_SSL_SERVER; + LT_SSHv2: + st := CRYPT_SESSION_SSH_SERVER; + else + Exit; + end + else + case FSSLType of + LT_all, LT_SSLv3, LT_TLSv1, LT_TLSv1_1: + st := CRYPT_SESSION_SSL; + LT_SSHv2: + st := CRYPT_SESSION_SSH; + else + Exit; + end; + if not SSLCheck(cryptCreateSession(FcryptSession, CRYPT_UNUSED, st)) then + Exit; + x := -1; + case FSSLType of + LT_SSLv3: + x := 0; + LT_TLSv1: + x := 1; + LT_TLSv1_1: + x := 2; + end; + if x >= 0 then + if not SSLCheck(cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_VERSION, x)) then + Exit; + + if (FCertComplianceLevel <> -1) then + if not SSLCheck(cryptSetAttribute (CRYPT_UNUSED, CRYPT_OPTION_CERT_COMPLIANCELEVEL, + FCertComplianceLevel)) then + Exit; + + if FUsername <> '' then + begin + cryptSetAttributeString(FcryptSession, CRYPT_SESSINFO_USERNAME, + Pointer(FUsername), Length(FUsername)); + cryptSetAttributeString(FcryptSession, CRYPT_SESSINFO_PASSWORD, + Pointer(FPassword), Length(FPassword)); + end; + if FSSLType = LT_SSHv2 then + if FSSHChannelType <> '' then + begin + cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_SSH_CHANNEL, CRYPT_UNUSED); + cryptSetAttributeString(FCryptSession, CRYPT_SESSINFO_SSH_CHANNEL_TYPE, + Pointer(FSSHChannelType), Length(FSSHChannelType)); + if FSSHChannelArg1 <> '' then + cryptSetAttributeString(FCryptSession, CRYPT_SESSINFO_SSH_CHANNEL_ARG1, + Pointer(FSSHChannelArg1), Length(FSSHChannelArg1)); + if FSSHChannelArg2 <> '' then + cryptSetAttributeString(FCryptSession, CRYPT_SESSINFO_SSH_CHANNEL_ARG2, + Pointer(FSSHChannelArg2), Length(FSSHChannelArg2)); + end; + + + if server and (FPrivatekeyFile = '') then + begin + if FPrivatekeyLabel = '' then + FPrivatekeyLabel := 'synapse'; + if FkeyPassword = '' then + FkeyPassword := 'synapse'; + CreateSelfSignedcert(FSocket.ResolveIPToName(FSocket.GetRemoteSinIP)); + end; + + if (FPrivatekeyLabel <> '') and (FPrivatekeyFile <> '') then + begin + if not SSLCheck(cryptKeysetOpen(KeySetObj, CRYPT_UNUSED, CRYPT_KEYSET_FILE, + PChar(FPrivatekeyFile), CRYPT_KEYOPT_READONLY)) then + Exit; + try + if not SSLCheck(cryptGetPrivateKey(KeySetObj, cryptcontext, CRYPT_KEYID_NAME, + PChar(FPrivatekeyLabel), PChar(FKeyPassword))) then + Exit; + if not SSLCheck(cryptSetAttribute(FcryptSession, CRYPT_SESSINFO_PRIVATEKEY, + cryptcontext)) then + Exit; + finally + cryptKeysetClose(keySetObj); + cryptDestroyContext(cryptcontext); + end; + end; + if server and FVerifyCert then + begin + if not SSLCheck(cryptKeysetOpen(KeySetObj, CRYPT_UNUSED, CRYPT_KEYSET_FILE, + PChar(FCertCAFile), CRYPT_KEYOPT_READONLY)) then + Exit; + try + if not SSLCheck(cryptSetAttribute(FcryptSession, CRYPT_SESSINFO_KEYSET, + keySetObj)) then + Exit; + finally + cryptKeysetClose(keySetObj); + end; + end; + Result := true; +end; + +function TSSLCryptLib.DeInit: Boolean; +begin + Result := True; + if FcryptSession <> CRYPT_SESSION(CRYPT_SESSION_NONE) then + CryptDestroySession(FcryptSession); + FcryptSession := CRYPT_SESSION(CRYPT_SESSION_NONE); + FSSLEnabled := False; + if FDelCert then + SysUtils.DeleteFile(FPrivatekeyFile); +end; + +function TSSLCryptLib.Prepare(server:Boolean): Boolean; +begin + Result := false; + DeInit; + if Init(server) then + Result := true + else + DeInit; +end; + +function TSSLCryptLib.Connect: boolean; +begin + Result := False; + if FSocket.Socket = INVALID_SOCKET then + Exit; + if Prepare(false) then + begin + if not SSLCheck(cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_NETWORKSOCKET, FSocket.Socket)) then + Exit; + if not SSLCheck(cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_ACTIVE, 1)) then + Exit; + if FverifyCert then + if (GetVerifyCert <> 0) or (not DoVerifyCert) then + Exit; + FSSLEnabled := True; + Result := True; + FReadBuffer := ''; + end; +end; + +function TSSLCryptLib.Accept: boolean; +begin + Result := False; + if FSocket.Socket = INVALID_SOCKET then + Exit; + if Prepare(true) then + begin + if not SSLCheck(cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_NETWORKSOCKET, FSocket.Socket)) then + Exit; + if not SSLCheck(cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_ACTIVE, 1)) then + Exit; + FSSLEnabled := True; + Result := True; + FReadBuffer := ''; + end; +end; + +function TSSLCryptLib.Shutdown: boolean; +begin + Result := BiShutdown; +end; + +function TSSLCryptLib.BiShutdown: boolean; +begin + if FcryptSession <> CRYPT_SESSION(CRYPT_SESSION_NONE) then + cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_ACTIVE, 0); + DeInit; + FReadBuffer := ''; + Result := True; +end; + +function TSSLCryptLib.SendBuffer(Buffer: TMemory; Len: Integer): Integer; +var + l: integer; +begin + FLastError := 0; + FLastErrorDesc := ''; + SSLCheck(cryptPushData(FCryptSession, Buffer, Len, L)); + cryptFlushData(FcryptSession); + Result := l; +end; + +function TSSLCryptLib.RecvBuffer(Buffer: TMemory; Len: Integer): Integer; +begin + FLastError := 0; + FLastErrorDesc := ''; + if Length(FReadBuffer) = 0 then + FReadBuffer := PopAll; + if Len > Length(FReadBuffer) then + Len := Length(FReadBuffer); + Move(Pointer(FReadBuffer)^, buffer^, Len); + Delete(FReadBuffer, 1, Len); + Result := Len; +end; + +function TSSLCryptLib.WaitingData: Integer; +begin + Result := Length(FReadBuffer); +end; + +function TSSLCryptLib.GetSSLVersion: string; +var + x: integer; +begin + Result := ''; + if FcryptSession = CRYPT_SESSION(CRYPT_SESSION_NONE) then + Exit; + cryptGetAttribute(FCryptSession, CRYPT_SESSINFO_VERSION, x); + if FSSLType in [LT_SSLv3, LT_TLSv1, LT_TLSv1_1, LT_all] then + case x of + 0: + Result := 'SSLv3'; + 1: + Result := 'TLSv1'; + 2: + Result := 'TLSv1.1'; + end; + if FSSLType in [LT_SSHv2] then + case x of + 0: + Result := 'SSHv1'; + 1: + Result := 'SSHv2'; + end; +end; + +function TSSLCryptLib.GetPeerSubject: string; +var + cert: CRYPT_CERTIFICATE; +begin + Result := ''; + if FcryptSession = CRYPT_SESSION(CRYPT_SESSION_NONE) then + Exit; + cryptGetAttribute(FCryptSession, CRYPT_SESSINFO_RESPONSE, cert); + cryptSetAttribute(cert, CRYPT_ATTRIBUTE_CURRENT, CRYPT_CERTINFO_SUBJECTNAME); + Result := GetString(cert, CRYPT_CERTINFO_DN); + cryptDestroyCert(cert); +end; + +function TSSLCryptLib.GetPeerName: string; +var + cert: CRYPT_CERTIFICATE; +begin + Result := ''; + if FcryptSession = CRYPT_SESSION(CRYPT_SESSION_NONE) then + Exit; + cryptGetAttribute(FCryptSession, CRYPT_SESSINFO_RESPONSE, cert); + cryptSetAttribute(cert, CRYPT_ATTRIBUTE_CURRENT, CRYPT_CERTINFO_SUBJECTNAME); + Result := GetString(cert, CRYPT_CERTINFO_COMMONNAME); + cryptDestroyCert(cert); +end; + +function TSSLCryptLib.GetPeerIssuer: string; +var + cert: CRYPT_CERTIFICATE; +begin + Result := ''; + if FcryptSession = CRYPT_SESSION(CRYPT_SESSION_NONE) then + Exit; + cryptGetAttribute(FCryptSession, CRYPT_SESSINFO_RESPONSE, cert); + cryptSetAttribute(cert, CRYPT_ATTRIBUTE_CURRENT, CRYPT_CERTINFO_ISSUERNAME); + Result := GetString(cert, CRYPT_CERTINFO_COMMONNAME); + cryptDestroyCert(cert); +end; + +function TSSLCryptLib.GetPeerFingerprint: string; +var + cert: CRYPT_CERTIFICATE; +begin + Result := ''; + if FcryptSession = CRYPT_SESSION(CRYPT_SESSION_NONE) then + Exit; + cryptGetAttribute(FCryptSession, CRYPT_SESSINFO_RESPONSE, cert); + Result := GetString(cert, CRYPT_CERTINFO_FINGERPRINT); + cryptDestroyCert(cert); +end; + + +procedure TSSLCryptLib.SetCertCAFile(const Value: string); + +var F:textfile; + bInCert:boolean; + s,sCert:string; + cert: CRYPT_CERTIFICATE; + idx:integer; + +begin +if assigned(FTrustedCAs) then + begin + for idx := 0 to High(FTrustedCAs) do + cryptDestroyCert(FTrustedCAs[idx]); + FTrustedCAs:=nil; + end; +if Value<>'' then + begin + AssignFile(F,Value); + reset(F); + bInCert:=false; + idx:=0; + while not eof(F) do + begin + readln(F,s); + if pos('-----END CERTIFICATE-----',s)>0 then + begin + bInCert:=false; + cert:=0; + if (cryptImportCert(PAnsiChar(sCert),length(sCert)-2,CRYPT_UNUSED,cert)=CRYPT_OK) then + begin + cryptSetAttribute( cert, CRYPT_CERTINFO_TRUSTED_IMPLICIT, 1 ); + SetLength(FTrustedCAs,idx+1); + FTrustedCAs[idx]:=cert; + idx:=idx+1; + end; + end; + if bInCert then + sCert:=sCert+s+#13#10; + if pos('-----BEGIN CERTIFICATE-----',s)>0 then + begin + bInCert:=true; + sCert:=''; + end; + end; + CloseFile(F); + end; +end; + +function TSSLCryptLib.GetVerifyCert: integer; +var + cert: CRYPT_CERTIFICATE; + itype,ilocus:integer; +begin + Result := -1; + if FcryptSession = CRYPT_SESSION(CRYPT_SESSION_NONE) then + Exit; + cryptGetAttribute(FCryptSession, CRYPT_SESSINFO_RESPONSE, cert); + result:=cryptCheckCert(cert,CRYPT_UNUSED); + if result<>CRYPT_OK then + begin + //get extended error info if available + cryptGetAttribute(cert,CRYPT_ATTRIBUTE_ERRORtype,itype); + cryptGetAttribute(cert,CRYPT_ATTRIBUTE_ERRORLOCUS,ilocus); + cryptSetAttribute(cert, CRYPT_ATTRIBUTE_CURRENT, CRYPT_CERTINFO_SUBJECTNAME); + FLastError := Result; + FLastErrorDesc := format('SSL/TLS certificate verification failed for "%s"'#13#10'Status: %d. ERRORTYPE: %d. ERRORLOCUS: %d.', + [GetString(cert, CRYPT_CERTINFO_COMMONNAME),result,itype,ilocus]); + end; + cryptDestroyCert(cert); +end; + +{==============================================================================} + +var imajor,iminor,iver:integer; +// e: ESynapseError; + +initialization + if cryptInit = CRYPT_OK then + SSLImplementation := TSSLCryptLib; + cryptAddRandom(nil, CRYPT_RANDOM_SLOWPOLL); + cryptGetAttribute (CRYPT_UNUSED, CRYPT_OPTION_INFO_MAJORVERSION,imajor); + cryptGetAttribute (CRYPT_UNUSED, CRYPT_OPTION_INFO_MINORVERSION,iminor); +// according to the documentation CRYPTLIB version has 3 digits. recent versions use 4 digits + if CRYPTLIB_VERSION >1000 then + iver:=CRYPTLIB_VERSION div 100 + else + iver:=CRYPTLIB_VERSION div 10; + if (iver <> imajor*10+iminor) then + begin + SSLImplementation :=TSSLNone; +// e := ESynapseError.Create(format('Error wrong cryptlib version (is %d.%d expected %d.%d). ', +// [imajor,iminor,iver div 10, iver mod 10])); +// e.ErrorCode := 0; +// e.ErrorMessage := format('Error wrong cryptlib version (%d.%d expected %d.%d)', +// [imajor,iminor,iver div 10, iver mod 10]); +// raise e; + end; +finalization + cryptEnd; +end. + + diff --git a/synapse/ssl_openssl.pas b/synapse/ssl_openssl.pas new file mode 100644 index 0000000..ea4fee6 --- /dev/null +++ b/synapse/ssl_openssl.pas @@ -0,0 +1,896 @@ +{==============================================================================| +| Project : Ararat Synapse | 001.002.000 | +|==============================================================================| +| Content: SSL support by OpenSSL | +|==============================================================================| +| Copyright (c)1999-2008, 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-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/) | +|==============================================================================} + +//requires OpenSSL libraries! + +{:@abstract(SSL plugin for OpenSSL) + +You need OpenSSL libraries version 0.9.7. It can work with 0.9.6 too, but +application mysteriously crashing when you are using freePascal on Linux. +Use Kylix on Linux is OK! If you have version 0.9.7 on Linux, then I not see +any problems with FreePascal. + +OpenSSL libraries are loaded dynamicly - you not need OpenSSl librares even you +compile your application with this unit. SSL just not working when you not have +OpenSSL libraries. + +This plugin have limited support for .NET too! Because is not possible to use +callbacks with CDECL calling convention under .NET, is not supported +key/certificate passwords and multithread locking. :-( + +For handling keys and certificates you can use this properties: + +@link(TCustomSSL.CertificateFile) for PEM or ASN1 DER (cer) format. @br +@link(TCustomSSL.Certificate) for ASN1 DER format only. @br +@link(TCustomSSL.PrivateKeyFile) for PEM or ASN1 DER (key) format. @br +@link(TCustomSSL.PrivateKey) for ASN1 DER format only. @br +@link(TCustomSSL.CertCAFile) for PEM CA certificate bundle. @br +@link(TCustomSSL.PFXFile) for PFX format. @br +@link(TCustomSSL.PFX) for PFX format from binary string. @br + +This plugin is capable to create Ad-Hoc certificates. When you start SSL/TLS +server without explicitly assigned key and certificate, then this plugin create +Ad-Hoc key and certificate for each incomming connection by self. It slowdown +accepting of new connections! +} + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$H+} + +{$IFDEF UNICODE} + {$WARN IMPLICIT_STRING_CAST OFF} + {$WARN IMPLICIT_STRING_CAST_LOSS OFF} +{$ENDIF} + +unit ssl_openssl; + +interface + +uses + SysUtils, Classes, + blcksock, synsock, synautil, +{$IFDEF CIL} + System.Text, +{$ENDIF} + ssl_openssl_lib; + +type + {:@abstract(class implementing OpenSSL SSL plugin.) + Instance of this class will be created for each @link(TTCPBlockSocket). + You not need to create instance of this class, all is done by Synapse itself!} + TSSLOpenSSL = class(TCustomSSL) + protected + FSsl: PSSL; + Fctx: PSSL_CTX; + function SSLCheck: Boolean; + function SetSslKeys: boolean; + function Init(server:Boolean): Boolean; + function DeInit: Boolean; + function Prepare(server:Boolean): Boolean; + function LoadPFX(pfxdata: ansistring): Boolean; + function CreateSelfSignedCert(Host: string): Boolean; override; + public + {:See @inherited} + constructor Create(const Value: TTCPBlockSocket); override; + destructor Destroy; override; + {:See @inherited} + function LibVersion: String; override; + {:See @inherited} + function LibName: String; override; + {:See @inherited and @link(ssl_cryptlib) for more details.} + function Connect: boolean; override; + {:See @inherited and @link(ssl_cryptlib) for more details.} + function Accept: boolean; override; + {:See @inherited} + function Shutdown: boolean; override; + {:See @inherited} + function BiShutdown: boolean; override; + {:See @inherited} + function SendBuffer(Buffer: TMemory; Len: Integer): Integer; override; + {:See @inherited} + function RecvBuffer(Buffer: TMemory; Len: Integer): Integer; override; + {:See @inherited} + function WaitingData: Integer; override; + {:See @inherited} + function GetSSLVersion: string; override; + {:See @inherited} + function GetPeerSubject: string; override; + {:See @inherited} + function GetPeerSerialNo: integer; override; {pf} + {:See @inherited} + function GetPeerIssuer: string; override; + {:See @inherited} + function GetPeerName: string; override; + {:See @inherited} + function GetPeerNameHash: cardinal; override; {pf} + {:See @inherited} + function GetPeerFingerprint: string; override; + {:See @inherited} + function GetCertInfo: string; override; + {:See @inherited} + function GetCipherName: string; override; + {:See @inherited} + function GetCipherBits: integer; override; + {:See @inherited} + function GetCipherAlgBits: integer; override; + {:See @inherited} + function GetVerifyCert: integer; override; + end; + +implementation + +{==============================================================================} + +{$IFNDEF CIL} +function PasswordCallback(buf:PAnsiChar; size:Integer; rwflag:Integer; userdata: Pointer):Integer; cdecl; +var + Password: AnsiString; +begin + Password := ''; + if TCustomSSL(userdata) is TCustomSSL then + Password := TCustomSSL(userdata).KeyPassword; + if Length(Password) > (Size - 1) then + SetLength(Password, Size - 1); + Result := Length(Password); + StrLCopy(buf, PAnsiChar(Password + #0), Result + 1); +end; +{$ENDIF} + +{==============================================================================} + +constructor TSSLOpenSSL.Create(const Value: TTCPBlockSocket); +begin + inherited Create(Value); + FCiphers := 'DEFAULT'; + FSsl := nil; + Fctx := nil; +end; + +destructor TSSLOpenSSL.Destroy; +begin + DeInit; + inherited Destroy; +end; + +function TSSLOpenSSL.LibVersion: String; +begin + Result := SSLeayversion(0); +end; + +function TSSLOpenSSL.LibName: String; +begin + Result := 'ssl_openssl'; +end; + +function TSSLOpenSSL.SSLCheck: Boolean; +var +{$IFDEF CIL} + sb: StringBuilder; +{$ENDIF} + s : AnsiString; +begin + Result := true; + FLastErrorDesc := ''; + FLastError := ErrGetError; + ErrClearError; + if FLastError <> 0 then + begin + Result := False; +{$IFDEF CIL} + sb := StringBuilder.Create(256); + ErrErrorString(FLastError, sb, 256); + FLastErrorDesc := Trim(sb.ToString); +{$ELSE} + s := StringOfChar(#0, 256); + ErrErrorString(FLastError, s, Length(s)); + FLastErrorDesc := s; +{$ENDIF} + end; +end; + +function TSSLOpenSSL.CreateSelfSignedCert(Host: string): Boolean; +var + pk: EVP_PKEY; + x: PX509; + rsa: PRSA; + t: PASN1_UTCTIME; + name: PX509_NAME; + b: PBIO; + xn, y: integer; + s: AnsiString; +{$IFDEF CIL} + sb: StringBuilder; +{$ENDIF} +begin + Result := True; + pk := EvpPkeynew; + x := X509New; + try + rsa := RsaGenerateKey(1024, $10001, nil, nil); + EvpPkeyAssign(pk, EVP_PKEY_RSA, rsa); + X509SetVersion(x, 2); + Asn1IntegerSet(X509getSerialNumber(x), 0); + t := Asn1UtctimeNew; + try + X509GmtimeAdj(t, -60 * 60 *24); + X509SetNotBefore(x, t); + X509GmtimeAdj(t, 60 * 60 * 60 *24); + X509SetNotAfter(x, t); + finally + Asn1UtctimeFree(t); + end; + X509SetPubkey(x, pk); + Name := X509GetSubjectName(x); + X509NameAddEntryByTxt(Name, 'C', $1001, 'CZ', -1, -1, 0); + X509NameAddEntryByTxt(Name, 'CN', $1001, host, -1, -1, 0); + x509SetIssuerName(x, Name); + x509Sign(x, pk, EvpGetDigestByName('SHA1')); + b := BioNew(BioSMem); + try + i2dX509Bio(b, x); + xn := bioctrlpending(b); +{$IFDEF CIL} + sb := StringBuilder.Create(xn); + y := bioread(b, sb, xn); + if y > 0 then + begin + sb.Length := y; + s := sb.ToString; + end; +{$ELSE} + setlength(s, xn); + y := bioread(b, s, xn); + if y > 0 then + setlength(s, y); +{$ENDIF} + finally + BioFreeAll(b); + end; + FCertificate := s; + b := BioNew(BioSMem); + try + i2dPrivatekeyBio(b, pk); + xn := bioctrlpending(b); +{$IFDEF CIL} + sb := StringBuilder.Create(xn); + y := bioread(b, sb, xn); + if y > 0 then + begin + sb.Length := y; + s := sb.ToString; + end; +{$ELSE} + setlength(s, xn); + y := bioread(b, s, xn); + if y > 0 then + setlength(s, y); +{$ENDIF} + finally + BioFreeAll(b); + end; + FPrivatekey := s; + finally + X509free(x); + EvpPkeyFree(pk); + end; +end; + +function TSSLOpenSSL.LoadPFX(pfxdata: Ansistring): Boolean; +var + cert, pkey, ca: SslPtr; + b: PBIO; + p12: SslPtr; +begin + Result := False; + b := BioNew(BioSMem); + try + BioWrite(b, pfxdata, Length(PfxData)); + p12 := d2iPKCS12bio(b, nil); + if not Assigned(p12) then + Exit; + try + cert := nil; + pkey := nil; + ca := nil; + try {pf} + if PKCS12parse(p12, FKeyPassword, pkey, cert, ca) > 0 then + if SSLCTXusecertificate(Fctx, cert) > 0 then + if SSLCTXusePrivateKey(Fctx, pkey) > 0 then + Result := True; + {pf} + finally + EvpPkeyFree(pkey); + X509free(cert); + SkX509PopFree(ca,_X509Free); // for ca=nil a new STACK was allocated... + end; + {/pf} + finally + PKCS12free(p12); + end; + finally + BioFreeAll(b); + end; +end; + +function TSSLOpenSSL.SetSslKeys: boolean; +var + st: TFileStream; + s: string; +begin + Result := False; + if not assigned(FCtx) then + Exit; + try + if FCertificateFile <> '' then + if SslCtxUseCertificateChainFile(FCtx, FCertificateFile) <> 1 then + if SslCtxUseCertificateFile(FCtx, FCertificateFile, SSL_FILETYPE_PEM) <> 1 then + if SslCtxUseCertificateFile(FCtx, FCertificateFile, SSL_FILETYPE_ASN1) <> 1 then + Exit; + if FCertificate <> '' then + if SslCtxUseCertificateASN1(FCtx, length(FCertificate), FCertificate) <> 1 then + Exit; + SSLCheck; + if FPrivateKeyFile <> '' then + if SslCtxUsePrivateKeyFile(FCtx, FPrivateKeyFile, SSL_FILETYPE_PEM) <> 1 then + if SslCtxUsePrivateKeyFile(FCtx, FPrivateKeyFile, SSL_FILETYPE_ASN1) <> 1 then + Exit; + if FPrivateKey <> '' then + if SslCtxUsePrivateKeyASN1(EVP_PKEY_RSA, FCtx, FPrivateKey, length(FPrivateKey)) <> 1 then + Exit; + SSLCheck; + if FCertCAFile <> '' then + if SslCtxLoadVerifyLocations(FCtx, FCertCAFile, '') <> 1 then + Exit; + if FPFXfile <> '' then + begin + try + st := TFileStream.Create(FPFXfile, fmOpenRead or fmShareDenyNone); + try + s := ReadStrFromStream(st, st.Size); + finally + st.Free; + end; + if not LoadPFX(s) then + Exit; + except + on Exception do + Exit; + end; + end; + if FPFX <> '' then + if not LoadPFX(FPfx) then + Exit; + SSLCheck; + Result := True; + finally + SSLCheck; + end; +end; + +function TSSLOpenSSL.Init(server:Boolean): Boolean; +var + s: AnsiString; +begin + Result := False; + FLastErrorDesc := ''; + FLastError := 0; + Fctx := nil; + case FSSLType of + LT_SSLv2: + Fctx := SslCtxNew(SslMethodV2); + LT_SSLv3: + Fctx := SslCtxNew(SslMethodV3); + LT_TLSv1: + Fctx := SslCtxNew(SslMethodTLSV1); + LT_all: + Fctx := SslCtxNew(SslMethodV23); + else + Exit; + end; + if Fctx = nil then + begin + SSLCheck; + Exit; + end + else + begin + s := FCiphers; + SslCtxSetCipherList(Fctx, s); + if FVerifyCert then + SslCtxSetVerify(FCtx, SSL_VERIFY_PEER, nil) + else + SslCtxSetVerify(FCtx, SSL_VERIFY_NONE, nil); +{$IFNDEF CIL} + SslCtxSetDefaultPasswdCb(FCtx, @PasswordCallback); + SslCtxSetDefaultPasswdCbUserdata(FCtx, self); +{$ENDIF} + + if server and (FCertificateFile = '') and (FCertificate = '') + and (FPFXfile = '') and (FPFX = '') then + begin + CreateSelfSignedcert(FSocket.ResolveIPToName(FSocket.GetRemoteSinIP)); + end; + + if not SetSSLKeys then + Exit + else + begin + Fssl := nil; + Fssl := SslNew(Fctx); + if Fssl = nil then + begin + SSLCheck; + exit; + end; + end; + end; + Result := true; +end; + +function TSSLOpenSSL.DeInit: Boolean; +begin + Result := True; + if assigned (Fssl) then + sslfree(Fssl); + Fssl := nil; + if assigned (Fctx) then + begin + SslCtxFree(Fctx); + Fctx := nil; + ErrRemoveState(0); + end; + FSSLEnabled := False; +end; + +function TSSLOpenSSL.Prepare(server:Boolean): Boolean; +begin + Result := false; + DeInit; + if Init(server) then + Result := true + else + DeInit; +end; + +function TSSLOpenSSL.Connect: boolean; +var + x: integer; +begin + Result := False; + if FSocket.Socket = INVALID_SOCKET then + Exit; + if Prepare(False) then + begin +{$IFDEF CIL} + if sslsetfd(FSsl, FSocket.Socket.Handle.ToInt32) < 1 then +{$ELSE} + if sslsetfd(FSsl, FSocket.Socket) < 1 then +{$ENDIF} + begin + SSLCheck; + Exit; + end; + if SNIHost<>'' then + SSLCtrl(Fssl, SSL_CTRL_SET_TLSEXT_HOSTNAME, TLSEXT_NAMETYPE_host_name, PAnsiChar(SNIHost)); + x := sslconnect(FSsl); + if x < 1 then + begin + SSLcheck; + Exit; + end; + if FverifyCert then + if (GetVerifyCert <> 0) or (not DoVerifyCert) then + Exit; + FSSLEnabled := True; + Result := True; + end; +end; + +function TSSLOpenSSL.Accept: boolean; +var + x: integer; +begin + Result := False; + if FSocket.Socket = INVALID_SOCKET then + Exit; + if Prepare(True) then + begin +{$IFDEF CIL} + if sslsetfd(FSsl, FSocket.Socket.Handle.ToInt32) < 1 then +{$ELSE} + if sslsetfd(FSsl, FSocket.Socket) < 1 then +{$ENDIF} + begin + SSLCheck; + Exit; + end; + x := sslAccept(FSsl); + if x < 1 then + begin + SSLcheck; + Exit; + end; + FSSLEnabled := True; + Result := True; + end; +end; + +function TSSLOpenSSL.Shutdown: boolean; +begin + if assigned(FSsl) then + sslshutdown(FSsl); + DeInit; + Result := True; +end; + +function TSSLOpenSSL.BiShutdown: boolean; +var + x: integer; +begin + if assigned(FSsl) then + begin + x := sslshutdown(FSsl); + if x = 0 then + begin + Synsock.Shutdown(FSocket.Socket, 1); + sslshutdown(FSsl); + end; + end; + DeInit; + Result := True; +end; + +function TSSLOpenSSL.SendBuffer(Buffer: TMemory; Len: Integer): Integer; +var + err: integer; +{$IFDEF CIL} + s: ansistring; +{$ENDIF} +begin + FLastError := 0; + FLastErrorDesc := ''; + repeat +{$IFDEF CIL} + s := StringOf(Buffer); + Result := SslWrite(FSsl, s, Len); +{$ELSE} + Result := SslWrite(FSsl, Buffer , Len); +{$ENDIF} + err := SslGetError(FSsl, Result); + until (err <> SSL_ERROR_WANT_READ) and (err <> SSL_ERROR_WANT_WRITE); + if err = SSL_ERROR_ZERO_RETURN then + Result := 0 + else + if (err <> 0) then + FLastError := err; +end; + +function TSSLOpenSSL.RecvBuffer(Buffer: TMemory; Len: Integer): Integer; +var + err: integer; +{$IFDEF CIL} + sb: stringbuilder; + s: ansistring; +{$ENDIF} +begin + FLastError := 0; + FLastErrorDesc := ''; + repeat +{$IFDEF CIL} + sb := StringBuilder.Create(Len); + Result := SslRead(FSsl, sb, Len); + if Result > 0 then + begin + sb.Length := Result; + s := sb.ToString; + System.Array.Copy(BytesOf(s), Buffer, length(s)); + end; +{$ELSE} + Result := SslRead(FSsl, Buffer , Len); +{$ENDIF} + err := SslGetError(FSsl, Result); + until (err <> SSL_ERROR_WANT_READ) and (err <> SSL_ERROR_WANT_WRITE); + if err = SSL_ERROR_ZERO_RETURN then + Result := 0 + {pf}// Verze 1.1.0 byla s else tak jak to ted mam, + // ve verzi 1.1.1 bylo ELSE zruseno, ale pak je SSL_ERROR_ZERO_RETURN + // propagovano jako Chyba. + {pf} else {/pf} if (err <> 0) then + FLastError := err; +end; + +function TSSLOpenSSL.WaitingData: Integer; +begin + Result := sslpending(Fssl); +end; + +function TSSLOpenSSL.GetSSLVersion: string; +begin + if not assigned(FSsl) then + Result := '' + else + Result := SSlGetVersion(FSsl); +end; + +function TSSLOpenSSL.GetPeerSubject: string; +var + cert: PX509; + s: ansistring; +{$IFDEF CIL} + sb: StringBuilder; +{$ENDIF} +begin + if not assigned(FSsl) then + begin + Result := ''; + Exit; + end; + cert := SSLGetPeerCertificate(Fssl); + if not assigned(cert) then + begin + Result := ''; + Exit; + end; +{$IFDEF CIL} + sb := StringBuilder.Create(4096); + Result := X509NameOneline(X509GetSubjectName(cert), sb, 4096); +{$ELSE} + setlength(s, 4096); + Result := X509NameOneline(X509GetSubjectName(cert), s, Length(s)); +{$ENDIF} + X509Free(cert); +end; + + +function TSSLOpenSSL.GetPeerSerialNo: integer; {pf} +var + cert: PX509; + SN: PASN1_INTEGER; +begin + if not assigned(FSsl) then + begin + Result := -1; + Exit; + end; + cert := SSLGetPeerCertificate(Fssl); + try + if not assigned(cert) then + begin + Result := -1; + Exit; + end; + SN := X509GetSerialNumber(cert); + Result := Asn1IntegerGet(SN); + finally + X509Free(cert); + end; +end; + +function TSSLOpenSSL.GetPeerName: string; +var + s: ansistring; +begin + s := GetPeerSubject; + s := SeparateRight(s, '/CN='); + Result := Trim(SeparateLeft(s, '/')); +end; + +function TSSLOpenSSL.GetPeerNameHash: cardinal; {pf} +var + cert: PX509; +begin + if not assigned(FSsl) then + begin + Result := 0; + Exit; + end; + cert := SSLGetPeerCertificate(Fssl); + try + if not assigned(cert) then + begin + Result := 0; + Exit; + end; + Result := X509NameHash(X509GetSubjectName(cert)); + finally + X509Free(cert); + end; +end; + +function TSSLOpenSSL.GetPeerIssuer: string; +var + cert: PX509; + s: ansistring; +{$IFDEF CIL} + sb: StringBuilder; +{$ENDIF} +begin + if not assigned(FSsl) then + begin + Result := ''; + Exit; + end; + cert := SSLGetPeerCertificate(Fssl); + if not assigned(cert) then + begin + Result := ''; + Exit; + end; +{$IFDEF CIL} + sb := StringBuilder.Create(4096); + Result := X509NameOneline(X509GetIssuerName(cert), sb, 4096); +{$ELSE} + setlength(s, 4096); + Result := X509NameOneline(X509GetIssuerName(cert), s, Length(s)); +{$ENDIF} + X509Free(cert); +end; + +function TSSLOpenSSL.GetPeerFingerprint: string; +var + cert: PX509; + x: integer; +{$IFDEF CIL} + sb: StringBuilder; +{$ENDIF} +begin + if not assigned(FSsl) then + begin + Result := ''; + Exit; + end; + cert := SSLGetPeerCertificate(Fssl); + if not assigned(cert) then + begin + Result := ''; + Exit; + end; +{$IFDEF CIL} + sb := StringBuilder.Create(EVP_MAX_MD_SIZE); + X509Digest(cert, EvpGetDigestByName('MD5'), sb, x); + sb.Length := x; + Result := sb.ToString; +{$ELSE} + setlength(Result, EVP_MAX_MD_SIZE); + X509Digest(cert, EvpGetDigestByName('MD5'), Result, x); + SetLength(Result, x); +{$ENDIF} + X509Free(cert); +end; + +function TSSLOpenSSL.GetCertInfo: string; +var + cert: PX509; + x, y: integer; + b: PBIO; + s: AnsiString; +{$IFDEF CIL} + sb: stringbuilder; +{$ENDIF} +begin + if not assigned(FSsl) then + begin + Result := ''; + Exit; + end; + cert := SSLGetPeerCertificate(Fssl); + if not assigned(cert) then + begin + Result := ''; + Exit; + end; + try {pf} + b := BioNew(BioSMem); + try + X509Print(b, cert); + x := bioctrlpending(b); + {$IFDEF CIL} + sb := StringBuilder.Create(x); + y := bioread(b, sb, x); + if y > 0 then + begin + sb.Length := y; + s := sb.ToString; + end; + {$ELSE} + setlength(s,x); + y := bioread(b,s,x); + if y > 0 then + setlength(s, y); + {$ENDIF} + Result := ReplaceString(s, LF, CRLF); + finally + BioFreeAll(b); + end; + {pf} + finally + X509Free(cert); + end; + {/pf} +end; + +function TSSLOpenSSL.GetCipherName: string; +begin + if not assigned(FSsl) then + Result := '' + else + Result := SslCipherGetName(SslGetCurrentCipher(FSsl)); +end; + +function TSSLOpenSSL.GetCipherBits: integer; +var + x: integer; +begin + if not assigned(FSsl) then + Result := 0 + else + Result := SSLCipherGetBits(SslGetCurrentCipher(FSsl), x); +end; + +function TSSLOpenSSL.GetCipherAlgBits: integer; +begin + if not assigned(FSsl) then + Result := 0 + else + SSLCipherGetBits(SslGetCurrentCipher(FSsl), Result); +end; + +function TSSLOpenSSL.GetVerifyCert: integer; +begin + if not assigned(FSsl) then + Result := 1 + else + Result := SslGetVerifyResult(FSsl); +end; + +{==============================================================================} + +initialization + if InitSSLInterface then + SSLImplementation := TSSLOpenSSL; + +end. diff --git a/synapse/ssl_openssl_lib.pas b/synapse/ssl_openssl_lib.pas new file mode 100644 index 0000000..d009684 --- /dev/null +++ b/synapse/ssl_openssl_lib.pas @@ -0,0 +1,2138 @@ +{==============================================================================| +| Project : Ararat Synapse | 003.007.000 | +|==============================================================================| +| Content: SSL support by OpenSSL | +|==============================================================================| +| 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)2002-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/) | +|==============================================================================} + +{ +Special thanks to Gregor Ibic <gregor.ibic@intelicom.si> + (Intelicom d.o.o., http://www.intelicom.si) + for good inspiration about begin with SSL programming. +} + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$H+} +{$IFDEF VER125} + {$DEFINE BCB} +{$ENDIF} +{$IFDEF BCB} + {$ObjExportAll On} + (*$HPPEMIT 'namespace ssl_openssl_lib { using System::Shortint; }' *) +{$ENDIF} + +//old Delphi does not have MSWINDOWS define. +{$IFDEF WIN32} + {$IFNDEF MSWINDOWS} + {$DEFINE MSWINDOWS} + {$ENDIF} +{$ENDIF} + +{:@abstract(OpenSSL support) + +This unit is Pascal interface to OpenSSL library (used by @link(ssl_openssl) unit). +OpenSSL is loaded dynamicly on-demand. If this library is not found in system, +requested OpenSSL function just return errorcode. +} +unit ssl_openssl_lib; + +interface + +uses +{$IFDEF CIL} + System.Runtime.InteropServices, + System.Text, +{$ENDIF} + Classes, + synafpc, +{$IFNDEF MSWINDOWS} + {$IFDEF FPC} + BaseUnix, SysUtils; + {$ELSE} + Libc, SysUtils; + {$ENDIF} +{$ELSE} + Windows; +{$ENDIF} + + +{$IFDEF CIL} +const + {$IFDEF LINUX} + DLLSSLName = 'libssl.so'; + DLLUtilName = 'libcrypto.so'; + {$ELSE} + DLLSSLName = 'ssleay32.dll'; + DLLUtilName = 'libeay32.dll'; + {$ENDIF} +{$ELSE} +var + {$IFNDEF MSWINDOWS} + {$IFDEF DARWIN} + DLLSSLName: string = 'libssl.dylib'; + DLLUtilName: string = 'libcrypto.dylib'; + {$ELSE} + DLLSSLName: string = 'libssl.so'; + DLLUtilName: string = 'libcrypto.so'; + {$ENDIF} + {$ELSE} + DLLSSLName: string = 'ssleay32.dll'; + DLLSSLName2: string = 'libssl32.dll'; + DLLUtilName: string = 'libeay32.dll'; + {$ENDIF} +{$ENDIF} + +type +{$IFDEF CIL} + SslPtr = IntPtr; +{$ELSE} + SslPtr = Pointer; +{$ENDIF} + PSslPtr = ^SslPtr; + PSSL_CTX = SslPtr; + PSSL = SslPtr; + PSSL_METHOD = SslPtr; + PX509 = SslPtr; + PX509_NAME = SslPtr; + PEVP_MD = SslPtr; + PInteger = ^Integer; + PBIO_METHOD = SslPtr; + PBIO = SslPtr; + EVP_PKEY = SslPtr; + PRSA = SslPtr; + PASN1_UTCTIME = SslPtr; + PASN1_INTEGER = SslPtr; + PPasswdCb = SslPtr; + PFunction = procedure; + PSTACK = SslPtr; {pf} + TSkPopFreeFunc = procedure(p:SslPtr); cdecl; {pf} + TX509Free = procedure(x: PX509); cdecl; {pf} + + DES_cblock = array[0..7] of Byte; + PDES_cblock = ^DES_cblock; + des_ks_struct = packed record + ks: DES_cblock; + weak_key: Integer; + end; + des_key_schedule = array[1..16] of des_ks_struct; + +const + EVP_MAX_MD_SIZE = 16 + 20; + + SSL_ERROR_NONE = 0; + SSL_ERROR_SSL = 1; + SSL_ERROR_WANT_READ = 2; + SSL_ERROR_WANT_WRITE = 3; + SSL_ERROR_WANT_X509_LOOKUP = 4; + SSL_ERROR_SYSCALL = 5; //look at error stack/return value/errno + SSL_ERROR_ZERO_RETURN = 6; + SSL_ERROR_WANT_CONNECT = 7; + SSL_ERROR_WANT_ACCEPT = 8; + + SSL_OP_NO_SSLv2 = $01000000; + SSL_OP_NO_SSLv3 = $02000000; + SSL_OP_NO_TLSv1 = $04000000; + SSL_OP_ALL = $000FFFFF; + SSL_VERIFY_NONE = $00; + SSL_VERIFY_PEER = $01; + + OPENSSL_DES_DECRYPT = 0; + OPENSSL_DES_ENCRYPT = 1; + + X509_V_OK = 0; + X509_V_ILLEGAL = 1; + X509_V_ERR_UNABLE_TO_GET_ISSUER_CERT = 2; + X509_V_ERR_UNABLE_TO_GET_CRL = 3; + X509_V_ERR_UNABLE_TO_DECRYPT_CERT_SIGNATURE = 4; + X509_V_ERR_UNABLE_TO_DECRYPT_CRL_SIGNATURE = 5; + X509_V_ERR_UNABLE_TO_DECODE_ISSUER_PUBLIC_KEY = 6; + X509_V_ERR_CERT_SIGNATURE_FAILURE = 7; + X509_V_ERR_CRL_SIGNATURE_FAILURE = 8; + X509_V_ERR_CERT_NOT_YET_VALID = 9; + X509_V_ERR_CERT_HAS_EXPIRED = 10; + X509_V_ERR_CRL_NOT_YET_VALID = 11; + X509_V_ERR_CRL_HAS_EXPIRED = 12; + X509_V_ERR_ERROR_IN_CERT_NOT_BEFORE_FIELD = 13; + X509_V_ERR_ERROR_IN_CERT_NOT_AFTER_FIELD = 14; + X509_V_ERR_ERROR_IN_CRL_LAST_UPDATE_FIELD = 15; + X509_V_ERR_ERROR_IN_CRL_NEXT_UPDATE_FIELD = 16; + X509_V_ERR_OUT_OF_MEM = 17; + X509_V_ERR_DEPTH_ZERO_SELF_SIGNED_CERT = 18; + X509_V_ERR_SELF_SIGNED_CERT_IN_CHAIN = 19; + X509_V_ERR_UNABLE_TO_GET_ISSUER_CERT_LOCALLY = 20; + X509_V_ERR_UNABLE_TO_VERIFY_LEAF_SIGNATURE = 21; + X509_V_ERR_CERT_CHAIN_TOO_LONG = 22; + X509_V_ERR_CERT_REVOKED = 23; + X509_V_ERR_INVALID_CA = 24; + X509_V_ERR_PATH_LENGTH_EXCEEDED = 25; + X509_V_ERR_INVALID_PURPOSE = 26; + X509_V_ERR_CERT_UNTRUSTED = 27; + X509_V_ERR_CERT_REJECTED = 28; + //These are 'informational' when looking for issuer cert + X509_V_ERR_SUBJECT_ISSUER_MISMATCH = 29; + X509_V_ERR_AKID_SKID_MISMATCH = 30; + X509_V_ERR_AKID_ISSUER_SERIAL_MISMATCH = 31; + X509_V_ERR_KEYUSAGE_NO_CERTSIGN = 32; + X509_V_ERR_UNABLE_TO_GET_CRL_ISSUER = 33; + X509_V_ERR_UNHANDLED_CRITICAL_EXTENSION = 34; + //The application is not happy + X509_V_ERR_APPLICATION_VERIFICATION = 50; + + SSL_FILETYPE_ASN1 = 2; + SSL_FILETYPE_PEM = 1; + EVP_PKEY_RSA = 6; + + SSL_CTRL_SET_TLSEXT_HOSTNAME = 55; + TLSEXT_NAMETYPE_host_name = 0; + +var + SSLLibHandle: TLibHandle = 0; + SSLUtilHandle: TLibHandle = 0; + SSLLibFile: string = ''; + SSLUtilFile: string = ''; + +{$IFDEF CIL} + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_get_error')] + function SslGetError(s: PSSL; ret_code: Integer): Integer; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_library_init')] + function SslLibraryInit: Integer; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_load_error_strings')] + procedure SslLoadErrorStrings; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_CTX_set_cipher_list')] + function SslCtxSetCipherList(arg0: PSSL_CTX; var str: String): Integer; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_CTX_new')] + function SslCtxNew(meth: PSSL_METHOD):PSSL_CTX; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_CTX_free')] + procedure SslCtxFree (arg0: PSSL_CTX); external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_set_fd')] + function SslSetFd(s: PSSL; fd: Integer):Integer; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSLv2_method')] + function SslMethodV2 : PSSL_METHOD; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSLv3_method')] + function SslMethodV3 : PSSL_METHOD; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'TLSv1_method')] + function SslMethodTLSV1:PSSL_METHOD; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSLv23_method')] + function SslMethodV23 : PSSL_METHOD; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_CTX_use_PrivateKey')] + function SslCtxUsePrivateKey(ctx: PSSL_CTX; pkey: SslPtr):Integer; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_CTX_use_PrivateKey_ASN1')] + function SslCtxUsePrivateKeyASN1(pk: integer; ctx: PSSL_CTX; d: String; len: integer):Integer; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_CTX_use_RSAPrivateKey_file')] + function SslCtxUsePrivateKeyFile(ctx: PSSL_CTX; const _file: String; _type: Integer):Integer; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_CTX_use_certificate')] + function SslCtxUseCertificate(ctx: PSSL_CTX; x: SslPtr):Integer; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_CTX_use_certificate_ASN1')] + function SslCtxUseCertificateASN1(ctx: PSSL_CTX; len: integer; d: String):Integer; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_CTX_use_certificate_file')] + function SslCtxUseCertificateFile(ctx: PSSL_CTX; const _file: String; _type: Integer):Integer;external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_CTX_use_certificate_chain_file')] + function SslCtxUseCertificateChainFile(ctx: PSSL_CTX; const _file: String):Integer;external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_CTX_check_private_key')] + function SslCtxCheckPrivateKeyFile(ctx: PSSL_CTX):Integer; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_CTX_set_default_passwd_cb')] + procedure SslCtxSetDefaultPasswdCb(ctx: PSSL_CTX; cb: PPasswdCb); external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_CTX_set_default_passwd_cb_userdata')] + procedure SslCtxSetDefaultPasswdCbUserdata(ctx: PSSL_CTX; u: IntPtr); external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_CTX_load_verify_locations')] + function SslCtxLoadVerifyLocations(ctx: PSSL_CTX; CAfile: string; CApath: String):Integer; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_CTX_ctrl')] + function SslCtxCtrl(ctx: PSSL_CTX; cmd: integer; larg: integer; parg: IntPtr): integer; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_new')] + function SslNew(ctx: PSSL_CTX):PSSL; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_free')] + procedure SslFree(ssl: PSSL); external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_accept')] + function SslAccept(ssl: PSSL):Integer; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_connect')] + function SslConnect(ssl: PSSL):Integer; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_shutdown')] + function SslShutdown(s: PSSL):Integer; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_read')] + function SslRead(ssl: PSSL; buf: StringBuilder; num: Integer):Integer; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_peek')] + function SslPeek(ssl: PSSL; buf: StringBuilder; num: Integer):Integer; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_write')] + function SslWrite(ssl: PSSL; buf: String; num: Integer):Integer; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_pending')] + function SslPending(ssl: PSSL):Integer; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_get_version')] + function SslGetVersion(ssl: PSSL):String; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_get_peer_certificate')] + function SslGetPeerCertificate(s: PSSL):PX509; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_CTX_set_verify')] + procedure SslCtxSetVerify(ctx: PSSL_CTX; mode: Integer; arg2: PFunction); external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_get_current_cipher')] + function SSLGetCurrentCipher(s: PSSL): SslPtr; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_CIPHER_get_name')] + function SSLCipherGetName(c: SslPtr):String; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_CIPHER_get_bits')] + function SSLCipherGetBits(c: SslPtr; var alg_bits: Integer):Integer; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_get_verify_result')] + function SSLGetVerifyResult(ssl: PSSL):Integer;external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_ctrl')] + function SslCtrl(ssl: PSSL; cmd: integer; larg: integer; parg: IntPtr): integer; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'X509_new')] + function X509New: PX509; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'X509_free')] + procedure X509Free(x: PX509); external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'X509_NAME_oneline')] + function X509NameOneline(a: PX509_NAME; buf: StringBuilder; size: Integer): String; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'X509_get_subject_name')] + function X509GetSubjectName(a: PX509):PX509_NAME; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'X509_get_issuer_name')] + function X509GetIssuerName(a: PX509):PX509_NAME; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'X509_NAME_hash')] + function X509NameHash(x: PX509_NAME):Cardinal; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'X509_digest')] + function X509Digest (data: PX509; _type: PEVP_MD; md: StringBuilder; var len: Integer):Integer; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'X509_set_version')] + function X509SetVersion(x: PX509; version: integer): integer; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'X509_set_pubkey')] + function X509SetPubkey(x: PX509; pkey: EVP_PKEY): integer; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'X509_set_issuer_name')] + function X509SetIssuerName(x: PX509; name: PX509_NAME): integer; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'X509_NAME_add_entry_by_txt')] + function X509NameAddEntryByTxt(name: PX509_NAME; field: string; _type: integer; + bytes: string; len, loc, _set: integer): integer; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'X509_sign')] + function X509Sign(x: PX509; pkey: EVP_PKEY; const md: PEVP_MD): integer; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'X509_print')] + function X509print(b: PBIO; a: PX509): integer; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'X509_gmtime_adj')] + function X509GmtimeAdj(s: PASN1_UTCTIME; adj: integer): PASN1_UTCTIME; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'X509_set_notBefore')] + function X509SetNotBefore(x: PX509; tm: PASN1_UTCTIME): integer; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'X509_set_notAfter')] + function X509SetNotAfter(x: PX509; tm: PASN1_UTCTIME): integer; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'X509_get_serialNumber')] + function X509GetSerialNumber(x: PX509): PASN1_INTEGER; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'EVP_PKEY_new')] + function EvpPkeyNew: EVP_PKEY; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'EVP_PKEY_free')] + procedure EvpPkeyFree(pk: EVP_PKEY); external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'EVP_PKEY_assign')] + function EvpPkeyAssign(pkey: EVP_PKEY; _type: integer; key: Prsa): integer; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'EVP_get_digestbyname')] + function EvpGetDigestByName(Name: String): PEVP_MD; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'EVP_cleanup')] + procedure EVPcleanup; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSLeay_version')] + function SSLeayversion(t: integer): String; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'ERR_error_string_n')] + procedure ErrErrorString(e: integer; buf: StringBuilder; len: integer); external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'ERR_get_error')] + function ErrGetError: integer; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'ERR_clear_error')] + procedure ErrClearError; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'ERR_free_strings')] + procedure ErrFreeStrings; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'ERR_remove_state')] + procedure ErrRemoveState(pid: integer); external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'OPENSSL_add_all_algorithms_noconf')] + procedure OPENSSLaddallalgorithms; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'CRYPTO_cleanup_all_ex_data')] + procedure CRYPTOcleanupAllExData; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'RAND_screen')] + procedure RandScreen; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'BIO_new')] + function BioNew(b: PBIO_METHOD): PBIO; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'BIO_free_all')] + procedure BioFreeAll(b: PBIO); external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'BIO_s_mem')] + function BioSMem: PBIO_METHOD; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'BIO_ctrl_pending')] + function BioCtrlPending(b: PBIO): integer; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'BIO_read')] + function BioRead(b: PBIO; Buf: StringBuilder; Len: integer): integer; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'BIO_write')] + function BioWrite(b: PBIO; var Buf: String; Len: integer): integer; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'd2i_PKCS12_bio')] + function d2iPKCS12bio(b:PBIO; Pkcs12: SslPtr): SslPtr; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'PKCS12_parse')] + function PKCS12parse(p12: SslPtr; pass: string; var pkey, cert, ca: SslPtr): integer; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'PKCS12_free')] + procedure PKCS12free(p12: SslPtr); external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'RSA_generate_key')] + function RsaGenerateKey(bits, e: integer; callback: PFunction; cb_arg: SslPtr): PRSA; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'ASN1_UTCTIME_new')] + function Asn1UtctimeNew: PASN1_UTCTIME; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'ASN1_UTCTIME_free')] + procedure Asn1UtctimeFree(a: PASN1_UTCTIME); external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'ASN1_INTEGER_set')] + function Asn1IntegerSet(a: PASN1_INTEGER; v: integer): integer; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'i2d_X509_bio')] + function i2dX509bio(b: PBIO; x: PX509): integer; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'i2d_PrivateKey_bio')] + function i2dPrivateKeyBio(b: PBIO; pkey: EVP_PKEY): integer; external; + + // 3DES functions + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'DES_set_odd_parity')] + procedure DESsetoddparity(Key: des_cblock); external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'DES_set_key_checked')] + function DESsetkeychecked(key: des_cblock; schedule: des_key_schedule): Integer; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'DES_ecb_encrypt')] + procedure DESecbencrypt(Input: des_cblock; output: des_cblock; ks: des_key_schedule; enc: Integer); external; + +{$ELSE} +// libssl.dll + function SslGetError(s: PSSL; ret_code: Integer):Integer; + function SslLibraryInit:Integer; + procedure SslLoadErrorStrings; +// function SslCtxSetCipherList(arg0: PSSL_CTX; str: PChar):Integer; + function SslCtxSetCipherList(arg0: PSSL_CTX; var str: AnsiString):Integer; + function SslCtxNew(meth: PSSL_METHOD):PSSL_CTX; + procedure SslCtxFree(arg0: PSSL_CTX); + function SslSetFd(s: PSSL; fd: Integer):Integer; + function SslMethodV2:PSSL_METHOD; + function SslMethodV3:PSSL_METHOD; + function SslMethodTLSV1:PSSL_METHOD; + function SslMethodV23:PSSL_METHOD; + function SslCtxUsePrivateKey(ctx: PSSL_CTX; pkey: SslPtr):Integer; + function SslCtxUsePrivateKeyASN1(pk: integer; ctx: PSSL_CTX; d: AnsiString; len: integer):Integer; +// function SslCtxUsePrivateKeyFile(ctx: PSSL_CTX; const _file: PChar; _type: Integer):Integer; + function SslCtxUsePrivateKeyFile(ctx: PSSL_CTX; const _file: AnsiString; _type: Integer):Integer; + function SslCtxUseCertificate(ctx: PSSL_CTX; x: SslPtr):Integer; + function SslCtxUseCertificateASN1(ctx: PSSL_CTX; len: integer; d: AnsiString):Integer; + function SslCtxUseCertificateFile(ctx: PSSL_CTX; const _file: AnsiString; _type: Integer):Integer; +// function SslCtxUseCertificateChainFile(ctx: PSSL_CTX; const _file: PChar):Integer; + function SslCtxUseCertificateChainFile(ctx: PSSL_CTX; const _file: AnsiString):Integer; + function SslCtxCheckPrivateKeyFile(ctx: PSSL_CTX):Integer; + procedure SslCtxSetDefaultPasswdCb(ctx: PSSL_CTX; cb: PPasswdCb); + procedure SslCtxSetDefaultPasswdCbUserdata(ctx: PSSL_CTX; u: SslPtr); +// function SslCtxLoadVerifyLocations(ctx: PSSL_CTX; const CAfile: PChar; const CApath: PChar):Integer; + function SslCtxLoadVerifyLocations(ctx: PSSL_CTX; const CAfile: AnsiString; const CApath: AnsiString):Integer; + function SslCtxCtrl(ctx: PSSL_CTX; cmd: integer; larg: integer; parg: SslPtr): integer; + function SslNew(ctx: PSSL_CTX):PSSL; + procedure SslFree(ssl: PSSL); + function SslAccept(ssl: PSSL):Integer; + function SslConnect(ssl: PSSL):Integer; + function SslShutdown(ssl: PSSL):Integer; + function SslRead(ssl: PSSL; buf: SslPtr; num: Integer):Integer; + function SslPeek(ssl: PSSL; buf: SslPtr; num: Integer):Integer; + function SslWrite(ssl: PSSL; buf: SslPtr; num: Integer):Integer; + function SslPending(ssl: PSSL):Integer; + function SslGetVersion(ssl: PSSL):AnsiString; + function SslGetPeerCertificate(ssl: PSSL):PX509; + procedure SslCtxSetVerify(ctx: PSSL_CTX; mode: Integer; arg2: PFunction); + function SSLGetCurrentCipher(s: PSSL):SslPtr; + function SSLCipherGetName(c: SslPtr): AnsiString; + function SSLCipherGetBits(c: SslPtr; var alg_bits: Integer):Integer; + function SSLGetVerifyResult(ssl: PSSL):Integer; + function SSLCtrl(ssl: PSSL; cmd: integer; larg: integer; parg: SslPtr):Integer; + +// libeay.dll + function X509New: PX509; + procedure X509Free(x: PX509); + function X509NameOneline(a: PX509_NAME; var buf: AnsiString; size: Integer):AnsiString; + function X509GetSubjectName(a: PX509):PX509_NAME; + function X509GetIssuerName(a: PX509):PX509_NAME; + function X509NameHash(x: PX509_NAME):Cardinal; +// function SslX509Digest(data: PX509; _type: PEVP_MD; md: PChar; len: PInteger):Integer; + function X509Digest(data: PX509; _type: PEVP_MD; md: AnsiString; var len: Integer):Integer; + function X509print(b: PBIO; a: PX509): integer; + function X509SetVersion(x: PX509; version: integer): integer; + function X509SetPubkey(x: PX509; pkey: EVP_PKEY): integer; + function X509SetIssuerName(x: PX509; name: PX509_NAME): integer; + function X509NameAddEntryByTxt(name: PX509_NAME; field: Ansistring; _type: integer; + bytes: Ansistring; len, loc, _set: integer): integer; + function X509Sign(x: PX509; pkey: EVP_PKEY; const md: PEVP_MD): integer; + function X509GmtimeAdj(s: PASN1_UTCTIME; adj: integer): PASN1_UTCTIME; + function X509SetNotBefore(x: PX509; tm: PASN1_UTCTIME): integer; + function X509SetNotAfter(x: PX509; tm: PASN1_UTCTIME): integer; + function X509GetSerialNumber(x: PX509): PASN1_INTEGER; + function EvpPkeyNew: EVP_PKEY; + procedure EvpPkeyFree(pk: EVP_PKEY); + function EvpPkeyAssign(pkey: EVP_PKEY; _type: integer; key: Prsa): integer; + function EvpGetDigestByName(Name: AnsiString): PEVP_MD; + procedure EVPcleanup; +// function ErrErrorString(e: integer; buf: PChar): PChar; + function SSLeayversion(t: integer): Ansistring; + procedure ErrErrorString(e: integer; var buf: Ansistring; len: integer); + function ErrGetError: integer; + procedure ErrClearError; + procedure ErrFreeStrings; + procedure ErrRemoveState(pid: integer); + procedure OPENSSLaddallalgorithms; + procedure CRYPTOcleanupAllExData; + procedure RandScreen; + function BioNew(b: PBIO_METHOD): PBIO; + procedure BioFreeAll(b: PBIO); + function BioSMem: PBIO_METHOD; + function BioCtrlPending(b: PBIO): integer; + function BioRead(b: PBIO; var Buf: AnsiString; Len: integer): integer; + function BioWrite(b: PBIO; Buf: AnsiString; Len: integer): integer; + function d2iPKCS12bio(b:PBIO; Pkcs12: SslPtr): SslPtr; + function PKCS12parse(p12: SslPtr; pass: Ansistring; var pkey, cert, ca: SslPtr): integer; + procedure PKCS12free(p12: SslPtr); + function RsaGenerateKey(bits, e: integer; callback: PFunction; cb_arg: SslPtr): PRSA; + function Asn1UtctimeNew: PASN1_UTCTIME; + procedure Asn1UtctimeFree(a: PASN1_UTCTIME); + function Asn1IntegerSet(a: PASN1_INTEGER; v: integer): integer; + function Asn1IntegerGet(a: PASN1_INTEGER): integer; {pf} + function i2dX509bio(b: PBIO; x: PX509): integer; + function d2iX509bio(b:PBIO; x:PX509): PX509; {pf} + function PEMReadBioX509(b:PBIO; {var x:PX509;}x:PSslPtr; callback:PFunction; cb_arg: SslPtr): PX509; {pf} + procedure SkX509PopFree(st: PSTACK; func: TSkPopFreeFunc); {pf} + + + function i2dPrivateKeyBio(b: PBIO; pkey: EVP_PKEY): integer; + + // 3DES functions + procedure DESsetoddparity(Key: des_cblock); + function DESsetkeychecked(key: des_cblock; schedule: des_key_schedule): Integer; + procedure DESecbencrypt(Input: des_cblock; output: des_cblock; ks: des_key_schedule; enc: Integer); + +{$ENDIF} + +function IsSSLloaded: Boolean; +function InitSSLInterface: Boolean; +function DestroySSLInterface: Boolean; + +var + _X509Free: TX509Free = nil; {pf} + +implementation + +uses SyncObjs; + +{$IFNDEF CIL} +type +// libssl.dll + TSslGetError = function(s: PSSL; ret_code: Integer):Integer; cdecl; + TSslLibraryInit = function:Integer; cdecl; + TSslLoadErrorStrings = procedure; cdecl; + TSslCtxSetCipherList = function(arg0: PSSL_CTX; str: PAnsiChar):Integer; cdecl; + TSslCtxNew = function(meth: PSSL_METHOD):PSSL_CTX; cdecl; + TSslCtxFree = procedure(arg0: PSSL_CTX); cdecl; + TSslSetFd = function(s: PSSL; fd: Integer):Integer; cdecl; + TSslMethodV2 = function:PSSL_METHOD; cdecl; + TSslMethodV3 = function:PSSL_METHOD; cdecl; + TSslMethodTLSV1 = function:PSSL_METHOD; cdecl; + TSslMethodV23 = function:PSSL_METHOD; cdecl; + TSslCtxUsePrivateKey = function(ctx: PSSL_CTX; pkey: sslptr):Integer; cdecl; + TSslCtxUsePrivateKeyASN1 = function(pk: integer; ctx: PSSL_CTX; d: sslptr; len: integer):Integer; cdecl; + TSslCtxUsePrivateKeyFile = function(ctx: PSSL_CTX; const _file: PAnsiChar; _type: Integer):Integer; cdecl; + TSslCtxUseCertificate = function(ctx: PSSL_CTX; x: SslPtr):Integer; cdecl; + TSslCtxUseCertificateASN1 = function(ctx: PSSL_CTX; len: Integer; d: SslPtr):Integer; cdecl; + TSslCtxUseCertificateFile = function(ctx: PSSL_CTX; const _file: PAnsiChar; _type: Integer):Integer; cdecl; + TSslCtxUseCertificateChainFile = function(ctx: PSSL_CTX; const _file: PAnsiChar):Integer; cdecl; + TSslCtxCheckPrivateKeyFile = function(ctx: PSSL_CTX):Integer; cdecl; + TSslCtxSetDefaultPasswdCb = procedure(ctx: PSSL_CTX; cb: SslPtr); cdecl; + TSslCtxSetDefaultPasswdCbUserdata = procedure(ctx: PSSL_CTX; u: SslPtr); cdecl; + TSslCtxLoadVerifyLocations = function(ctx: PSSL_CTX; const CAfile: PAnsiChar; const CApath: PAnsiChar):Integer; cdecl; + TSslCtxCtrl = function(ctx: PSSL_CTX; cmd: integer; larg: integer; parg: SslPtr): integer; cdecl; + TSslNew = function(ctx: PSSL_CTX):PSSL; cdecl; + TSslFree = procedure(ssl: PSSL); cdecl; + TSslAccept = function(ssl: PSSL):Integer; cdecl; + TSslConnect = function(ssl: PSSL):Integer; cdecl; + TSslShutdown = function(ssl: PSSL):Integer; cdecl; + TSslRead = function(ssl: PSSL; buf: PAnsiChar; num: Integer):Integer; cdecl; + TSslPeek = function(ssl: PSSL; buf: PAnsiChar; num: Integer):Integer; cdecl; + TSslWrite = function(ssl: PSSL; const buf: PAnsiChar; num: Integer):Integer; cdecl; + TSslPending = function(ssl: PSSL):Integer; cdecl; + TSslGetVersion = function(ssl: PSSL):PAnsiChar; cdecl; + TSslGetPeerCertificate = function(ssl: PSSL):PX509; cdecl; + TSslCtxSetVerify = procedure(ctx: PSSL_CTX; mode: Integer; arg2: SslPtr); cdecl; + TSSLGetCurrentCipher = function(s: PSSL):SslPtr; cdecl; + TSSLCipherGetName = function(c: Sslptr):PAnsiChar; cdecl; + TSSLCipherGetBits = function(c: SslPtr; alg_bits: PInteger):Integer; cdecl; + TSSLGetVerifyResult = function(ssl: PSSL):Integer; cdecl; + TSSLCtrl = function(ssl: PSSL; cmd: integer; larg: integer; parg: SslPtr):Integer; cdecl; + + TSSLSetTlsextHostName = function(ssl: PSSL; buf: PAnsiChar):Integer; cdecl; + +// libeay.dll + TX509New = function: PX509; cdecl; + TX509NameOneline = function(a: PX509_NAME; buf: PAnsiChar; size: Integer):PAnsiChar; cdecl; + TX509GetSubjectName = function(a: PX509):PX509_NAME; cdecl; + TX509GetIssuerName = function(a: PX509):PX509_NAME; cdecl; + TX509NameHash = function(x: PX509_NAME):Cardinal; cdecl; + TX509Digest = function(data: PX509; _type: PEVP_MD; md: PAnsiChar; len: PInteger):Integer; cdecl; + TX509print = function(b: PBIO; a: PX509): integer; cdecl; + TX509SetVersion = function(x: PX509; version: integer): integer; cdecl; + TX509SetPubkey = function(x: PX509; pkey: EVP_PKEY): integer; cdecl; + TX509SetIssuerName = function(x: PX509; name: PX509_NAME): integer; cdecl; + TX509NameAddEntryByTxt = function(name: PX509_NAME; field: PAnsiChar; _type: integer; + bytes: PAnsiChar; len, loc, _set: integer): integer; cdecl; + TX509Sign = function(x: PX509; pkey: EVP_PKEY; const md: PEVP_MD): integer; cdecl; + TX509GmtimeAdj = function(s: PASN1_UTCTIME; adj: integer): PASN1_UTCTIME; cdecl; + TX509SetNotBefore = function(x: PX509; tm: PASN1_UTCTIME): integer; cdecl; + TX509SetNotAfter = function(x: PX509; tm: PASN1_UTCTIME): integer; cdecl; + TX509GetSerialNumber = function(x: PX509): PASN1_INTEGER; cdecl; + TEvpPkeyNew = function: EVP_PKEY; cdecl; + TEvpPkeyFree = procedure(pk: EVP_PKEY); cdecl; + TEvpPkeyAssign = function(pkey: EVP_PKEY; _type: integer; key: Prsa): integer; cdecl; + TEvpGetDigestByName = function(Name: PAnsiChar): PEVP_MD; cdecl; + TEVPcleanup = procedure; cdecl; + TSSLeayversion = function(t: integer): PAnsiChar; cdecl; + TErrErrorString = procedure(e: integer; buf: PAnsiChar; len: integer); cdecl; + TErrGetError = function: integer; cdecl; + TErrClearError = procedure; cdecl; + TErrFreeStrings = procedure; cdecl; + TErrRemoveState = procedure(pid: integer); cdecl; + TOPENSSLaddallalgorithms = procedure; cdecl; + TCRYPTOcleanupAllExData = procedure; cdecl; + TRandScreen = procedure; cdecl; + TBioNew = function(b: PBIO_METHOD): PBIO; cdecl; + TBioFreeAll = procedure(b: PBIO); cdecl; + TBioSMem = function: PBIO_METHOD; cdecl; + TBioCtrlPending = function(b: PBIO): integer; cdecl; + TBioRead = function(b: PBIO; Buf: PAnsiChar; Len: integer): integer; cdecl; + TBioWrite = function(b: PBIO; Buf: PAnsiChar; Len: integer): integer; cdecl; + Td2iPKCS12bio = function(b:PBIO; Pkcs12: SslPtr): SslPtr; cdecl; + TPKCS12parse = function(p12: SslPtr; pass: PAnsiChar; var pkey, cert, ca: SslPtr): integer; cdecl; + TPKCS12free = procedure(p12: SslPtr); cdecl; + TRsaGenerateKey = function(bits, e: integer; callback: PFunction; cb_arg: SslPtr): PRSA; cdecl; + TAsn1UtctimeNew = function: PASN1_UTCTIME; cdecl; + TAsn1UtctimeFree = procedure(a: PASN1_UTCTIME); cdecl; + TAsn1IntegerSet = function(a: PASN1_INTEGER; v: integer): integer; cdecl; + TAsn1IntegerGet = function(a: PASN1_INTEGER): integer; cdecl; {pf} + Ti2dX509bio = function(b: PBIO; x: PX509): integer; cdecl; + Td2iX509bio = function(b:PBIO; x:PX509): PX509; cdecl; {pf} + TPEMReadBioX509 = function(b:PBIO; {var x:PX509;}x:PSslPtr; callback:PFunction; cb_arg:SslPtr): PX509; cdecl; {pf} + TSkX509PopFree = procedure(st: PSTACK; func: TSkPopFreeFunc); cdecl; {pf} + Ti2dPrivateKeyBio= function(b: PBIO; pkey: EVP_PKEY): integer; cdecl; + + // 3DES functions + TDESsetoddparity = procedure(Key: des_cblock); cdecl; + TDESsetkeychecked = function(key: des_cblock; schedule: des_key_schedule): Integer; cdecl; + TDESecbencrypt = procedure(Input: des_cblock; output: des_cblock; ks: des_key_schedule; enc: Integer); cdecl; + //thread lock functions + TCRYPTOnumlocks = function: integer; cdecl; + TCRYPTOSetLockingCallback = procedure(cb: Sslptr); cdecl; + +var +// libssl.dll + _SslGetError: TSslGetError = nil; + _SslLibraryInit: TSslLibraryInit = nil; + _SslLoadErrorStrings: TSslLoadErrorStrings = nil; + _SslCtxSetCipherList: TSslCtxSetCipherList = nil; + _SslCtxNew: TSslCtxNew = nil; + _SslCtxFree: TSslCtxFree = nil; + _SslSetFd: TSslSetFd = nil; + _SslMethodV2: TSslMethodV2 = nil; + _SslMethodV3: TSslMethodV3 = nil; + _SslMethodTLSV1: TSslMethodTLSV1 = nil; + _SslMethodV23: TSslMethodV23 = nil; + _SslCtxUsePrivateKey: TSslCtxUsePrivateKey = nil; + _SslCtxUsePrivateKeyASN1: TSslCtxUsePrivateKeyASN1 = nil; + _SslCtxUsePrivateKeyFile: TSslCtxUsePrivateKeyFile = nil; + _SslCtxUseCertificate: TSslCtxUseCertificate = nil; + _SslCtxUseCertificateASN1: TSslCtxUseCertificateASN1 = nil; + _SslCtxUseCertificateFile: TSslCtxUseCertificateFile = nil; + _SslCtxUseCertificateChainFile: TSslCtxUseCertificateChainFile = nil; + _SslCtxCheckPrivateKeyFile: TSslCtxCheckPrivateKeyFile = nil; + _SslCtxSetDefaultPasswdCb: TSslCtxSetDefaultPasswdCb = nil; + _SslCtxSetDefaultPasswdCbUserdata: TSslCtxSetDefaultPasswdCbUserdata = nil; + _SslCtxLoadVerifyLocations: TSslCtxLoadVerifyLocations = nil; + _SslCtxCtrl: TSslCtxCtrl = nil; + _SslNew: TSslNew = nil; + _SslFree: TSslFree = nil; + _SslAccept: TSslAccept = nil; + _SslConnect: TSslConnect = nil; + _SslShutdown: TSslShutdown = nil; + _SslRead: TSslRead = nil; + _SslPeek: TSslPeek = nil; + _SslWrite: TSslWrite = nil; + _SslPending: TSslPending = nil; + _SslGetVersion: TSslGetVersion = nil; + _SslGetPeerCertificate: TSslGetPeerCertificate = nil; + _SslCtxSetVerify: TSslCtxSetVerify = nil; + _SSLGetCurrentCipher: TSSLGetCurrentCipher = nil; + _SSLCipherGetName: TSSLCipherGetName = nil; + _SSLCipherGetBits: TSSLCipherGetBits = nil; + _SSLGetVerifyResult: TSSLGetVerifyResult = nil; + _SSLCtrl: TSSLCtrl = nil; + +// libeay.dll + _X509New: TX509New = nil; + _X509NameOneline: TX509NameOneline = nil; + _X509GetSubjectName: TX509GetSubjectName = nil; + _X509GetIssuerName: TX509GetIssuerName = nil; + _X509NameHash: TX509NameHash = nil; + _X509Digest: TX509Digest = nil; + _X509print: TX509print = nil; + _X509SetVersion: TX509SetVersion = nil; + _X509SetPubkey: TX509SetPubkey = nil; + _X509SetIssuerName: TX509SetIssuerName = nil; + _X509NameAddEntryByTxt: TX509NameAddEntryByTxt = nil; + _X509Sign: TX509Sign = nil; + _X509GmtimeAdj: TX509GmtimeAdj = nil; + _X509SetNotBefore: TX509SetNotBefore = nil; + _X509SetNotAfter: TX509SetNotAfter = nil; + _X509GetSerialNumber: TX509GetSerialNumber = nil; + _EvpPkeyNew: TEvpPkeyNew = nil; + _EvpPkeyFree: TEvpPkeyFree = nil; + _EvpPkeyAssign: TEvpPkeyAssign = nil; + _EvpGetDigestByName: TEvpGetDigestByName = nil; + _EVPcleanup: TEVPcleanup = nil; + _SSLeayversion: TSSLeayversion = nil; + _ErrErrorString: TErrErrorString = nil; + _ErrGetError: TErrGetError = nil; + _ErrClearError: TErrClearError = nil; + _ErrFreeStrings: TErrFreeStrings = nil; + _ErrRemoveState: TErrRemoveState = nil; + _OPENSSLaddallalgorithms: TOPENSSLaddallalgorithms = nil; + _CRYPTOcleanupAllExData: TCRYPTOcleanupAllExData = nil; + _RandScreen: TRandScreen = nil; + _BioNew: TBioNew = nil; + _BioFreeAll: TBioFreeAll = nil; + _BioSMem: TBioSMem = nil; + _BioCtrlPending: TBioCtrlPending = nil; + _BioRead: TBioRead = nil; + _BioWrite: TBioWrite = nil; + _d2iPKCS12bio: Td2iPKCS12bio = nil; + _PKCS12parse: TPKCS12parse = nil; + _PKCS12free: TPKCS12free = nil; + _RsaGenerateKey: TRsaGenerateKey = nil; + _Asn1UtctimeNew: TAsn1UtctimeNew = nil; + _Asn1UtctimeFree: TAsn1UtctimeFree = nil; + _Asn1IntegerSet: TAsn1IntegerSet = nil; + _Asn1IntegerGet: TAsn1IntegerGet = nil; {pf} + _i2dX509bio: Ti2dX509bio = nil; + _d2iX509bio: Td2iX509bio = nil; {pf} + _PEMReadBioX509: TPEMReadBioX509 = nil; {pf} + _SkX509PopFree: TSkX509PopFree = nil; {pf} + _i2dPrivateKeyBio: Ti2dPrivateKeyBio = nil; + + // 3DES functions + _DESsetoddparity: TDESsetoddparity = nil; + _DESsetkeychecked: TDESsetkeychecked = nil; + _DESecbencrypt: TDESecbencrypt = nil; + //thread lock functions + _CRYPTOnumlocks: TCRYPTOnumlocks = nil; + _CRYPTOSetLockingCallback: TCRYPTOSetLockingCallback = nil; +{$ENDIF} + +var + SSLCS: TCriticalSection; + SSLloaded: boolean = false; +{$IFNDEF CIL} + Locks: TList; +{$ENDIF} + +{$IFNDEF CIL} +// libssl.dll +function SslGetError(s: PSSL; ret_code: Integer):Integer; +begin + if InitSSLInterface and Assigned(_SslGetError) then + Result := _SslGetError(s, ret_code) + else + Result := SSL_ERROR_SSL; +end; + +function SslLibraryInit:Integer; +begin + if InitSSLInterface and Assigned(_SslLibraryInit) then + Result := _SslLibraryInit + else + Result := 1; +end; + +procedure SslLoadErrorStrings; +begin + if InitSSLInterface and Assigned(_SslLoadErrorStrings) then + _SslLoadErrorStrings; +end; + +//function SslCtxSetCipherList(arg0: PSSL_CTX; str: PChar):Integer; +function SslCtxSetCipherList(arg0: PSSL_CTX; var str: AnsiString):Integer; +begin + if InitSSLInterface and Assigned(_SslCtxSetCipherList) then + Result := _SslCtxSetCipherList(arg0, PAnsiChar(str)) + else + Result := 0; +end; + +function SslCtxNew(meth: PSSL_METHOD):PSSL_CTX; +begin + if InitSSLInterface and Assigned(_SslCtxNew) then + Result := _SslCtxNew(meth) + else + Result := nil; +end; + +procedure SslCtxFree(arg0: PSSL_CTX); +begin + if InitSSLInterface and Assigned(_SslCtxFree) then + _SslCtxFree(arg0); +end; + +function SslSetFd(s: PSSL; fd: Integer):Integer; +begin + if InitSSLInterface and Assigned(_SslSetFd) then + Result := _SslSetFd(s, fd) + else + Result := 0; +end; + +function SslMethodV2:PSSL_METHOD; +begin + if InitSSLInterface and Assigned(_SslMethodV2) then + Result := _SslMethodV2 + else + Result := nil; +end; + +function SslMethodV3:PSSL_METHOD; +begin + if InitSSLInterface and Assigned(_SslMethodV3) then + Result := _SslMethodV3 + else + Result := nil; +end; + +function SslMethodTLSV1:PSSL_METHOD; +begin + if InitSSLInterface and Assigned(_SslMethodTLSV1) then + Result := _SslMethodTLSV1 + else + Result := nil; +end; + +function SslMethodV23:PSSL_METHOD; +begin + if InitSSLInterface and Assigned(_SslMethodV23) then + Result := _SslMethodV23 + else + Result := nil; +end; + +function SslCtxUsePrivateKey(ctx: PSSL_CTX; pkey: SslPtr):Integer; +begin + if InitSSLInterface and Assigned(_SslCtxUsePrivateKey) then + Result := _SslCtxUsePrivateKey(ctx, pkey) + else + Result := 0; +end; + +function SslCtxUsePrivateKeyASN1(pk: integer; ctx: PSSL_CTX; d: AnsiString; len: integer):Integer; +begin + if InitSSLInterface and Assigned(_SslCtxUsePrivateKeyASN1) then + Result := _SslCtxUsePrivateKeyASN1(pk, ctx, Sslptr(d), len) + else + Result := 0; +end; + +//function SslCtxUsePrivateKeyFile(ctx: PSSL_CTX; const _file: PChar; _type: Integer):Integer; +function SslCtxUsePrivateKeyFile(ctx: PSSL_CTX; const _file: AnsiString; _type: Integer):Integer; +begin + if InitSSLInterface and Assigned(_SslCtxUsePrivateKeyFile) then + Result := _SslCtxUsePrivateKeyFile(ctx, PAnsiChar(_file), _type) + else + Result := 0; +end; + +function SslCtxUseCertificate(ctx: PSSL_CTX; x: SslPtr):Integer; +begin + if InitSSLInterface and Assigned(_SslCtxUseCertificate) then + Result := _SslCtxUseCertificate(ctx, x) + else + Result := 0; +end; + +function SslCtxUseCertificateASN1(ctx: PSSL_CTX; len: integer; d: AnsiString):Integer; +begin + if InitSSLInterface and Assigned(_SslCtxUseCertificateASN1) then + Result := _SslCtxUseCertificateASN1(ctx, len, SslPtr(d)) + else + Result := 0; +end; + +function SslCtxUseCertificateFile(ctx: PSSL_CTX; const _file: AnsiString; _type: Integer):Integer; +begin + if InitSSLInterface and Assigned(_SslCtxUseCertificateFile) then + Result := _SslCtxUseCertificateFile(ctx, PAnsiChar(_file), _type) + else + Result := 0; +end; + +//function SslCtxUseCertificateChainFile(ctx: PSSL_CTX; const _file: PChar):Integer; +function SslCtxUseCertificateChainFile(ctx: PSSL_CTX; const _file: AnsiString):Integer; +begin + if InitSSLInterface and Assigned(_SslCtxUseCertificateChainFile) then + Result := _SslCtxUseCertificateChainFile(ctx, PAnsiChar(_file)) + else + Result := 0; +end; + +function SslCtxCheckPrivateKeyFile(ctx: PSSL_CTX):Integer; +begin + if InitSSLInterface and Assigned(_SslCtxCheckPrivateKeyFile) then + Result := _SslCtxCheckPrivateKeyFile(ctx) + else + Result := 0; +end; + +procedure SslCtxSetDefaultPasswdCb(ctx: PSSL_CTX; cb: PPasswdCb); +begin + if InitSSLInterface and Assigned(_SslCtxSetDefaultPasswdCb) then + _SslCtxSetDefaultPasswdCb(ctx, cb); +end; + +procedure SslCtxSetDefaultPasswdCbUserdata(ctx: PSSL_CTX; u: SslPtr); +begin + if InitSSLInterface and Assigned(_SslCtxSetDefaultPasswdCbUserdata) then + _SslCtxSetDefaultPasswdCbUserdata(ctx, u); +end; + +//function SslCtxLoadVerifyLocations(ctx: PSSL_CTX; const CAfile: PChar; const CApath: PChar):Integer; +function SslCtxLoadVerifyLocations(ctx: PSSL_CTX; const CAfile: AnsiString; const CApath: AnsiString):Integer; +begin + if InitSSLInterface and Assigned(_SslCtxLoadVerifyLocations) then + Result := _SslCtxLoadVerifyLocations(ctx, SslPtr(CAfile), SslPtr(CApath)) + else + Result := 0; +end; + +function SslCtxCtrl(ctx: PSSL_CTX; cmd: integer; larg: integer; parg: SslPtr): integer; +begin + if InitSSLInterface and Assigned(_SslCtxCtrl) then + Result := _SslCtxCtrl(ctx, cmd, larg, parg) + else + Result := 0; +end; + +function SslNew(ctx: PSSL_CTX):PSSL; +begin + if InitSSLInterface and Assigned(_SslNew) then + Result := _SslNew(ctx) + else + Result := nil; +end; + +procedure SslFree(ssl: PSSL); +begin + if InitSSLInterface and Assigned(_SslFree) then + _SslFree(ssl); +end; + +function SslAccept(ssl: PSSL):Integer; +begin + if InitSSLInterface and Assigned(_SslAccept) then + Result := _SslAccept(ssl) + else + Result := -1; +end; + +function SslConnect(ssl: PSSL):Integer; +begin + if InitSSLInterface and Assigned(_SslConnect) then + Result := _SslConnect(ssl) + else + Result := -1; +end; + +function SslShutdown(ssl: PSSL):Integer; +begin + if InitSSLInterface and Assigned(_SslShutdown) then + Result := _SslShutdown(ssl) + else + Result := -1; +end; + +//function SslRead(ssl: PSSL; buf: PChar; num: Integer):Integer; +function SslRead(ssl: PSSL; buf: SslPtr; num: Integer):Integer; +begin + if InitSSLInterface and Assigned(_SslRead) then + Result := _SslRead(ssl, PAnsiChar(buf), num) + else + Result := -1; +end; + +//function SslPeek(ssl: PSSL; buf: PChar; num: Integer):Integer; +function SslPeek(ssl: PSSL; buf: SslPtr; num: Integer):Integer; +begin + if InitSSLInterface and Assigned(_SslPeek) then + Result := _SslPeek(ssl, PAnsiChar(buf), num) + else + Result := -1; +end; + +//function SslWrite(ssl: PSSL; const buf: PChar; num: Integer):Integer; +function SslWrite(ssl: PSSL; buf: SslPtr; num: Integer):Integer; +begin + if InitSSLInterface and Assigned(_SslWrite) then + Result := _SslWrite(ssl, PAnsiChar(buf), num) + else + Result := -1; +end; + +function SslPending(ssl: PSSL):Integer; +begin + if InitSSLInterface and Assigned(_SslPending) then + Result := _SslPending(ssl) + else + Result := 0; +end; + +//function SslGetVersion(ssl: PSSL):PChar; +function SslGetVersion(ssl: PSSL):AnsiString; +begin + if InitSSLInterface and Assigned(_SslGetVersion) then + Result := _SslGetVersion(ssl) + else + Result := ''; +end; + +function SslGetPeerCertificate(ssl: PSSL):PX509; +begin + if InitSSLInterface and Assigned(_SslGetPeerCertificate) then + Result := _SslGetPeerCertificate(ssl) + else + Result := nil; +end; + +//procedure SslCtxSetVerify(ctx: PSSL_CTX; mode: Integer; arg2: SslPtr); +procedure SslCtxSetVerify(ctx: PSSL_CTX; mode: Integer; arg2: PFunction); +begin + if InitSSLInterface and Assigned(_SslCtxSetVerify) then + _SslCtxSetVerify(ctx, mode, @arg2); +end; + +function SSLGetCurrentCipher(s: PSSL):SslPtr; +begin + if InitSSLInterface and Assigned(_SSLGetCurrentCipher) then +{$IFDEF CIL} +{$ELSE} + Result := _SSLGetCurrentCipher(s) +{$ENDIF} + else + Result := nil; +end; + +//function SSLCipherGetName(c: SslPtr):PChar; +function SSLCipherGetName(c: SslPtr):AnsiString; +begin + if InitSSLInterface and Assigned(_SSLCipherGetName) then + Result := _SSLCipherGetName(c) + else + Result := ''; +end; + +//function SSLCipherGetBits(c: SslPtr; alg_bits: PInteger):Integer; +function SSLCipherGetBits(c: SslPtr; var alg_bits: Integer):Integer; +begin + if InitSSLInterface and Assigned(_SSLCipherGetBits) then + Result := _SSLCipherGetBits(c, @alg_bits) + else + Result := 0; +end; + +function SSLGetVerifyResult(ssl: PSSL):Integer; +begin + if InitSSLInterface and Assigned(_SSLGetVerifyResult) then + Result := _SSLGetVerifyResult(ssl) + else + Result := X509_V_ERR_APPLICATION_VERIFICATION; +end; + + +function SSLCtrl(ssl: PSSL; cmd: integer; larg: integer; parg: SslPtr):Integer; +begin + if InitSSLInterface and Assigned(_SSLCtrl) then + Result := _SSLCtrl(ssl, cmd, larg, parg) + else + Result := X509_V_ERR_APPLICATION_VERIFICATION; +end; + +// libeay.dll +function X509New: PX509; +begin + if InitSSLInterface and Assigned(_X509New) then + Result := _X509New + else + Result := nil; +end; + +procedure X509Free(x: PX509); +begin + if InitSSLInterface and Assigned(_X509Free) then + _X509Free(x); +end; + +//function SslX509NameOneline(a: PX509_NAME; buf: PChar; size: Integer):PChar; +function X509NameOneline(a: PX509_NAME; var buf: AnsiString; size: Integer):AnsiString; +begin + if InitSSLInterface and Assigned(_X509NameOneline) then + Result := _X509NameOneline(a, PAnsiChar(buf),size) + else + Result := ''; +end; + +function X509GetSubjectName(a: PX509):PX509_NAME; +begin + if InitSSLInterface and Assigned(_X509GetSubjectName) then + Result := _X509GetSubjectName(a) + else + Result := nil; +end; + +function X509GetIssuerName(a: PX509):PX509_NAME; +begin + if InitSSLInterface and Assigned(_X509GetIssuerName) then + Result := _X509GetIssuerName(a) + else + Result := nil; +end; + +function X509NameHash(x: PX509_NAME):Cardinal; +begin + if InitSSLInterface and Assigned(_X509NameHash) then + Result := _X509NameHash(x) + else + Result := 0; +end; + +//function SslX509Digest(data: PX509; _type: PEVP_MD; md: PChar; len: PInteger):Integer; +function X509Digest(data: PX509; _type: PEVP_MD; md: AnsiString; var len: Integer):Integer; +begin + if InitSSLInterface and Assigned(_X509Digest) then + Result := _X509Digest(data, _type, PAnsiChar(md), @len) + else + Result := 0; +end; + +function EvpPkeyNew: EVP_PKEY; +begin + if InitSSLInterface and Assigned(_EvpPkeyNew) then + Result := _EvpPkeyNew + else + Result := nil; +end; + +procedure EvpPkeyFree(pk: EVP_PKEY); +begin + if InitSSLInterface and Assigned(_EvpPkeyFree) then + _EvpPkeyFree(pk); +end; + +function SSLeayversion(t: integer): Ansistring; +begin + if InitSSLInterface and Assigned(_SSLeayversion) then + Result := PAnsiChar(_SSLeayversion(t)) + else + Result := ''; +end; + +procedure ErrErrorString(e: integer; var buf: Ansistring; len: integer); +begin + if InitSSLInterface and Assigned(_ErrErrorString) then + _ErrErrorString(e, Pointer(buf), len); + buf := PAnsiChar(Buf); +end; + +function ErrGetError: integer; +begin + if InitSSLInterface and Assigned(_ErrGetError) then + Result := _ErrGetError + else + Result := SSL_ERROR_SSL; +end; + +procedure ErrClearError; +begin + if InitSSLInterface and Assigned(_ErrClearError) then + _ErrClearError; +end; + +procedure ErrFreeStrings; +begin + if InitSSLInterface and Assigned(_ErrFreeStrings) then + _ErrFreeStrings; +end; + +procedure ErrRemoveState(pid: integer); +begin + if InitSSLInterface and Assigned(_ErrRemoveState) then + _ErrRemoveState(pid); +end; + +procedure OPENSSLaddallalgorithms; +begin + if InitSSLInterface and Assigned(_OPENSSLaddallalgorithms) then + _OPENSSLaddallalgorithms; +end; + +procedure EVPcleanup; +begin + if InitSSLInterface and Assigned(_EVPcleanup) then + _EVPcleanup; +end; + +procedure CRYPTOcleanupAllExData; +begin + if InitSSLInterface and Assigned(_CRYPTOcleanupAllExData) then + _CRYPTOcleanupAllExData; +end; + +procedure RandScreen; +begin + if InitSSLInterface and Assigned(_RandScreen) then + _RandScreen; +end; + +function BioNew(b: PBIO_METHOD): PBIO; +begin + if InitSSLInterface and Assigned(_BioNew) then + Result := _BioNew(b) + else + Result := nil; +end; + +procedure BioFreeAll(b: PBIO); +begin + if InitSSLInterface and Assigned(_BioFreeAll) then + _BioFreeAll(b); +end; + +function BioSMem: PBIO_METHOD; +begin + if InitSSLInterface and Assigned(_BioSMem) then + Result := _BioSMem + else + Result := nil; +end; + +function BioCtrlPending(b: PBIO): integer; +begin + if InitSSLInterface and Assigned(_BioCtrlPending) then + Result := _BioCtrlPending(b) + else + Result := 0; +end; + +//function BioRead(b: PBIO; Buf: PChar; Len: integer): integer; +function BioRead(b: PBIO; var Buf: AnsiString; Len: integer): integer; +begin + if InitSSLInterface and Assigned(_BioRead) then + Result := _BioRead(b, PAnsiChar(Buf), Len) + else + Result := -2; +end; + +//function BioWrite(b: PBIO; Buf: PChar; Len: integer): integer; +function BioWrite(b: PBIO; Buf: AnsiString; Len: integer): integer; +begin + if InitSSLInterface and Assigned(_BioWrite) then + Result := _BioWrite(b, PAnsiChar(Buf), Len) + else + Result := -2; +end; + +function X509print(b: PBIO; a: PX509): integer; +begin + if InitSSLInterface and Assigned(_X509print) then + Result := _X509print(b, a) + else + Result := 0; +end; + +function d2iPKCS12bio(b:PBIO; Pkcs12: SslPtr): SslPtr; +begin + if InitSSLInterface and Assigned(_d2iPKCS12bio) then + Result := _d2iPKCS12bio(b, Pkcs12) + else + Result := nil; +end; + +function PKCS12parse(p12: SslPtr; pass: Ansistring; var pkey, cert, ca: SslPtr): integer; +begin + if InitSSLInterface and Assigned(_PKCS12parse) then + Result := _PKCS12parse(p12, SslPtr(pass), pkey, cert, ca) + else + Result := 0; +end; + +procedure PKCS12free(p12: SslPtr); +begin + if InitSSLInterface and Assigned(_PKCS12free) then + _PKCS12free(p12); +end; + +function RsaGenerateKey(bits, e: integer; callback: PFunction; cb_arg: SslPtr): PRSA; +begin + if InitSSLInterface and Assigned(_RsaGenerateKey) then + Result := _RsaGenerateKey(bits, e, callback, cb_arg) + else + Result := nil; +end; + +function EvpPkeyAssign(pkey: EVP_PKEY; _type: integer; key: Prsa): integer; +begin + if InitSSLInterface and Assigned(_EvpPkeyAssign) then + Result := _EvpPkeyAssign(pkey, _type, key) + else + Result := 0; +end; + +function X509SetVersion(x: PX509; version: integer): integer; +begin + if InitSSLInterface and Assigned(_X509SetVersion) then + Result := _X509SetVersion(x, version) + else + Result := 0; +end; + +function X509SetPubkey(x: PX509; pkey: EVP_PKEY): integer; +begin + if InitSSLInterface and Assigned(_X509SetPubkey) then + Result := _X509SetPubkey(x, pkey) + else + Result := 0; +end; + +function X509SetIssuerName(x: PX509; name: PX509_NAME): integer; +begin + if InitSSLInterface and Assigned(_X509SetIssuerName) then + Result := _X509SetIssuerName(x, name) + else + Result := 0; +end; + +function X509NameAddEntryByTxt(name: PX509_NAME; field: Ansistring; _type: integer; + bytes: Ansistring; len, loc, _set: integer): integer; +begin + if InitSSLInterface and Assigned(_X509NameAddEntryByTxt) then + Result := _X509NameAddEntryByTxt(name, PAnsiChar(field), _type, PAnsiChar(Bytes), len, loc, _set) + else + Result := 0; +end; + +function X509Sign(x: PX509; pkey: EVP_PKEY; const md: PEVP_MD): integer; +begin + if InitSSLInterface and Assigned(_X509Sign) then + Result := _X509Sign(x, pkey, md) + else + Result := 0; +end; + +function Asn1UtctimeNew: PASN1_UTCTIME; +begin + if InitSSLInterface and Assigned(_Asn1UtctimeNew) then + Result := _Asn1UtctimeNew + else + Result := nil; +end; + +procedure Asn1UtctimeFree(a: PASN1_UTCTIME); +begin + if InitSSLInterface and Assigned(_Asn1UtctimeFree) then + _Asn1UtctimeFree(a); +end; + +function X509GmtimeAdj(s: PASN1_UTCTIME; adj: integer): PASN1_UTCTIME; +begin + if InitSSLInterface and Assigned(_X509GmtimeAdj) then + Result := _X509GmtimeAdj(s, adj) + else + Result := nil; +end; + +function X509SetNotBefore(x: PX509; tm: PASN1_UTCTIME): integer; +begin + if InitSSLInterface and Assigned(_X509SetNotBefore) then + Result := _X509SetNotBefore(x, tm) + else + Result := 0; +end; + +function X509SetNotAfter(x: PX509; tm: PASN1_UTCTIME): integer; +begin + if InitSSLInterface and Assigned(_X509SetNotAfter) then + Result := _X509SetNotAfter(x, tm) + else + Result := 0; +end; + +function i2dX509bio(b: PBIO; x: PX509): integer; +begin + if InitSSLInterface and Assigned(_i2dX509bio) then + Result := _i2dX509bio(b, x) + else + Result := 0; +end; + +function d2iX509bio(b: PBIO; x: PX509): PX509; {pf} +begin + if InitSSLInterface and Assigned(_d2iX509bio) then + Result := _d2iX509bio(x,b) + else + Result := nil; +end; + +function PEMReadBioX509(b:PBIO; {var x:PX509;}x:PSslPtr; callback:PFunction; cb_arg: SslPtr): PX509; {pf} +begin + if InitSSLInterface and Assigned(_PEMReadBioX509) then + Result := _PEMReadBioX509(b,x,callback,cb_arg) + else + Result := nil; +end; + +procedure SkX509PopFree(st: PSTACK; func:TSkPopFreeFunc); {pf} +begin + if InitSSLInterface and Assigned(_SkX509PopFree) then + _SkX509PopFree(st,func); +end; + +function i2dPrivateKeyBio(b: PBIO; pkey: EVP_PKEY): integer; +begin + if InitSSLInterface and Assigned(_i2dPrivateKeyBio) then + Result := _i2dPrivateKeyBio(b, pkey) + else + Result := 0; +end; + +function EvpGetDigestByName(Name: AnsiString): PEVP_MD; +begin + if InitSSLInterface and Assigned(_EvpGetDigestByName) then + Result := _EvpGetDigestByName(PAnsiChar(Name)) + else + Result := nil; +end; + +function Asn1IntegerSet(a: PASN1_INTEGER; v: integer): integer; +begin + if InitSSLInterface and Assigned(_Asn1IntegerSet) then + Result := _Asn1IntegerSet(a, v) + else + Result := 0; +end; + +function Asn1IntegerGet(a: PASN1_INTEGER): integer; {pf} +begin + if InitSSLInterface and Assigned(_Asn1IntegerGet) then + Result := _Asn1IntegerGet(a) + else + Result := 0; +end; + +function X509GetSerialNumber(x: PX509): PASN1_INTEGER; +begin + if InitSSLInterface and Assigned(_X509GetSerialNumber) then + Result := _X509GetSerialNumber(x) + else + Result := nil; +end; + +// 3DES functions +procedure DESsetoddparity(Key: des_cblock); +begin + if InitSSLInterface and Assigned(_DESsetoddparity) then + _DESsetoddparity(Key); +end; + +function DESsetkeychecked(key: des_cblock; schedule: des_key_schedule): Integer; +begin + if InitSSLInterface and Assigned(_DESsetkeychecked) then + Result := _DESsetkeychecked(key, schedule) + else + Result := -1; +end; + +procedure DESecbencrypt(Input: des_cblock; output: des_cblock; ks: des_key_schedule; enc: Integer); +begin + if InitSSLInterface and Assigned(_DESecbencrypt) then + _DESecbencrypt(Input, output, ks, enc); +end; + +procedure locking_callback(mode, ltype: integer; lfile: PChar; line: integer); cdecl; +begin + if (mode and 1) > 0 then + TCriticalSection(Locks[ltype]).Enter + else + TCriticalSection(Locks[ltype]).Leave; +end; + +procedure InitLocks; +var + n: integer; + max: integer; +begin + Locks := TList.Create; + max := _CRYPTOnumlocks; + for n := 1 to max do + Locks.Add(TCriticalSection.Create); + _CRYPTOsetlockingcallback(@locking_callback); +end; + +procedure FreeLocks; +var + n: integer; +begin + _CRYPTOsetlockingcallback(nil); + for n := 0 to Locks.Count - 1 do + TCriticalSection(Locks[n]).Free; + Locks.Free; +end; + +{$ENDIF} + +function LoadLib(const Value: String): HModule; +begin +{$IFDEF CIL} + Result := LoadLibrary(Value); +{$ELSE} + Result := LoadLibrary(PChar(Value)); +{$ENDIF} +end; + +function GetProcAddr(module: HModule; const ProcName: string): SslPtr; +begin +{$IFDEF CIL} + Result := GetProcAddress(module, ProcName); +{$ELSE} + Result := GetProcAddress(module, PChar(ProcName)); +{$ENDIF} +end; + +function InitSSLInterface: Boolean; +var + s: string; + x: integer; +begin + {pf} + if SSLLoaded then + begin + Result := TRUE; + exit; + end; + {/pf} + SSLCS.Enter; + try + if not IsSSLloaded then + begin +{$IFDEF CIL} + SSLLibHandle := 1; + SSLUtilHandle := 1; +{$ELSE} + SSLLibHandle := LoadLib(DLLSSLName); + SSLUtilHandle := LoadLib(DLLUtilName); + {$IFDEF MSWINDOWS} + if (SSLLibHandle = 0) then + SSLLibHandle := LoadLib(DLLSSLName2); + {$ENDIF} +{$ENDIF} + if (SSLLibHandle <> 0) and (SSLUtilHandle <> 0) then + begin +{$IFNDEF CIL} + _SslGetError := GetProcAddr(SSLLibHandle, 'SSL_get_error'); + _SslLibraryInit := GetProcAddr(SSLLibHandle, 'SSL_library_init'); + _SslLoadErrorStrings := GetProcAddr(SSLLibHandle, 'SSL_load_error_strings'); + _SslCtxSetCipherList := GetProcAddr(SSLLibHandle, 'SSL_CTX_set_cipher_list'); + _SslCtxNew := GetProcAddr(SSLLibHandle, 'SSL_CTX_new'); + _SslCtxFree := GetProcAddr(SSLLibHandle, 'SSL_CTX_free'); + _SslSetFd := GetProcAddr(SSLLibHandle, 'SSL_set_fd'); + _SslMethodV2 := GetProcAddr(SSLLibHandle, 'SSLv2_method'); + _SslMethodV3 := GetProcAddr(SSLLibHandle, 'SSLv3_method'); + _SslMethodTLSV1 := GetProcAddr(SSLLibHandle, 'TLSv1_method'); + _SslMethodV23 := GetProcAddr(SSLLibHandle, 'SSLv23_method'); + _SslCtxUsePrivateKey := GetProcAddr(SSLLibHandle, 'SSL_CTX_use_PrivateKey'); + _SslCtxUsePrivateKeyASN1 := GetProcAddr(SSLLibHandle, 'SSL_CTX_use_PrivateKey_ASN1'); + //use SSL_CTX_use_RSAPrivateKey_file instead SSL_CTX_use_PrivateKey_file, + //because SSL_CTX_use_PrivateKey_file not support DER format. :-O + _SslCtxUsePrivateKeyFile := GetProcAddr(SSLLibHandle, 'SSL_CTX_use_RSAPrivateKey_file'); + _SslCtxUseCertificate := GetProcAddr(SSLLibHandle, 'SSL_CTX_use_certificate'); + _SslCtxUseCertificateASN1 := GetProcAddr(SSLLibHandle, 'SSL_CTX_use_certificate_ASN1'); + _SslCtxUseCertificateFile := GetProcAddr(SSLLibHandle, 'SSL_CTX_use_certificate_file'); + _SslCtxUseCertificateChainFile := GetProcAddr(SSLLibHandle, 'SSL_CTX_use_certificate_chain_file'); + _SslCtxCheckPrivateKeyFile := GetProcAddr(SSLLibHandle, 'SSL_CTX_check_private_key'); + _SslCtxSetDefaultPasswdCb := GetProcAddr(SSLLibHandle, 'SSL_CTX_set_default_passwd_cb'); + _SslCtxSetDefaultPasswdCbUserdata := GetProcAddr(SSLLibHandle, 'SSL_CTX_set_default_passwd_cb_userdata'); + _SslCtxLoadVerifyLocations := GetProcAddr(SSLLibHandle, 'SSL_CTX_load_verify_locations'); + _SslCtxCtrl := GetProcAddr(SSLLibHandle, 'SSL_CTX_ctrl'); + _SslNew := GetProcAddr(SSLLibHandle, 'SSL_new'); + _SslFree := GetProcAddr(SSLLibHandle, 'SSL_free'); + _SslAccept := GetProcAddr(SSLLibHandle, 'SSL_accept'); + _SslConnect := GetProcAddr(SSLLibHandle, 'SSL_connect'); + _SslShutdown := GetProcAddr(SSLLibHandle, 'SSL_shutdown'); + _SslRead := GetProcAddr(SSLLibHandle, 'SSL_read'); + _SslPeek := GetProcAddr(SSLLibHandle, 'SSL_peek'); + _SslWrite := GetProcAddr(SSLLibHandle, 'SSL_write'); + _SslPending := GetProcAddr(SSLLibHandle, 'SSL_pending'); + _SslGetPeerCertificate := GetProcAddr(SSLLibHandle, 'SSL_get_peer_certificate'); + _SslGetVersion := GetProcAddr(SSLLibHandle, 'SSL_get_version'); + _SslCtxSetVerify := GetProcAddr(SSLLibHandle, 'SSL_CTX_set_verify'); + _SslGetCurrentCipher := GetProcAddr(SSLLibHandle, 'SSL_get_current_cipher'); + _SslCipherGetName := GetProcAddr(SSLLibHandle, 'SSL_CIPHER_get_name'); + _SslCipherGetBits := GetProcAddr(SSLLibHandle, 'SSL_CIPHER_get_bits'); + _SslGetVerifyResult := GetProcAddr(SSLLibHandle, 'SSL_get_verify_result'); + _SslCtrl := GetProcAddr(SSLLibHandle, 'SSL_ctrl'); + + _X509New := GetProcAddr(SSLUtilHandle, 'X509_new'); + _X509Free := GetProcAddr(SSLUtilHandle, 'X509_free'); + _X509NameOneline := GetProcAddr(SSLUtilHandle, 'X509_NAME_oneline'); + _X509GetSubjectName := GetProcAddr(SSLUtilHandle, 'X509_get_subject_name'); + _X509GetIssuerName := GetProcAddr(SSLUtilHandle, 'X509_get_issuer_name'); + _X509NameHash := GetProcAddr(SSLUtilHandle, 'X509_NAME_hash'); + _X509Digest := GetProcAddr(SSLUtilHandle, 'X509_digest'); + _X509print := GetProcAddr(SSLUtilHandle, 'X509_print'); + _X509SetVersion := GetProcAddr(SSLUtilHandle, 'X509_set_version'); + _X509SetPubkey := GetProcAddr(SSLUtilHandle, 'X509_set_pubkey'); + _X509SetIssuerName := GetProcAddr(SSLUtilHandle, 'X509_set_issuer_name'); + _X509NameAddEntryByTxt := GetProcAddr(SSLUtilHandle, 'X509_NAME_add_entry_by_txt'); + _X509Sign := GetProcAddr(SSLUtilHandle, 'X509_sign'); + _X509GmtimeAdj := GetProcAddr(SSLUtilHandle, 'X509_gmtime_adj'); + _X509SetNotBefore := GetProcAddr(SSLUtilHandle, 'X509_set_notBefore'); + _X509SetNotAfter := GetProcAddr(SSLUtilHandle, 'X509_set_notAfter'); + _X509GetSerialNumber := GetProcAddr(SSLUtilHandle, 'X509_get_serialNumber'); + _EvpPkeyNew := GetProcAddr(SSLUtilHandle, 'EVP_PKEY_new'); + _EvpPkeyFree := GetProcAddr(SSLUtilHandle, 'EVP_PKEY_free'); + _EvpPkeyAssign := GetProcAddr(SSLUtilHandle, 'EVP_PKEY_assign'); + _EVPCleanup := GetProcAddr(SSLUtilHandle, 'EVP_cleanup'); + _EvpGetDigestByName := GetProcAddr(SSLUtilHandle, 'EVP_get_digestbyname'); + _SSLeayversion := GetProcAddr(SSLUtilHandle, 'SSLeay_version'); + _ErrErrorString := GetProcAddr(SSLUtilHandle, 'ERR_error_string_n'); + _ErrGetError := GetProcAddr(SSLUtilHandle, 'ERR_get_error'); + _ErrClearError := GetProcAddr(SSLUtilHandle, 'ERR_clear_error'); + _ErrFreeStrings := GetProcAddr(SSLUtilHandle, 'ERR_free_strings'); + _ErrRemoveState := GetProcAddr(SSLUtilHandle, 'ERR_remove_state'); + _OPENSSLaddallalgorithms := GetProcAddr(SSLUtilHandle, 'OPENSSL_add_all_algorithms_noconf'); + _CRYPTOcleanupAllExData := GetProcAddr(SSLUtilHandle, 'CRYPTO_cleanup_all_ex_data'); + _RandScreen := GetProcAddr(SSLUtilHandle, 'RAND_screen'); + _BioNew := GetProcAddr(SSLUtilHandle, 'BIO_new'); + _BioFreeAll := GetProcAddr(SSLUtilHandle, 'BIO_free_all'); + _BioSMem := GetProcAddr(SSLUtilHandle, 'BIO_s_mem'); + _BioCtrlPending := GetProcAddr(SSLUtilHandle, 'BIO_ctrl_pending'); + _BioRead := GetProcAddr(SSLUtilHandle, 'BIO_read'); + _BioWrite := GetProcAddr(SSLUtilHandle, 'BIO_write'); + _d2iPKCS12bio := GetProcAddr(SSLUtilHandle, 'd2i_PKCS12_bio'); + _PKCS12parse := GetProcAddr(SSLUtilHandle, 'PKCS12_parse'); + _PKCS12free := GetProcAddr(SSLUtilHandle, 'PKCS12_free'); + _RsaGenerateKey := GetProcAddr(SSLUtilHandle, 'RSA_generate_key'); + _Asn1UtctimeNew := GetProcAddr(SSLUtilHandle, 'ASN1_UTCTIME_new'); + _Asn1UtctimeFree := GetProcAddr(SSLUtilHandle, 'ASN1_UTCTIME_free'); + _Asn1IntegerSet := GetProcAddr(SSLUtilHandle, 'ASN1_INTEGER_set'); + _Asn1IntegerGet := GetProcAddr(SSLUtilHandle, 'ASN1_INTEGER_get'); {pf} + _i2dX509bio := GetProcAddr(SSLUtilHandle, 'i2d_X509_bio'); + _d2iX509bio := GetProcAddr(SSLUtilHandle, 'd2i_X509_bio'); {pf} + _PEMReadBioX509 := GetProcAddr(SSLUtilHandle, 'PEM_read_bio_X509'); {pf} + _SkX509PopFree := GetProcAddr(SSLUtilHandle, 'SK_X509_POP_FREE'); {pf} + _i2dPrivateKeyBio := GetProcAddr(SSLUtilHandle, 'i2d_PrivateKey_bio'); + + // 3DES functions + _DESsetoddparity := GetProcAddr(SSLUtilHandle, 'DES_set_odd_parity'); + _DESsetkeychecked := GetProcAddr(SSLUtilHandle, 'DES_set_key_checked'); + _DESecbencrypt := GetProcAddr(SSLUtilHandle, 'DES_ecb_encrypt'); + // + _CRYPTOnumlocks := GetProcAddr(SSLUtilHandle, 'CRYPTO_num_locks'); + _CRYPTOsetlockingcallback := GetProcAddr(SSLUtilHandle, 'CRYPTO_set_locking_callback'); +{$ENDIF} +{$IFDEF CIL} + SslLibraryInit; + SslLoadErrorStrings; + OPENSSLaddallalgorithms; + RandScreen; +{$ELSE} + SetLength(s, 1024); + x := GetModuleFilename(SSLLibHandle,PChar(s),Length(s)); + SetLength(s, x); + SSLLibFile := s; + SetLength(s, 1024); + x := GetModuleFilename(SSLUtilHandle,PChar(s),Length(s)); + SetLength(s, x); + SSLUtilFile := s; + //init library + if assigned(_SslLibraryInit) then + _SslLibraryInit; + if assigned(_SslLoadErrorStrings) then + _SslLoadErrorStrings; + if assigned(_OPENSSLaddallalgorithms) then + _OPENSSLaddallalgorithms; + if assigned(_RandScreen) then + _RandScreen; + if assigned(_CRYPTOnumlocks) and assigned(_CRYPTOsetlockingcallback) then + InitLocks; +{$ENDIF} + Result := True; + SSLloaded := True; + end + else + begin + //load failed! + if SSLLibHandle <> 0 then + begin +{$IFNDEF CIL} + FreeLibrary(SSLLibHandle); +{$ENDIF} + SSLLibHandle := 0; + end; + if SSLUtilHandle <> 0 then + begin +{$IFNDEF CIL} + FreeLibrary(SSLUtilHandle); +{$ENDIF} + SSLLibHandle := 0; + end; + Result := False; + end; + end + else + //loaded before... + Result := true; + finally + SSLCS.Leave; + end; +end; + +function DestroySSLInterface: Boolean; +begin + SSLCS.Enter; + try + if IsSSLLoaded then + begin + //deinit library +{$IFNDEF CIL} + if assigned(_CRYPTOnumlocks) and assigned(_CRYPTOsetlockingcallback) then + FreeLocks; +{$ENDIF} + EVPCleanup; + CRYPTOcleanupAllExData; + ErrRemoveState(0); + end; + SSLloaded := false; + if SSLLibHandle <> 0 then + begin +{$IFNDEF CIL} + FreeLibrary(SSLLibHandle); +{$ENDIF} + SSLLibHandle := 0; + end; + if SSLUtilHandle <> 0 then + begin +{$IFNDEF CIL} + FreeLibrary(SSLUtilHandle); +{$ENDIF} + SSLLibHandle := 0; + end; + +{$IFNDEF CIL} + _SslGetError := nil; + _SslLibraryInit := nil; + _SslLoadErrorStrings := nil; + _SslCtxSetCipherList := nil; + _SslCtxNew := nil; + _SslCtxFree := nil; + _SslSetFd := nil; + _SslMethodV2 := nil; + _SslMethodV3 := nil; + _SslMethodTLSV1 := nil; + _SslMethodV23 := nil; + _SslCtxUsePrivateKey := nil; + _SslCtxUsePrivateKeyASN1 := nil; + _SslCtxUsePrivateKeyFile := nil; + _SslCtxUseCertificate := nil; + _SslCtxUseCertificateASN1 := nil; + _SslCtxUseCertificateFile := nil; + _SslCtxUseCertificateChainFile := nil; + _SslCtxCheckPrivateKeyFile := nil; + _SslCtxSetDefaultPasswdCb := nil; + _SslCtxSetDefaultPasswdCbUserdata := nil; + _SslCtxLoadVerifyLocations := nil; + _SslCtxCtrl := nil; + _SslNew := nil; + _SslFree := nil; + _SslAccept := nil; + _SslConnect := nil; + _SslShutdown := nil; + _SslRead := nil; + _SslPeek := nil; + _SslWrite := nil; + _SslPending := nil; + _SslGetPeerCertificate := nil; + _SslGetVersion := nil; + _SslCtxSetVerify := nil; + _SslGetCurrentCipher := nil; + _SslCipherGetName := nil; + _SslCipherGetBits := nil; + _SslGetVerifyResult := nil; + _SslCtrl := nil; + + _X509New := nil; + _X509Free := nil; + _X509NameOneline := nil; + _X509GetSubjectName := nil; + _X509GetIssuerName := nil; + _X509NameHash := nil; + _X509Digest := nil; + _X509print := nil; + _X509SetVersion := nil; + _X509SetPubkey := nil; + _X509SetIssuerName := nil; + _X509NameAddEntryByTxt := nil; + _X509Sign := nil; + _X509GmtimeAdj := nil; + _X509SetNotBefore := nil; + _X509SetNotAfter := nil; + _X509GetSerialNumber := nil; + _EvpPkeyNew := nil; + _EvpPkeyFree := nil; + _EvpPkeyAssign := nil; + _EVPCleanup := nil; + _EvpGetDigestByName := nil; + _SSLeayversion := nil; + _ErrErrorString := nil; + _ErrGetError := nil; + _ErrClearError := nil; + _ErrFreeStrings := nil; + _ErrRemoveState := nil; + _OPENSSLaddallalgorithms := nil; + _CRYPTOcleanupAllExData := nil; + _RandScreen := nil; + _BioNew := nil; + _BioFreeAll := nil; + _BioSMem := nil; + _BioCtrlPending := nil; + _BioRead := nil; + _BioWrite := nil; + _d2iPKCS12bio := nil; + _PKCS12parse := nil; + _PKCS12free := nil; + _RsaGenerateKey := nil; + _Asn1UtctimeNew := nil; + _Asn1UtctimeFree := nil; + _Asn1IntegerSet := nil; + _Asn1IntegerGet := nil; {pf} + _SkX509PopFree := nil; {pf} + _i2dX509bio := nil; + _i2dPrivateKeyBio := nil; + + // 3DES functions + _DESsetoddparity := nil; + _DESsetkeychecked := nil; + _DESecbencrypt := nil; + // + _CRYPTOnumlocks := nil; + _CRYPTOsetlockingcallback := nil; +{$ENDIF} + finally + SSLCS.Leave; + end; + Result := True; +end; + +function IsSSLloaded: Boolean; +begin + Result := SSLLoaded; +end; + +initialization +begin + SSLCS:= TCriticalSection.Create; +end; + +finalization +begin +{$IFNDEF CIL} + DestroySSLInterface; +{$ENDIF} + SSLCS.Free; +end; + +end. diff --git a/synapse/ssl_sbb.pas b/synapse/ssl_sbb.pas new file mode 100644 index 0000000..c9380a4 --- /dev/null +++ b/synapse/ssl_sbb.pas @@ -0,0 +1,697 @@ +{==============================================================================| +| Project : Ararat Synapse | 001.000.003 | +|==============================================================================| +| Content: SSL support for SecureBlackBox | +|==============================================================================| +| Copyright (c)1999-2005, 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. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +| Allen Drennan (adrennan@wiredred.com) | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +{:@abstract(SSL plugin for Eldos SecureBlackBox) + +For handling keys and certificates you can use this properties: +@link(TCustomSSL.CertCAFile), @link(TCustomSSL.CertCA), +@link(TCustomSSL.TrustCertificateFile), @link(TCustomSSL.TrustCertificate), +@link(TCustomSSL.PrivateKeyFile), @link(TCustomSSL.PrivateKey), +@link(TCustomSSL.CertificateFile), @link(TCustomSSL.Certificate), +@link(TCustomSSL.PFXFile). For usage of this properties and for possible formats +of keys and certificates refer to SecureBlackBox documentation. +} + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$H+} + +unit ssl_sbb; + +interface + +uses + SysUtils, Classes, Windows, blcksock, synsock, synautil, synacode, + SBClient, SBServer, SBX509, SBWinCertStorage, SBCustomCertStorage, + SBUtils, SBConstants, SBSessionPool; + +const + DEFAULT_RECV_BUFFER=32768; + +type + {:@abstract(class implementing SecureBlackbox SSL plugin.) + Instance of this class will be created for each @link(TTCPBlockSocket). + You not need to create instance of this class, all is done by Synapse itself!} + TSSLSBB=class(TCustomSSL) + protected + FServer: Boolean; + FElSecureClient:TElSecureClient; + FElSecureServer:TElSecureServer; + FElCertStorage:TElMemoryCertStorage; + FElX509Certificate:TElX509Certificate; + FElX509CACertificate:TElX509Certificate; + FCipherSuites:TBits; + private + FRecvBuffer:String; + FRecvBuffers:String; + FRecvBuffersLock:TRTLCriticalSection; + FRecvDecodedBuffers:String; + function GetCipherSuite:Integer; + procedure Reset; + function Prepare(Server:Boolean):Boolean; + procedure OnError(Sender:TObject; ErrorCode:Integer; Fatal:Boolean; Remote:Boolean); + procedure OnSend(Sender:TObject;Buffer:Pointer;Size:LongInt); + procedure OnReceive(Sender:TObject;Buffer:Pointer;MaxSize:LongInt;var Written:LongInt); + procedure OnData(Sender:TObject;Buffer:Pointer;Size:LongInt); + public + constructor Create(const Value: TTCPBlockSocket); override; + destructor Destroy; override; + {:See @inherited} + function LibVersion: String; override; + {:See @inherited} + function LibName: String; override; + {:See @inherited and @link(ssl_sbb) for more details.} + function Connect: boolean; override; + {:See @inherited and @link(ssl_sbb) for more details.} + function Accept: boolean; override; + {:See @inherited} + function Shutdown: boolean; override; + {:See @inherited} + function BiShutdown: boolean; override; + {:See @inherited} + function SendBuffer(Buffer: TMemory; Len: Integer): Integer; override; + {:See @inherited} + function RecvBuffer(Buffer: TMemory; Len: Integer): Integer; override; + {:See @inherited} + function WaitingData: Integer; override; + {:See @inherited} + function GetSSLVersion: string; override; + {:See @inherited} + function GetPeerSubject: string; override; + {:See @inherited} + function GetPeerIssuer: string; override; + {:See @inherited} + function GetPeerName: string; override; + {:See @inherited} + function GetPeerFingerprint: string; override; + {:See @inherited} + function GetCertInfo: string; override; + published + property ElSecureClient:TElSecureClient read FElSecureClient write FElSecureClient; + property ElSecureServer:TElSecureServer read FElSecureServer write FElSecureServer; + property CipherSuites:TBits read FCipherSuites write FCipherSuites; + property CipherSuite:Integer read GetCipherSuite; + end; + +implementation + +var + FAcceptThread:THandle=0; + +// on error +procedure TSSLSBB.OnError(Sender:TObject; ErrorCode:Integer; Fatal:Boolean; Remote:Boolean); + +begin + FLastErrorDesc:=''; + FLastError:=ErrorCode; +end; + +// on send +procedure TSSLSBB.OnSend(Sender:TObject;Buffer:Pointer;Size:LongInt); + +var + lResult:Integer; + +begin + if FSocket.Socket=INVALID_SOCKET then + Exit; + lResult:=Send(FSocket.Socket,Buffer,Size,0); + if lResult=SOCKET_ERROR then + begin + FLastErrorDesc:=''; + FLastError:=WSAGetLastError; + end; +end; + +// on receive +procedure TSSLSBB.OnReceive(Sender:TObject;Buffer:Pointer;MaxSize:LongInt;var Written:LongInt); + +begin + if GetCurrentThreadId<>FAcceptThread then EnterCriticalSection(FRecvBuffersLock); + try + if Length(FRecvBuffers)<=MaxSize then + begin + Written:=Length(FRecvBuffers); + Move(FRecvBuffers[1],Buffer^,Written); + FRecvBuffers:=''; + end + else + begin + Written:=MaxSize; + Move(FRecvBuffers[1],Buffer^,Written); + Delete(FRecvBuffers,1,Written); + end; + finally + if GetCurrentThreadId<>FAcceptThread then LeaveCriticalSection(FRecvBuffersLock); + end; +end; + +// on data +procedure TSSLSBB.OnData(Sender:TObject;Buffer:Pointer;Size:LongInt); + +var + lString:String; + +begin + SetLength(lString,Size); + Move(Buffer^,lString[1],Size); + FRecvDecodedBuffers:=FRecvDecodedBuffers+lString; +end; + +{ inherited } + +constructor TSSLSBB.Create(const Value: TTCPBlockSocket); + +var + loop1:Integer; + +begin + inherited Create(Value); + FServer:=FALSE; + FElSecureClient:=NIL; + FElSecureServer:=NIL; + FElCertStorage:=NIL; + FElX509Certificate:=NIL; + FElX509CACertificate:=NIL; + SetLength(FRecvBuffer,DEFAULT_RECV_BUFFER); + FRecvBuffers:=''; + InitializeCriticalSection(FRecvBuffersLock); + FRecvDecodedBuffers:=''; + FCipherSuites:=TBits.Create; + if FCipherSuites<>NIL then + begin + FCipherSuites.Size:=SB_SUITE_LAST+1; + for loop1:=SB_SUITE_FIRST to SB_SUITE_LAST do + FCipherSuites[loop1]:=TRUE; + end; +end; + +destructor TSSLSBB.Destroy; + +begin + Reset; + inherited Destroy; + if FCipherSuites<>NIL then + FreeAndNIL(FCipherSuites); + DeleteCriticalSection(FRecvBuffersLock); +end; + +function TSSLSBB.LibVersion: String; + +begin + Result:='SecureBlackBox'; +end; + +function TSSLSBB.LibName: String; + +begin + Result:='ssl_sbb'; +end; + +function FileToString(lFile:String):String; + +var + lStream:TMemoryStream; + +begin + Result:=''; + lStream:=TMemoryStream.Create; + if lStream<>NIL then + begin + lStream.LoadFromFile(lFile); + if lStream.Size>0 then + begin + lStream.Position:=0; + SetLength(Result,lStream.Size); + Move(lStream.Memory^,Result[1],lStream.Size); + end; + lStream.Free; + end; +end; + +function TSSLSBB.GetCipherSuite:Integer; + +begin + if FServer then + Result:=FElSecureServer.CipherSuite + else + Result:=FElSecureClient.CipherSuite; +end; + +procedure TSSLSBB.Reset; + +begin + if FElSecureServer<>NIL then + FreeAndNIL(FElSecureServer); + if FElSecureClient<>NIL then + FreeAndNIL(FElSecureClient); + if FElX509Certificate<>NIL then + FreeAndNIL(FElX509Certificate); + if FElX509CACertificate<>NIL then + FreeAndNIL(FElX509CACertificate); + if FElCertStorage<>NIL then + FreeAndNIL(FElCertStorage); + FSSLEnabled:=FALSE; +end; + +function TSSLSBB.Prepare(Server:Boolean): Boolean; + +var + loop1:Integer; + lStream:TMemoryStream; + lCertificate,lPrivateKey,lCertCA:String; + +begin + Result:=FALSE; + FServer:=Server; + + // reset, if necessary + Reset; + + // init, certificate + if FCertificateFile<>'' then + lCertificate:=FileToString(FCertificateFile) + else + lCertificate:=FCertificate; + if FPrivateKeyFile<>'' then + lPrivateKey:=FileToString(FPrivateKeyFile) + else + lPrivateKey:=FPrivateKey; + if FCertCAFile<>'' then + lCertCA:=FileToString(FCertCAFile) + else + lCertCA:=FCertCA; + if (lCertificate<>'') and (lPrivateKey<>'') then + begin + FElCertStorage:=TElMemoryCertStorage.Create(NIL); + if FElCertStorage<>NIL then + FElCertStorage.Clear; + + // apply ca certificate + if lCertCA<>'' then + begin + FElX509CACertificate:=TElX509Certificate.Create(NIL); + if FElX509CACertificate<>NIL then + begin + with FElX509CACertificate do + begin + lStream:=TMemoryStream.Create; + try + WriteStrToStream(lStream,lCertCA); + lStream.Seek(0,soFromBeginning); + LoadFromStream(lStream); + finally + lStream.Free; + end; + end; + if FElCertStorage<>NIL then + FElCertStorage.Add(FElX509CACertificate); + end; + end; + + // apply certificate + FElX509Certificate:=TElX509Certificate.Create(NIL); + if FElX509Certificate<>NIL then + begin + with FElX509Certificate do + begin + lStream:=TMemoryStream.Create; + try + WriteStrToStream(lStream,lCertificate); + lStream.Seek(0,soFromBeginning); + LoadFromStream(lStream); + finally + lStream.Free; + end; + lStream:=TMemoryStream.Create; + try + WriteStrToStream(lStream,lPrivateKey); + lStream.Seek(0,soFromBeginning); + LoadKeyFromStream(lStream); + finally + lStream.Free; + end; + if FElCertStorage<>NIL then + FElCertStorage.Add(FElX509Certificate); + end; + end; + end; + + // init, as server + if FServer then + begin + FElSecureServer:=TElSecureServer.Create(NIL); + if FElSecureServer<>NIL then + begin + // init, ciphers + for loop1:=SB_SUITE_FIRST to SB_SUITE_LAST do + FElSecureServer.CipherSuites[loop1]:=FCipherSuites[loop1]; + FElSecureServer.Versions:=[sbSSL2,sbSSL3,sbTLS1]; + FElSecureServer.ClientAuthentication:=FALSE; + FElSecureServer.OnError:=OnError; + FElSecureServer.OnSend:=OnSend; + FElSecureServer.OnReceive:=OnReceive; + FElSecureServer.OnData:=OnData; + FElSecureServer.CertStorage:=FElCertStorage; + Result:=TRUE; + end; + end + else + // init, as client + begin + FElSecureClient:=TElSecureClient.Create(NIL); + if FElSecureClient<>NIL then + begin + // init, ciphers + for loop1:=SB_SUITE_FIRST to SB_SUITE_LAST do + FElSecureClient.CipherSuites[loop1]:=FCipherSuites[loop1]; + FElSecureClient.Versions:=[sbSSL3,sbTLS1]; + FElSecureClient.OnError:=OnError; + FElSecureClient.OnSend:=OnSend; + FElSecureClient.OnReceive:=OnReceive; + FElSecureClient.OnData:=OnData; + FElSecureClient.CertStorage:=FElCertStorage; + Result:=TRUE; + end; + end; +end; + +function TSSLSBB.Connect:Boolean; + +var + lResult:Integer; + +begin + Result:=FALSE; + if FSocket.Socket=INVALID_SOCKET then + Exit; + if Prepare(FALSE) then + begin + FElSecureClient.Open; + + // reset + FRecvBuffers:=''; + FRecvDecodedBuffers:=''; + + // wait for open or error + while (not FElSecureClient.Active) and + (FLastError=0) do + begin + // data available? + if FRecvBuffers<>'' then + FElSecureClient.DataAvailable + else + begin + // socket recv + lResult:=Recv(FSocket.Socket,@FRecvBuffer[1],Length(FRecvBuffer),0); + if lResult=SOCKET_ERROR then + begin + FLastErrorDesc:=''; + FLastError:=WSAGetLastError; + end + else + begin + if lResult>0 then + FRecvBuffers:=FRecvBuffers+Copy(FRecvBuffer,1,lResult) + else + Break; + end; + end; + end; + if FLastError<>0 then + Exit; + FSSLEnabled:=FElSecureClient.Active; + Result:=FSSLEnabled; + end; +end; + +function TSSLSBB.Accept:Boolean; + +var + lResult:Integer; + +begin + Result:=FALSE; + if FSocket.Socket=INVALID_SOCKET then + Exit; + if Prepare(TRUE) then + begin + FAcceptThread:=GetCurrentThreadId; + FElSecureServer.Open; + + // reset + FRecvBuffers:=''; + FRecvDecodedBuffers:=''; + + // wait for open or error + while (not FElSecureServer.Active) and + (FLastError=0) do + begin + // data available? + if FRecvBuffers<>'' then + FElSecureServer.DataAvailable + else + begin + // socket recv + lResult:=Recv(FSocket.Socket,@FRecvBuffer[1],Length(FRecvBuffer),0); + if lResult=SOCKET_ERROR then + begin + FLastErrorDesc:=''; + FLastError:=WSAGetLastError; + end + else + begin + if lResult>0 then + FRecvBuffers:=FRecvBuffers+Copy(FRecvBuffer,1,lResult) + else + Break; + end; + end; + end; + if FLastError<>0 then + Exit; + FSSLEnabled:=FElSecureServer.Active; + Result:=FSSLEnabled; + end; +end; + +function TSSLSBB.Shutdown:Boolean; + +begin + Result:=BiShutdown; +end; + +function TSSLSBB.BiShutdown: boolean; + +begin + Reset; + Result:=TRUE; +end; + +function TSSLSBB.SendBuffer(Buffer: TMemory; Len: Integer): Integer; + +begin + if FServer then + FElSecureServer.SendData(Buffer,Len) + else + FElSecureClient.SendData(Buffer,Len); + Result:=Len; +end; + +function TSSLSBB.RecvBuffer(Buffer: TMemory; Len: Integer): Integer; + +begin + Result:=0; + try + // recv waiting, if necessary + if FRecvDecodedBuffers='' then + WaitingData; + + // received + if Length(FRecvDecodedBuffers)<Len then + begin + Result:=Length(FRecvDecodedBuffers); + Move(FRecvDecodedBuffers[1],Buffer^,Result); + FRecvDecodedBuffers:=''; + end + else + begin + Result:=Len; + Move(FRecvDecodedBuffers[1],Buffer^,Result); + Delete(FRecvDecodedBuffers,1,Result); + end; + except + // ignore + end; +end; + +function TSSLSBB.WaitingData: Integer; + +var + lResult:Integer; + lRecvBuffers:Boolean; + +begin + Result:=0; + if FSocket.Socket=INVALID_SOCKET then + Exit; + // data available? + if GetCurrentThreadId<>FAcceptThread then EnterCriticalSection(FRecvBuffersLock); + try + lRecvBuffers:=FRecvBuffers<>''; + finally + if GetCurrentThreadId<>FAcceptThread then LeaveCriticalSection(FRecvBuffersLock); + end; + if lRecvBuffers then + begin + if FServer then + FElSecureServer.DataAvailable + else + FElSecureClient.DataAvailable; + end + else + begin + // socket recv + lResult:=Recv(FSocket.Socket,@FRecvBuffer[1],Length(FRecvBuffer),0); + if lResult=SOCKET_ERROR then + begin + FLastErrorDesc:=''; + FLastError:=WSAGetLastError; + end + else + begin + if GetCurrentThreadId<>FAcceptThread then EnterCriticalSection(FRecvBuffersLock); + try + FRecvBuffers:=FRecvBuffers+Copy(FRecvBuffer,1,lResult); + finally + if GetCurrentThreadId<>FAcceptThread then LeaveCriticalSection(FRecvBuffersLock); + end; + + // data available? + if GetCurrentThreadId<>FAcceptThread then EnterCriticalSection(FRecvBuffersLock); + try + lRecvBuffers:=FRecvBuffers<>''; + finally + if GetCurrentThreadId<>FAcceptThread then LeaveCriticalSection(FRecvBuffersLock); + end; + if lRecvBuffers then + begin + if FServer then + FElSecureServer.DataAvailable + else + FElSecureClient.DataAvailable; + end; + end; + end; + + // decoded buffers result + Result:=Length(FRecvDecodedBuffers); +end; + +function TSSLSBB.GetSSLVersion: string; + +begin + Result:='SSLv3 or TLSv1'; +end; + +function TSSLSBB.GetPeerSubject: string; + +begin + Result := ''; +// if FServer then + // must return subject of the client certificate +// else + // must return subject of the server certificate +end; + +function TSSLSBB.GetPeerName: string; + +begin + Result := ''; +// if FServer then + // must return commonname of the client certificate +// else + // must return commonname of the server certificate +end; + +function TSSLSBB.GetPeerIssuer: string; + +begin + Result := ''; +// if FServer then + // must return issuer of the client certificate +// else + // must return issuer of the server certificate +end; + +function TSSLSBB.GetPeerFingerprint: string; + +begin + Result := ''; +// if FServer then + // must return a unique hash string of the client certificate +// else + // must return a unique hash string of the server certificate +end; + +function TSSLSBB.GetCertInfo: string; + +begin + Result := ''; +// if FServer then + // must return a text representation of the ASN of the client certificate +// else + // must return a text representation of the ASN of the server certificate +end; + +{==============================================================================} + +initialization + SSLImplementation := TSSLSBB; + +finalization + +end. diff --git a/synapse/ssl_streamsec.pas b/synapse/ssl_streamsec.pas new file mode 100644 index 0000000..8c36ac8 --- /dev/null +++ b/synapse/ssl_streamsec.pas @@ -0,0 +1,539 @@ +{==============================================================================| +| Project : Ararat Synapse | 001.000.006 | +|==============================================================================| +| Content: SSL support by StreamSecII | +|==============================================================================| +| Copyright (c)1999-2005, 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. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +| Henrick Hellstrm <henrick@streamsec.se> | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +{:@abstract(SSL plugin for StreamSecII or OpenStreamSecII) + +StreamSecII is native pascal library, you not need any external libraries! + +You can tune lot of StreamSecII properties by using your GlobalServer. If you not +using your GlobalServer, then this plugin create own TSimpleTLSInternalServer +instance for each TCP connection. Formore information about GlobalServer usage +refer StreamSecII documentation. + +If you are not using key and certificate by GlobalServer, then you can use +properties of this plugin instead, but this have limited features and +@link(TCustomSSL.KeyPassword) not working properly yet! + +For handling keys and certificates you can use this properties: +@link(TCustomSSL.CertCAFile), @link(TCustomSSL.CertCA), +@link(TCustomSSL.TrustCertificateFile), @link(TCustomSSL.TrustCertificate), +@link(TCustomSSL.PrivateKeyFile), @link(TCustomSSL.PrivateKey), +@link(TCustomSSL.CertificateFile), @link(TCustomSSL.Certificate), +@link(TCustomSSL.PFXFile). For usage of this properties and for possible formats +of keys and certificates refer to StreamSecII documentation. +} + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$H+} + +unit ssl_streamsec; + +interface + +uses + SysUtils, Classes, + blcksock, synsock, synautil, synacode, + TlsInternalServer, TlsSynaSock, TlsConst, StreamSecII, Asn1, X509Base, + SecUtils; + +type + {:@exclude} + TMyTLSSynSockSlave = class(TTLSSynSockSlave) + protected + procedure SetMyTLSServer(const Value: TCustomTLSInternalServer); + function GetMyTLSServer: TCustomTLSInternalServer; + published + property MyTLSServer: TCustomTLSInternalServer read GetMyTLSServer write SetMyTLSServer; + end; + + {:@abstract(class implementing StreamSecII SSL plugin.) + Instance of this class will be created for each @link(TTCPBlockSocket). + You not need to create instance of this class, all is done by Synapse itself!} + TSSLStreamSec = class(TCustomSSL) + protected + FSlave: TMyTLSSynSockSlave; + FIsServer: Boolean; + FTLSServer: TCustomTLSInternalServer; + FServerCreated: Boolean; + function SSLCheck: Boolean; + function Init(server:Boolean): Boolean; + function DeInit: Boolean; + function Prepare(server:Boolean): Boolean; + procedure NotTrustEvent(Sender: TObject; Cert: TASN1Struct; var ExplicitTrust: Boolean); + function X500StrToStr(const Prefix: string; const Value: TX500String): string; + function X501NameToStr(const Value: TX501Name): string; + function GetCert: PASN1Struct; + public + constructor Create(const Value: TTCPBlockSocket); override; + destructor Destroy; override; + {:See @inherited} + function LibVersion: String; override; + {:See @inherited} + function LibName: String; override; + {:See @inherited and @link(ssl_streamsec) for more details.} + function Connect: boolean; override; + {:See @inherited and @link(ssl_streamsec) for more details.} + function Accept: boolean; override; + {:See @inherited} + function Shutdown: boolean; override; + {:See @inherited} + function BiShutdown: boolean; override; + {:See @inherited} + function SendBuffer(Buffer: TMemory; Len: Integer): Integer; override; + {:See @inherited} + function RecvBuffer(Buffer: TMemory; Len: Integer): Integer; override; + {:See @inherited} + function WaitingData: Integer; override; + {:See @inherited} + function GetSSLVersion: string; override; + {:See @inherited} + function GetPeerSubject: string; override; + {:See @inherited} + function GetPeerIssuer: string; override; + {:See @inherited} + function GetPeerName: string; override; + {:See @inherited} + function GetPeerFingerprint: string; override; + {:See @inherited} + function GetCertInfo: string; override; + published + {:TLS server for tuning of StreamSecII.} + property TLSServer: TCustomTLSInternalServer read FTLSServer write FTLSServer; + end; + +implementation + +{==============================================================================} +procedure TMyTLSSynSockSlave.SetMyTLSServer(const Value: TCustomTLSInternalServer); +begin + TLSServer := Value; +end; + +function TMyTLSSynSockSlave.GetMyTLSServer: TCustomTLSInternalServer; +begin + Result := TLSServer; +end; + +{==============================================================================} + +constructor TSSLStreamSec.Create(const Value: TTCPBlockSocket); +begin + inherited Create(Value); + FSlave := nil; + FIsServer := False; + FTLSServer := nil; +end; + +destructor TSSLStreamSec.Destroy; +begin + DeInit; + inherited Destroy; +end; + +function TSSLStreamSec.LibVersion: String; +begin + Result := 'StreamSecII'; +end; + +function TSSLStreamSec.LibName: String; +begin + Result := 'ssl_streamsec'; +end; + +function TSSLStreamSec.SSLCheck: Boolean; +begin + Result := true; + FLastErrorDesc := ''; + if not Assigned(FSlave) then + Exit; + FLastError := FSlave.ErrorCode; + if FLastError <> 0 then + begin + FLastErrorDesc := TlsConst.AlertMsg(FLastError); + end; +end; + +procedure TSSLStreamSec.NotTrustEvent(Sender: TObject; Cert: TASN1Struct; var ExplicitTrust: Boolean); +begin + ExplicitTrust := true; +end; + +function TSSLStreamSec.Init(server:Boolean): Boolean; +var + st: TMemoryStream; + pass: ISecretKey; + ws: WideString; +begin + Result := False; + ws := FKeyPassword; + pass := TSecretKey.CreateBmpStr(PWideChar(ws), length(ws)); + try + FIsServer := Server; + FSlave := TMyTLSSynSockSlave.CreateSocket(FSocket.Socket); + if Assigned(FTLSServer) then + FSlave.MyTLSServer := FTLSServer + else + if Assigned(TLSInternalServer.GlobalServer) then + FSlave.MyTLSServer := TLSInternalServer.GlobalServer + else begin + FSlave.MyTLSServer := TSimpleTLSInternalServer.Create(nil); + FServerCreated := True; + end; + if server then + FSlave.MyTLSServer.ClientOrServer := cosServerSide + else + FSlave.MyTLSServer.ClientOrServer := cosClientSide; + if not FVerifyCert then + begin + FSlave.MyTLSServer.OnCertNotTrusted := NotTrustEvent; + end; + FSlave.MyTLSServer.Options.VerifyServerName := []; + FSlave.MyTLSServer.Options.Export40Bit := prAllowed; + FSlave.MyTLSServer.Options.Export56Bit := prAllowed; + FSlave.MyTLSServer.Options.RequestClientCertificate := False; + FSlave.MyTLSServer.Options.RequireClientCertificate := False; + if server and FVerifyCert then + begin + FSlave.MyTLSServer.Options.RequestClientCertificate := True; + FSlave.MyTLSServer.Options.RequireClientCertificate := True; + end; + if FCertCAFile <> '' then + FSlave.MyTLSServer.LoadRootCertsFromFile(CertCAFile); + if FCertCA <> '' then + begin + st := TMemoryStream.Create; + try + WriteStrToStream(st, FCertCA); + st.Seek(0, soFromBeginning); + FSlave.MyTLSServer.LoadRootCertsFromStream(st); + finally + st.free; + end; + end; + if FTrustCertificateFile <> '' then + FSlave.MyTLSServer.LoadTrustedCertsFromFile(FTrustCertificateFile); + if FTrustCertificate <> '' then + begin + st := TMemoryStream.Create; + try + WriteStrToStream(st, FTrustCertificate); + st.Seek(0, soFromBeginning); + FSlave.MyTLSServer.LoadTrustedCertsFromStream(st); + finally + st.free; + end; + end; + if FPrivateKeyFile <> '' then + FSlave.MyTLSServer.LoadPrivateKeyRingFromFile(FPrivateKeyFile, pass); +// FSlave.MyTLSServer.PrivateKeyRing.LoadPrivateKeyFromFile(FPrivateKeyFile, pass); + if FPrivateKey <> '' then + begin + st := TMemoryStream.Create; + try + WriteStrToStream(st, FPrivateKey); + st.Seek(0, soFromBeginning); + FSlave.MyTLSServer.LoadPrivateKeyRingFromStream(st, pass); + finally + st.free; + end; + end; + if FCertificateFile <> '' then + FSlave.MyTLSServer.LoadMyCertsFromFile(FCertificateFile); + if FCertificate <> '' then + begin + st := TMemoryStream.Create; + try + WriteStrToStream(st, FCertificate); + st.Seek(0, soFromBeginning); + FSlave.MyTLSServer.LoadMyCertsFromStream(st); + finally + st.free; + end; + end; + if FPFXfile <> '' then + FSlave.MyTLSServer.ImportFromPFX(FPFXfile, pass); + if server and FServerCreated then + begin + FSlave.MyTLSServer.Options.BulkCipherAES128 := prPrefer; + FSlave.MyTLSServer.Options.BulkCipherAES256 := prAllowed; + FSlave.MyTLSServer.Options.EphemeralECDHKeySize := ecs256; + FSlave.MyTLSServer.Options.SignatureRSA := prPrefer; + FSlave.MyTLSServer.Options.KeyAgreementRSA := prAllowed; + FSlave.MyTLSServer.Options.KeyAgreementECDHE := prAllowed; + FSlave.MyTLSServer.Options.KeyAgreementDHE := prPrefer; + FSlave.MyTLSServer.TLSSetupServer; + end; + Result := true; + finally + pass := nil; + end; +end; + +function TSSLStreamSec.DeInit: Boolean; +var + obj: TObject; +begin + Result := True; + if assigned(FSlave) then + begin + FSlave.Close; + if FServerCreated then + obj := FSlave.TLSServer + else + obj := nil; + FSlave.Free; + obj.Free; + FSlave := nil; + end; + FSSLEnabled := false; +end; + +function TSSLStreamSec.Prepare(server:Boolean): Boolean; +begin + Result := false; + DeInit; + if Init(server) then + Result := true + else + DeInit; +end; + +function TSSLStreamSec.Connect: boolean; +begin + Result := False; + if FSocket.Socket = INVALID_SOCKET then + Exit; + if Prepare(false) then + begin + FSlave.Open; + SSLCheck; + if FLastError <> 0 then + Exit; + FSSLEnabled := True; + Result := True; + end; +end; + +function TSSLStreamSec.Accept: boolean; +begin + Result := False; + if FSocket.Socket = INVALID_SOCKET then + Exit; + if Prepare(true) then + begin + FSlave.DoConnect; + SSLCheck; + if FLastError <> 0 then + Exit; + FSSLEnabled := True; + Result := True; + end; +end; + +function TSSLStreamSec.Shutdown: boolean; +begin + Result := BiShutdown; +end; + +function TSSLStreamSec.BiShutdown: boolean; +begin + DeInit; + Result := True; +end; + +function TSSLStreamSec.SendBuffer(Buffer: TMemory; Len: Integer): Integer; +var + l: integer; +begin + l := len; + FSlave.SendBuf(Buffer^, l, true); + Result := l; + SSLCheck; +end; + +function TSSLStreamSec.RecvBuffer(Buffer: TMemory; Len: Integer): Integer; +var + l: integer; +begin + l := Len; + Result := FSlave.ReceiveBuf(Buffer^, l); + SSLCheck; +end; + +function TSSLStreamSec.WaitingData: Integer; +begin + Result := 0; + while FSlave.Connected do begin + Result := FSlave.ReceiveLength; + if Result > 0 then + Break; + Sleep(1); + end; +end; + +function TSSLStreamSec.GetSSLVersion: string; +begin + Result := 'SSLv3 or TLSv1'; +end; + +function TSSLStreamSec.GetCert: PASN1Struct; +begin + if FIsServer then + Result := FSlave.GetClientCert + else + Result := FSlave.GetServerCert; +end; + +function TSSLStreamSec.GetPeerSubject: string; +var + XName: TX501Name; + Cert: PASN1Struct; +begin + Result := ''; + Cert := GetCert; + if Assigned(cert) then + begin + ExtractSubject(Cert^,XName, false); + Result := X501NameToStr(XName); + end; +end; + +function TSSLStreamSec.GetPeerName: string; +var + XName: TX501Name; + Cert: PASN1Struct; +begin + Result := ''; + Cert := GetCert; + if Assigned(cert) then + begin + ExtractSubject(Cert^,XName, false); + Result := XName.commonName.Str; + end; +end; + +function TSSLStreamSec.GetPeerIssuer: string; +var + XName: TX501Name; + Cert: PASN1Struct; +begin + Result := ''; + Cert := GetCert; + if Assigned(cert) then + begin + ExtractIssuer(Cert^, XName, false); + Result := X501NameToStr(XName); + end; +end; + +function TSSLStreamSec.GetPeerFingerprint: string; +var + Cert: PASN1Struct; +begin + Result := ''; + Cert := GetCert; + if Assigned(cert) then + Result := MD5(Cert.ContentAsOctetString); +end; + +function TSSLStreamSec.GetCertInfo: string; +var + Cert: PASN1Struct; + l: Tstringlist; +begin + Result := ''; + Cert := GetCert; + if Assigned(cert) then + begin + l := TStringList.Create; + try + Asn1.RenderAsText(cert^, l, true, true, true, 2); + Result := l.Text; + finally + l.free; + end; + end; +end; + +function TSSLStreamSec.X500StrToStr(const Prefix: string; + const Value: TX500String): string; +begin + if Value.Str = '' then + Result := '' + else + Result := '/' + Prefix + '=' + Value.Str; +end; + +function TSSLStreamSec.X501NameToStr(const Value: TX501Name): string; +begin + Result := X500StrToStr('CN',Value.commonName) + + X500StrToStr('C',Value.countryName) + + X500StrToStr('L',Value.localityName) + + X500StrToStr('ST',Value.stateOrProvinceName) + + X500StrToStr('O',Value.organizationName) + + X500StrToStr('OU',Value.organizationalUnitName) + + X500StrToStr('T',Value.title) + + X500StrToStr('N',Value.name) + + X500StrToStr('G',Value.givenName) + + X500StrToStr('I',Value.initials) + + X500StrToStr('SN',Value.surname) + + X500StrToStr('GQ',Value.generationQualifier) + + X500StrToStr('DNQ',Value.dnQualifier) + + X500StrToStr('E',Value.emailAddress); +end; + + +{==============================================================================} + +initialization + SSLImplementation := TSSLStreamSec; + +finalization + +end. + + diff --git a/synapse/sslinux.inc b/synapse/sslinux.inc new file mode 100644 index 0000000..2a23146 --- /dev/null +++ b/synapse/sslinux.inc @@ -0,0 +1,1314 @@ +{==============================================================================| +| Project : Ararat Synapse | 002.000.009 | +|==============================================================================| +| Content: Socket Independent Platform Layer - Linux definition include | +|==============================================================================| +| 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/) | +|==============================================================================} + +{:@exclude} + +{$IFDEF LINUX} + +//{$DEFINE FORCEOLDAPI} +{Note about define FORCEOLDAPI: +If you activate this compiler directive, then is allways used old socket API +for name resolution. If you leave this directive inactive, then the new API +is used, when running system allows it. + +For IPv6 support you must have new API! +} + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$H+} +interface + +uses + SyncObjs, SysUtils, Classes, + synafpc, + Libc; + +function InitSocketInterface(stack: string): Boolean; +function DestroySocketInterface: Boolean; + +const + WinsockLevel = $0202; + +type + u_char = Char; + u_short = Word; + u_int = Integer; + u_long = Longint; + pu_long = ^u_long; + pu_short = ^u_short; + TSocket = u_int; + TAddrFamily = integer; + + TMemory = pointer; + + +const + DLLStackName = 'libc.so.6'; + + cLocalhost = '127.0.0.1'; + cAnyHost = '0.0.0.0'; + cBroadcast = '255.255.255.255'; + c6Localhost = '::1'; + c6AnyHost = '::0'; + c6Broadcast = 'ffff::1'; + cAnyPort = '0'; + +type + DWORD = Integer; + __fd_mask = LongWord; +const + __FD_SETSIZE = 1024; + __NFDBITS = 8 * sizeof(__fd_mask); +type + __fd_set = {packed} record + fds_bits: packed array[0..(__FD_SETSIZE div __NFDBITS)-1] of __fd_mask; + end; + TFDSet = __fd_set; + PFDSet = ^TFDSet; + +const + FIONREAD = $541B; + FIONBIO = $5421; + FIOASYNC = $5452; + +type + PTimeVal = ^TTimeVal; + TTimeVal = packed record + tv_sec: Longint; + tv_usec: Longint; + end; + +const + IPPROTO_IP = 0; { Dummy } + IPPROTO_ICMP = 1; { Internet Control Message Protocol } + IPPROTO_IGMP = 2; { Internet Group Management Protocol} + IPPROTO_TCP = 6; { TCP } + IPPROTO_UDP = 17; { User Datagram Protocol } + IPPROTO_IPV6 = 41; + IPPROTO_ICMPV6 = 58; + IPPROTO_RM = 113; + + IPPROTO_RAW = 255; + IPPROTO_MAX = 256; + +type + PInAddr = ^TInAddr; + TInAddr = packed record + case integer of + 0: (S_bytes: packed array [0..3] of byte); + 1: (S_addr: u_long); + end; + + PSockAddrIn = ^TSockAddrIn; + TSockAddrIn = packed record + case Integer of + 0: (sin_family: u_short; + sin_port: u_short; + sin_addr: TInAddr; + sin_zero: array[0..7] of Char); + 1: (sa_family: u_short; + sa_data: array[0..13] of Char) + end; + + TIP_mreq = record + imr_multiaddr: TInAddr; { IP multicast address of group } + imr_interface: TInAddr; { local IP address of interface } + end; + + PInAddr6 = ^TInAddr6; + TInAddr6 = packed record + case integer of + 0: (S6_addr: packed array [0..15] of byte); + 1: (u6_addr8: packed array [0..15] of byte); + 2: (u6_addr16: packed array [0..7] of word); + 3: (u6_addr32: packed array [0..3] of integer); + end; + + PSockAddrIn6 = ^TSockAddrIn6; + TSockAddrIn6 = packed record + sin6_family: u_short; // AF_INET6 + sin6_port: u_short; // Transport level port number + sin6_flowinfo: u_long; // IPv6 flow information + sin6_addr: TInAddr6; // IPv6 address + sin6_scope_id: u_long; // Scope Id: IF number for link-local + // SITE id for site-local + end; + + TIPv6_mreq = record + ipv6mr_multiaddr: TInAddr6; // IPv6 multicast address. + ipv6mr_interface: integer; // Interface index. + padding: u_long; + end; + + PHostEnt = ^THostEnt; + THostent = record + h_name: PChar; + h_aliases: PPChar; + h_addrtype: Integer; + h_length: Cardinal; + case Byte of + 0: (h_addr_list: PPChar); + 1: (h_addr: PPChar); + end; + + PNetEnt = ^TNetEnt; + TNetEnt = record + n_name: PChar; + n_aliases: PPChar; + n_addrtype: Integer; + n_net: uint32_t; + end; + + PServEnt = ^TServEnt; + TServEnt = record + s_name: PChar; + s_aliases: PPChar; + s_port: Integer; + s_proto: PChar; + end; + + PProtoEnt = ^TProtoEnt; + TProtoEnt = record + p_name: PChar; + p_aliases: ^PChar; + p_proto: u_short; + end; + +const + INADDR_ANY = $00000000; + INADDR_LOOPBACK = $7F000001; + INADDR_BROADCAST = $FFFFFFFF; + INADDR_NONE = $FFFFFFFF; + ADDR_ANY = INADDR_ANY; + INVALID_SOCKET = TSocket(NOT(0)); + SOCKET_ERROR = -1; + +Const + IP_TOS = 1; { int; IP type of service and precedence. } + IP_TTL = 2; { int; IP time to live. } + IP_HDRINCL = 3; { int; Header is included with data. } + IP_OPTIONS = 4; { ip_opts; IP per-packet options. } + IP_ROUTER_ALERT = 5; { bool } + IP_RECVOPTS = 6; { bool } + IP_RETOPTS = 7; { bool } + IP_PKTINFO = 8; { bool } + IP_PKTOPTIONS = 9; + IP_PMTUDISC = 10; { obsolete name? } + IP_MTU_DISCOVER = 10; { int; see below } + IP_RECVERR = 11; { bool } + IP_RECVTTL = 12; { bool } + IP_RECVTOS = 13; { bool } + IP_MULTICAST_IF = 32; { in_addr; set/get IP multicast i/f } + IP_MULTICAST_TTL = 33; { u_char; set/get IP multicast ttl } + IP_MULTICAST_LOOP = 34; { i_char; set/get IP multicast loopback } + IP_ADD_MEMBERSHIP = 35; { ip_mreq; add an IP group membership } + IP_DROP_MEMBERSHIP = 36; { ip_mreq; drop an IP group membership } + + SOL_SOCKET = 1; + + SO_DEBUG = 1; + SO_REUSEADDR = 2; + SO_TYPE = 3; + SO_ERROR = 4; + SO_DONTROUTE = 5; + SO_BROADCAST = 6; + SO_SNDBUF = 7; + SO_RCVBUF = 8; + SO_KEEPALIVE = 9; + SO_OOBINLINE = 10; + SO_NO_CHECK = 11; + SO_PRIORITY = 12; + SO_LINGER = 13; + SO_BSDCOMPAT = 14; + SO_REUSEPORT = 15; + SO_PASSCRED = 16; + SO_PEERCRED = 17; + SO_RCVLOWAT = 18; + SO_SNDLOWAT = 19; + SO_RCVTIMEO = 20; + SO_SNDTIMEO = 21; +{ Security levels - as per NRL IPv6 - don't actually do anything } + SO_SECURITY_AUTHENTICATION = 22; + SO_SECURITY_ENCRYPTION_TRANSPORT = 23; + SO_SECURITY_ENCRYPTION_NETWORK = 24; + SO_BINDTODEVICE = 25; +{ Socket filtering } + SO_ATTACH_FILTER = 26; + SO_DETACH_FILTER = 27; + + SOMAXCONN = 128; + + IPV6_UNICAST_HOPS = 16; + IPV6_MULTICAST_IF = 17; + IPV6_MULTICAST_HOPS = 18; + IPV6_MULTICAST_LOOP = 19; + IPV6_JOIN_GROUP = 20; + IPV6_LEAVE_GROUP = 21; + + MSG_NOSIGNAL = $4000; // Do not generate SIGPIPE. + + // getnameinfo constants + NI_MAXHOST = 1025; + NI_MAXSERV = 32; + NI_NOFQDN = $4; + NI_NUMERICHOST = $1; + NI_NAMEREQD = $8; + NI_NUMERICSERV = $2; + NI_DGRAM = $10; + +const + SOCK_STREAM = 1; { stream socket } + SOCK_DGRAM = 2; { datagram socket } + SOCK_RAW = 3; { raw-protocol interface } + SOCK_RDM = 4; { reliably-delivered message } + SOCK_SEQPACKET = 5; { sequenced packet stream } + +{ TCP options. } + TCP_NODELAY = $0001; + +{ Address families. } + + AF_UNSPEC = 0; { unspecified } + AF_INET = 2; { internetwork: UDP, TCP, etc. } + AF_INET6 = 10; { Internetwork Version 6 } + AF_MAX = 24; + +{ Protocol families, same as address families for now. } + PF_UNSPEC = AF_UNSPEC; + PF_INET = AF_INET; + PF_INET6 = AF_INET6; + PF_MAX = AF_MAX; + +type + { Structure used by kernel to store most addresses. } + PSockAddr = ^TSockAddr; + TSockAddr = TSockAddrIn; + + { Structure used by kernel to pass protocol information in raw sockets. } + PSockProto = ^TSockProto; + TSockProto = packed record + sp_family: u_short; + sp_protocol: u_short; + end; + +type + PAddrInfo = ^TAddrInfo; + TAddrInfo = record + ai_flags: integer; // AI_PASSIVE, AI_CANONNAME, AI_NUMERICHOST. + ai_family: integer; // PF_xxx. + ai_socktype: integer; // SOCK_xxx. + ai_protocol: integer; // 0 or IPPROTO_xxx for IPv4 and IPv6. + ai_addrlen: u_int; // Length of ai_addr. + ai_addr: PSockAddr; // Binary address. + ai_canonname: PChar; // Canonical name for nodename. + ai_next: PAddrInfo; // Next structure in linked list. + end; + +const + // Flags used in "hints" argument to getaddrinfo(). + AI_PASSIVE = $1; // Socket address will be used in bind() call. + AI_CANONNAME = $2; // Return canonical name in first ai_canonname. + AI_NUMERICHOST = $4; // Nodename must be a numeric address string. + +type +{ Structure used for manipulating linger option. } + PLinger = ^TLinger; + TLinger = packed record + l_onoff: integer; + l_linger: integer; + end; + +const + + MSG_OOB = $01; // Process out-of-band data. + MSG_PEEK = $02; // Peek at incoming messages. + +const + WSAEINTR = EINTR; + WSAEBADF = EBADF; + WSAEACCES = EACCES; + WSAEFAULT = EFAULT; + WSAEINVAL = EINVAL; + WSAEMFILE = EMFILE; + WSAEWOULDBLOCK = EWOULDBLOCK; + WSAEINPROGRESS = EINPROGRESS; + WSAEALREADY = EALREADY; + WSAENOTSOCK = ENOTSOCK; + WSAEDESTADDRREQ = EDESTADDRREQ; + WSAEMSGSIZE = EMSGSIZE; + WSAEPROTOTYPE = EPROTOTYPE; + WSAENOPROTOOPT = ENOPROTOOPT; + WSAEPROTONOSUPPORT = EPROTONOSUPPORT; + WSAESOCKTNOSUPPORT = ESOCKTNOSUPPORT; + WSAEOPNOTSUPP = EOPNOTSUPP; + WSAEPFNOSUPPORT = EPFNOSUPPORT; + WSAEAFNOSUPPORT = EAFNOSUPPORT; + WSAEADDRINUSE = EADDRINUSE; + WSAEADDRNOTAVAIL = EADDRNOTAVAIL; + WSAENETDOWN = ENETDOWN; + WSAENETUNREACH = ENETUNREACH; + WSAENETRESET = ENETRESET; + WSAECONNABORTED = ECONNABORTED; + WSAECONNRESET = ECONNRESET; + WSAENOBUFS = ENOBUFS; + WSAEISCONN = EISCONN; + WSAENOTCONN = ENOTCONN; + WSAESHUTDOWN = ESHUTDOWN; + WSAETOOMANYREFS = ETOOMANYREFS; + WSAETIMEDOUT = ETIMEDOUT; + WSAECONNREFUSED = ECONNREFUSED; + WSAELOOP = ELOOP; + WSAENAMETOOLONG = ENAMETOOLONG; + WSAEHOSTDOWN = EHOSTDOWN; + WSAEHOSTUNREACH = EHOSTUNREACH; + WSAENOTEMPTY = ENOTEMPTY; + WSAEPROCLIM = -1; + WSAEUSERS = EUSERS; + WSAEDQUOT = EDQUOT; + WSAESTALE = ESTALE; + WSAEREMOTE = EREMOTE; + WSASYSNOTREADY = -2; + WSAVERNOTSUPPORTED = -3; + WSANOTINITIALISED = -4; + WSAEDISCON = -5; + WSAHOST_NOT_FOUND = HOST_NOT_FOUND; + WSATRY_AGAIN = TRY_AGAIN; + WSANO_RECOVERY = NO_RECOVERY; + WSANO_DATA = -6; + + EAI_BADFLAGS = -1; { Invalid value for `ai_flags' field. } + EAI_NONAME = -2; { NAME or SERVICE is unknown. } + EAI_AGAIN = -3; { Temporary failure in name resolution. } + EAI_FAIL = -4; { Non-recoverable failure in name res. } + EAI_NODATA = -5; { No address associated with NAME. } + EAI_FAMILY = -6; { `ai_family' not supported. } + EAI_SOCKTYPE = -7; { `ai_socktype' not supported. } + EAI_SERVICE = -8; { SERVICE not supported for `ai_socktype'. } + EAI_ADDRFAMILY = -9; { Address family for NAME not supported. } + EAI_MEMORY = -10; { Memory allocation failure. } + EAI_SYSTEM = -11; { System error returned in `errno'. } + +const + WSADESCRIPTION_LEN = 256; + WSASYS_STATUS_LEN = 128; +type + PWSAData = ^TWSAData; + TWSAData = packed record + wVersion: Word; + wHighVersion: Word; + szDescription: array[0..WSADESCRIPTION_LEN] of Char; + szSystemStatus: array[0..WSASYS_STATUS_LEN] of Char; + iMaxSockets: Word; + iMaxUdpDg: Word; + lpVendorInfo: PChar; + end; + + function IN6_IS_ADDR_UNSPECIFIED(const a: PInAddr6): boolean; + function IN6_IS_ADDR_LOOPBACK(const a: PInAddr6): boolean; + function IN6_IS_ADDR_LINKLOCAL(const a: PInAddr6): boolean; + function IN6_IS_ADDR_SITELOCAL(const a: PInAddr6): boolean; + function IN6_IS_ADDR_MULTICAST(const a: PInAddr6): boolean; + function IN6_ADDR_EQUAL(const a: PInAddr6; const b: PInAddr6):boolean; + procedure SET_IN6_IF_ADDR_ANY (const a: PInAddr6); + procedure SET_LOOPBACK_ADDR6 (const a: PInAddr6); +var + in6addr_any, in6addr_loopback : TInAddr6; + +procedure FD_CLR(Socket: TSocket; var FDSet: TFDSet); +function FD_ISSET(Socket: TSocket; var FDSet: TFDSet): Boolean; +procedure FD_SET(Socket: TSocket; var FDSet: TFDSet); +procedure FD_ZERO(var FDSet: TFDSet); + +{=============================================================================} + +type + TWSAStartup = function(wVersionRequired: Word; var WSData: TWSAData): Integer; + cdecl; + TWSACleanup = function: Integer; + cdecl; + TWSAGetLastError = function: Integer; + cdecl; + TGetServByName = function(name, proto: PChar): PServEnt; + cdecl; + TGetServByPort = function(port: Integer; proto: PChar): PServEnt; + cdecl; + TGetProtoByName = function(name: PChar): PProtoEnt; + cdecl; + TGetProtoByNumber = function(proto: Integer): PProtoEnt; + cdecl; + TGetHostByName = function(name: PChar): PHostEnt; + cdecl; + TGetHostByAddr = function(addr: Pointer; len, Struc: Integer): PHostEnt; + cdecl; + TGetHostName = function(name: PChar; len: Integer): Integer; + cdecl; + TShutdown = function(s: TSocket; how: Integer): Integer; + cdecl; + TSetSockOpt = function(s: TSocket; level, optname: Integer; optval: PChar; + optlen: Integer): Integer; + cdecl; + TGetSockOpt = function(s: TSocket; level, optname: Integer; optval: PChar; + var optlen: Integer): Integer; + cdecl; + TSendTo = function(s: TSocket; const Buf; len, flags: Integer; addrto: PSockAddr; + tolen: Integer): Integer; + cdecl; + TSend = function(s: TSocket; const Buf; len, flags: Integer): Integer; + cdecl; + TRecv = function(s: TSocket; var Buf; len, flags: Integer): Integer; + cdecl; + TRecvFrom = function(s: TSocket; var Buf; len, flags: Integer; from: PSockAddr; + var fromlen: Integer): Integer; + cdecl; + Tntohs = function(netshort: u_short): u_short; + cdecl; + Tntohl = function(netlong: u_long): u_long; + cdecl; + TListen = function(s: TSocket; backlog: Integer): Integer; + cdecl; + TIoctlSocket = function(s: TSocket; cmd: DWORD; var arg: integer): Integer; + cdecl; + TInet_ntoa = function(inaddr: TInAddr): PChar; + cdecl; + TInet_addr = function(cp: PChar): u_long; + cdecl; + Thtons = function(hostshort: u_short): u_short; + cdecl; + Thtonl = function(hostlong: u_long): u_long; + cdecl; + TGetSockName = function(s: TSocket; name: PSockAddr; var namelen: Integer): Integer; + cdecl; + TGetPeerName = function(s: TSocket; name: PSockAddr; var namelen: Integer): Integer; + cdecl; + TConnect = function(s: TSocket; name: PSockAddr; namelen: Integer): Integer; + cdecl; + TCloseSocket = function(s: TSocket): Integer; + cdecl; + TBind = function(s: TSocket; addr: PSockAddr; namelen: Integer): Integer; + cdecl; + TAccept = function(s: TSocket; addr: PSockAddr; var addrlen: Integer): TSocket; + cdecl; + TTSocket = function(af, Struc, Protocol: Integer): TSocket; + cdecl; + TSelect = function(nfds: Integer; readfds, writefds, exceptfds: PFDSet; + timeout: PTimeVal): Longint; + cdecl; + + TGetAddrInfo = function(NodeName: PChar; ServName: PChar; Hints: PAddrInfo; + var Addrinfo: PAddrInfo): integer; + cdecl; + TFreeAddrInfo = procedure(ai: PAddrInfo); + cdecl; + TGetNameInfo = function( addr: PSockAddr; namelen: Integer; host: PChar; + hostlen: DWORD; serv: PChar; servlen: DWORD; flags: integer): integer; + cdecl; + +var + WSAStartup: TWSAStartup = nil; + WSACleanup: TWSACleanup = nil; + WSAGetLastError: TWSAGetLastError = nil; + GetServByName: TGetServByName = nil; + GetServByPort: TGetServByPort = nil; + GetProtoByName: TGetProtoByName = nil; + GetProtoByNumber: TGetProtoByNumber = nil; + GetHostByName: TGetHostByName = nil; + GetHostByAddr: TGetHostByAddr = nil; + ssGetHostName: TGetHostName = nil; + Shutdown: TShutdown = nil; + SetSockOpt: TSetSockOpt = nil; + GetSockOpt: TGetSockOpt = nil; + ssSendTo: TSendTo = nil; + ssSend: TSend = nil; + ssRecv: TRecv = nil; + ssRecvFrom: TRecvFrom = nil; + ntohs: Tntohs = nil; + ntohl: Tntohl = nil; + Listen: TListen = nil; + IoctlSocket: TIoctlSocket = nil; + Inet_ntoa: TInet_ntoa = nil; + Inet_addr: TInet_addr = nil; + htons: Thtons = nil; + htonl: Thtonl = nil; + ssGetSockName: TGetSockName = nil; + ssGetPeerName: TGetPeerName = nil; + ssConnect: TConnect = nil; + CloseSocket: TCloseSocket = nil; + ssBind: TBind = nil; + ssAccept: TAccept = nil; + Socket: TTSocket = nil; + Select: TSelect = nil; + + GetAddrInfo: TGetAddrInfo = nil; + FreeAddrInfo: TFreeAddrInfo = nil; + GetNameInfo: TGetNameInfo = nil; + +function LSWSAStartup(wVersionRequired: Word; var WSData: TWSAData): Integer; cdecl; +function LSWSACleanup: Integer; cdecl; +function LSWSAGetLastError: Integer; cdecl; + +var + SynSockCS: SyncObjs.TCriticalSection; + SockEnhancedApi: Boolean; + SockWship6Api: Boolean; + +type + TVarSin = packed record + case integer of + 0: (AddressFamily: u_short); + 1: ( + case sin_family: u_short of + AF_INET: (sin_port: u_short; + sin_addr: TInAddr; + sin_zero: array[0..7] of Char); + AF_INET6: (sin6_port: u_short; + sin6_flowinfo: u_long; + sin6_addr: TInAddr6; + sin6_scope_id: u_long); + ); + end; + +function SizeOfVarSin(sin: TVarSin): integer; + +function Bind(s: TSocket; const addr: TVarSin): Integer; +function Connect(s: TSocket; const name: TVarSin): Integer; +function GetSockName(s: TSocket; var name: TVarSin): Integer; +function GetPeerName(s: TSocket; var name: TVarSin): Integer; +function GetHostName: string; +function Send(s: TSocket; Buf: TMemory; len, flags: Integer): Integer; +function Recv(s: TSocket; Buf: TMemory; len, flags: Integer): Integer; +function SendTo(s: TSocket; Buf: TMemory; len, flags: Integer; addrto: TVarSin): Integer; +function RecvFrom(s: TSocket; Buf: TMemory; len, flags: Integer; var from: TVarSin): Integer; +function Accept(s: TSocket; var addr: TVarSin): TSocket; + +function IsNewApi(Family: integer): Boolean; +function SetVarSin(var Sin: TVarSin; IP, Port: string; Family, SockProtocol, SockType: integer; PreferIP4: Boolean): integer; +function GetSinIP(Sin: TVarSin): string; +function GetSinPort(Sin: TVarSin): Integer; +procedure ResolveNameToIP(Name: string; Family, SockProtocol, SockType: integer; const IPList: TStrings); +function ResolveIPToName(IP: string; Family, SockProtocol, SockType: integer): string; +function ResolvePort(Port: string; Family, SockProtocol, SockType: integer): Word; + +{==============================================================================} +implementation + +var + SynSockCount: Integer = 0; + LibHandle: TLibHandle = 0; + Libwship6Handle: TLibHandle = 0; + +function IN6_IS_ADDR_UNSPECIFIED(const a: PInAddr6): boolean; +begin + Result := ((a^.u6_addr32[0] = 0) and (a^.u6_addr32[1] = 0) and + (a^.u6_addr32[2] = 0) and (a^.u6_addr32[3] = 0)); +end; + +function IN6_IS_ADDR_LOOPBACK(const a: PInAddr6): boolean; +begin + Result := ((a^.u6_addr32[0] = 0) and (a^.u6_addr32[1] = 0) and + (a^.u6_addr32[2] = 0) and + (a^.u6_addr8[12] = 0) and (a^.u6_addr8[13] = 0) and + (a^.u6_addr8[14] = 0) and (a^.u6_addr8[15] = 1)); +end; + +function IN6_IS_ADDR_LINKLOCAL(const a: PInAddr6): boolean; +begin + Result := ((a^.u6_addr8[0] = $FE) and (a^.u6_addr8[1] = $80)); +end; + +function IN6_IS_ADDR_SITELOCAL(const a: PInAddr6): boolean; +begin + Result := ((a^.u6_addr8[0] = $FE) and (a^.u6_addr8[1] = $C0)); +end; + +function IN6_IS_ADDR_MULTICAST(const a: PInAddr6): boolean; +begin + Result := (a^.u6_addr8[0] = $FF); +end; + +function IN6_ADDR_EQUAL(const a: PInAddr6; const b: PInAddr6): boolean; +begin + Result := (CompareMem( a, b, sizeof(TInAddr6))); +end; + +procedure SET_IN6_IF_ADDR_ANY (const a: PInAddr6); +begin + FillChar(a^, sizeof(TInAddr6), 0); +end; + +procedure SET_LOOPBACK_ADDR6 (const a: PInAddr6); +begin + FillChar(a^, sizeof(TInAddr6), 0); + a^.u6_addr8[15] := 1; +end; + +{=============================================================================} +var +{$IFNDEF VER1_0} //FTP version 1.0.x + errno_loc: function: PInteger cdecl = nil; +{$ELSE} + errno_loc: function: PInteger = nil; cdecl; +{$ENDIF} + +function LSWSAStartup(wVersionRequired: Word; var WSData: TWSAData): Integer; +begin + with WSData do + begin + wVersion := wVersionRequired; + wHighVersion := $202; + szDescription := 'Synsock - Synapse Platform Independent Socket Layer'; + szSystemStatus := 'Running on Linux'; + iMaxSockets := 32768; + iMaxUdpDg := 8192; + end; + Result := 0; +end; + +function LSWSACleanup: Integer; +begin + Result := 0; +end; + +function LSWSAGetLastError: Integer; +var + p: PInteger; +begin + p := errno_loc; + Result := p^; +end; + +function __FDELT(Socket: TSocket): Integer; +begin + Result := Socket div __NFDBITS; +end; + +function __FDMASK(Socket: TSocket): __fd_mask; +begin + Result := LongWord(1) shl (Socket mod __NFDBITS); +end; + +function FD_ISSET(Socket: TSocket; var fdset: TFDSet): Boolean; +begin + Result := (fdset.fds_bits[__FDELT(Socket)] and __FDMASK(Socket)) <> 0; +end; + +procedure FD_SET(Socket: TSocket; var fdset: TFDSet); +begin + fdset.fds_bits[__FDELT(Socket)] := fdset.fds_bits[__FDELT(Socket)] or __FDMASK(Socket); +end; + +procedure FD_CLR(Socket: TSocket; var fdset: TFDSet); +begin + fdset.fds_bits[__FDELT(Socket)] := fdset.fds_bits[__FDELT(Socket)] and (not __FDMASK(Socket)); +end; + +procedure FD_ZERO(var fdset: TFDSet); +var + I: Integer; +begin + with fdset do + for I := Low(fds_bits) to High(fds_bits) do + fds_bits[I] := 0; +end; + +{=============================================================================} + +function SizeOfVarSin(sin: TVarSin): integer; +begin + case sin.sin_family of + AF_INET: + Result := SizeOf(TSockAddrIn); + AF_INET6: + Result := SizeOf(TSockAddrIn6); + else + Result := 0; + end; +end; + +{=============================================================================} + +function Bind(s: TSocket; const addr: TVarSin): Integer; +begin + Result := ssBind(s, @addr, SizeOfVarSin(addr)); +end; + +function Connect(s: TSocket; const name: TVarSin): Integer; +begin + Result := ssConnect(s, @name, SizeOfVarSin(name)); +end; + +function GetSockName(s: TSocket; var name: TVarSin): Integer; +var + len: integer; +begin + len := SizeOf(name); + FillChar(name, len, 0); + Result := ssGetSockName(s, @name, Len); +end; + +function GetPeerName(s: TSocket; var name: TVarSin): Integer; +var + len: integer; +begin + len := SizeOf(name); + FillChar(name, len, 0); + Result := ssGetPeerName(s, @name, Len); +end; + +function GetHostName: string; +var + s: string; +begin + Result := ''; + setlength(s, 255); + ssGetHostName(pchar(s), Length(s) - 1); + Result := Pchar(s); +end; + +function Send(s: TSocket; Buf: TMemory; len, flags: Integer): Integer; +begin + Result := ssSend(s, Buf^, len, flags); +end; + +function Recv(s: TSocket; Buf: TMemory; len, flags: Integer): Integer; +begin + Result := ssRecv(s, Buf^, len, flags); +end; + +function SendTo(s: TSocket; Buf: TMemory; len, flags: Integer; addrto: TVarSin): Integer; +begin + Result := ssSendTo(s, Buf^, len, flags, @addrto, SizeOfVarSin(addrto)); +end; + +function RecvFrom(s: TSocket; Buf: TMemory; len, flags: Integer; var from: TVarSin): Integer; +var + x: integer; +begin + x := SizeOf(from); + Result := ssRecvFrom(s, Buf^, len, flags, @from, x); +end; + +function Accept(s: TSocket; var addr: TVarSin): TSocket; +var + x: integer; +begin + x := SizeOf(addr); + Result := ssAccept(s, @addr, x); +end; + +{=============================================================================} +function IsNewApi(Family: integer): Boolean; +begin + Result := SockEnhancedApi; + if not Result then + Result := (Family = AF_INET6) and SockWship6Api; +end; + +function SetVarSin(var Sin: TVarSin; IP, Port: string; Family, SockProtocol, SockType: integer; PreferIP4: Boolean): integer; +type + pu_long = ^u_long; +var + ProtoEnt: PProtoEnt; + ServEnt: PServEnt; + HostEnt: PHostEnt; + r: integer; + Hints1, Hints2: TAddrInfo; + Sin1, Sin2: TVarSin; + TwoPass: boolean; + + function GetAddr(const IP, port: string; Hints: TAddrInfo; var Sin: TVarSin): integer; + var + Addr: PAddrInfo; + begin + Addr := nil; + try + FillChar(Sin, Sizeof(Sin), 0); + if Hints.ai_socktype = SOCK_RAW then + begin + Hints.ai_socktype := 0; + Hints.ai_protocol := 0; + Result := synsock.GetAddrInfo(PChar(IP), nil, @Hints, Addr); + end + else + begin + if (IP = cAnyHost) or (IP = c6AnyHost) then + begin + Hints.ai_flags := AI_PASSIVE; + Result := synsock.GetAddrInfo(nil, PChar(Port), @Hints, Addr); + end + else + if (IP = cLocalhost) or (IP = c6Localhost) then + begin + Result := synsock.GetAddrInfo(nil, PChar(Port), @Hints, Addr); + end + else + begin + Result := synsock.GetAddrInfo(PChar(IP), PChar(Port), @Hints, Addr); + end; + end; + if Result = 0 then + if (Addr <> nil) then + Move(Addr^.ai_addr^, Sin, Addr^.ai_addrlen); + finally + if Assigned(Addr) then + synsock.FreeAddrInfo(Addr); + end; + end; + +begin + Result := 0; + FillChar(Sin, Sizeof(Sin), 0); + if not IsNewApi(family) then + begin + SynSockCS.Enter; + try + Sin.sin_family := AF_INET; + ProtoEnt := synsock.GetProtoByNumber(SockProtocol); + ServEnt := nil; + if ProtoEnt <> nil then + ServEnt := synsock.GetServByName(PChar(Port), ProtoEnt^.p_name); + if ServEnt = nil then + Sin.sin_port := synsock.htons(StrToIntDef(Port, 0)) + else + Sin.sin_port := ServEnt^.s_port; + if IP = cBroadcast then + Sin.sin_addr.s_addr := u_long(INADDR_BROADCAST) + else + begin + Sin.sin_addr.s_addr := synsock.inet_addr(PChar(IP)); + if Sin.sin_addr.s_addr = u_long(INADDR_NONE) then + begin + HostEnt := synsock.GetHostByName(PChar(IP)); + Result := synsock.WSAGetLastError; + if HostEnt <> nil then + Sin.sin_addr.S_addr := u_long(Pu_long(HostEnt^.h_addr_list^)^); + end; + end; + finally + SynSockCS.Leave; + end; + end + else + begin + FillChar(Hints1, Sizeof(Hints1), 0); + FillChar(Hints2, Sizeof(Hints2), 0); + TwoPass := False; + if Family = AF_UNSPEC then + begin + if PreferIP4 then + begin + Hints1.ai_family := AF_INET; + Hints2.ai_family := AF_INET6; + TwoPass := True; + end + else + begin + Hints2.ai_family := AF_INET; + Hints1.ai_family := AF_INET6; + TwoPass := True; + end; + end + else + Hints1.ai_family := Family; + + Hints1.ai_socktype := SockType; + Hints1.ai_protocol := SockProtocol; + Hints2.ai_socktype := Hints1.ai_socktype; + Hints2.ai_protocol := Hints1.ai_protocol; + + r := GetAddr(IP, Port, Hints1, Sin1); + Result := r; + sin := sin1; + if r <> 0 then + if TwoPass then + begin + r := GetAddr(IP, Port, Hints2, Sin2); + Result := r; + if r = 0 then + sin := sin2; + end; + end; +end; + +function GetSinIP(Sin: TVarSin): string; +var + p: PChar; + host, serv: string; + hostlen, servlen: integer; + r: integer; +begin + Result := ''; + if not IsNewApi(Sin.AddressFamily) then + begin + p := synsock.inet_ntoa(Sin.sin_addr); + if p <> nil then + Result := p; + end + else + begin + hostlen := NI_MAXHOST; + servlen := NI_MAXSERV; + setlength(host, hostlen); + setlength(serv, servlen); + r := getnameinfo(@sin, SizeOfVarSin(sin), PChar(host), hostlen, + PChar(serv), servlen, NI_NUMERICHOST + NI_NUMERICSERV); + if r = 0 then + Result := PChar(host); + end; +end; + +function GetSinPort(Sin: TVarSin): Integer; +begin + if (Sin.sin_family = AF_INET6) then + Result := synsock.ntohs(Sin.sin6_port) + else + Result := synsock.ntohs(Sin.sin_port); +end; + +procedure ResolveNameToIP(Name: string; Family, SockProtocol, SockType: integer; const IPList: TStrings); +type + TaPInAddr = array[0..250] of PInAddr; + PaPInAddr = ^TaPInAddr; +var + Hints: TAddrInfo; + Addr: PAddrInfo; + AddrNext: PAddrInfo; + r: integer; + host, serv: string; + hostlen, servlen: integer; + RemoteHost: PHostEnt; + IP: u_long; + PAdrPtr: PaPInAddr; + i: Integer; + s: string; + InAddr: TInAddr; +begin + IPList.Clear; + if not IsNewApi(Family) then + begin + IP := synsock.inet_addr(PChar(Name)); + if IP = u_long(INADDR_NONE) then + begin + SynSockCS.Enter; + try + RemoteHost := synsock.GetHostByName(PChar(Name)); + if RemoteHost <> nil then + begin + PAdrPtr := PAPInAddr(RemoteHost^.h_addr_list); + i := 0; + while PAdrPtr^[i] <> nil do + begin + InAddr := PAdrPtr^[i]^; + s := Format('%d.%d.%d.%d', [InAddr.S_bytes[0], InAddr.S_bytes[1], + InAddr.S_bytes[2], InAddr.S_bytes[3]]); + IPList.Add(s); + Inc(i); + end; + end; + finally + SynSockCS.Leave; + end; + end + else + IPList.Add(Name); + end + else + begin + Addr := nil; + try + FillChar(Hints, Sizeof(Hints), 0); + Hints.ai_family := AF_UNSPEC; + Hints.ai_socktype := SockType; + Hints.ai_protocol := SockProtocol; + Hints.ai_flags := 0; + r := synsock.GetAddrInfo(PChar(Name), nil, @Hints, Addr); + if r = 0 then + begin + AddrNext := Addr; + while not(AddrNext = nil) do + begin + if not(((Family = AF_INET6) and (AddrNext^.ai_family = AF_INET)) + or ((Family = AF_INET) and (AddrNext^.ai_family = AF_INET6))) then + begin + hostlen := NI_MAXHOST; + servlen := NI_MAXSERV; + setlength(host, hostlen); + setlength(serv, servlen); + r := getnameinfo(AddrNext^.ai_addr, AddrNext^.ai_addrlen, + PChar(host), hostlen, PChar(serv), servlen, + NI_NUMERICHOST + NI_NUMERICSERV); + if r = 0 then + begin + host := PChar(host); + IPList.Add(host); + end; + end; + AddrNext := AddrNext^.ai_next; + end; + end; + finally + if Assigned(Addr) then + synsock.FreeAddrInfo(Addr); + end; + end; + if IPList.Count = 0 then + IPList.Add(cAnyHost); +end; + +function ResolvePort(Port: string; Family, SockProtocol, SockType: integer): Word; +var + ProtoEnt: PProtoEnt; + ServEnt: PServEnt; + Hints: TAddrInfo; + Addr: PAddrInfo; + r: integer; +begin + Result := 0; + if not IsNewApi(Family) then + begin + SynSockCS.Enter; + try + ProtoEnt := synsock.GetProtoByNumber(SockProtocol); + ServEnt := nil; + if ProtoEnt <> nil then + ServEnt := synsock.GetServByName(PChar(Port), ProtoEnt^.p_name); + if ServEnt = nil then + Result := StrToIntDef(Port, 0) + else + Result := synsock.htons(ServEnt^.s_port); + finally + SynSockCS.Leave; + end; + end + else + begin + Addr := nil; + try + FillChar(Hints, Sizeof(Hints), 0); + Hints.ai_family := AF_UNSPEC; + Hints.ai_socktype := SockType; + Hints.ai_protocol := Sockprotocol; + Hints.ai_flags := AI_PASSIVE; + r := synsock.GetAddrInfo(nil, PChar(Port), @Hints, Addr); + if (r = 0) and Assigned(Addr) then + begin + if Addr^.ai_family = AF_INET then + Result := synsock.htons(Addr^.ai_addr^.sin_port); + if Addr^.ai_family = AF_INET6 then + Result := synsock.htons(PSockAddrIn6(Addr^.ai_addr)^.sin6_port); + end; + finally + if Assigned(Addr) then + synsock.FreeAddrInfo(Addr); + end; + end; +end; + +function ResolveIPToName(IP: string; Family, SockProtocol, SockType: integer): string; +var + Hints: TAddrInfo; + Addr: PAddrInfo; + r: integer; + host, serv: string; + hostlen, servlen: integer; + RemoteHost: PHostEnt; + IPn: u_long; +begin + Result := IP; + if not IsNewApi(Family) then + begin + IPn := synsock.inet_addr(PChar(IP)); + if IPn <> u_long(INADDR_NONE) then + begin + SynSockCS.Enter; + try + RemoteHost := GetHostByAddr(@IPn, SizeOf(IPn), AF_INET); + if RemoteHost <> nil then + Result := RemoteHost^.h_name; + finally + SynSockCS.Leave; + end; + end; + end + else + begin + Addr := nil; + try + FillChar(Hints, Sizeof(Hints), 0); + Hints.ai_family := AF_UNSPEC; + Hints.ai_socktype := SockType; + Hints.ai_protocol := SockProtocol; + Hints.ai_flags := 0; + r := synsock.GetAddrInfo(PChar(IP), nil, @Hints, Addr); + if (r = 0) and Assigned(Addr)then + begin + hostlen := NI_MAXHOST; + servlen := NI_MAXSERV; + setlength(host, hostlen); + setlength(serv, servlen); + r := getnameinfo(Addr^.ai_addr, Addr^.ai_addrlen, + PChar(host), hostlen, PChar(serv), servlen, + NI_NUMERICSERV); + if r = 0 then + Result := PChar(host); + end; + finally + if Assigned(Addr) then + synsock.FreeAddrInfo(Addr); + end; + end; +end; + +{=============================================================================} + +function InitSocketInterface(stack: string): Boolean; +begin + Result := False; + SockEnhancedApi := False; + if stack = '' then + stack := DLLStackName; + SynSockCS.Enter; + try + if SynSockCount = 0 then + begin + SockEnhancedApi := False; + SockWship6Api := False; + Libc.Signal(Libc.SIGPIPE, TSignalHandler(Libc.SIG_IGN)); + LibHandle := LoadLibrary(PChar(Stack)); + if LibHandle <> 0 then + begin + errno_loc := GetProcAddress(LibHandle, PChar('__errno_location')); + CloseSocket := GetProcAddress(LibHandle, PChar('close')); + IoctlSocket := GetProcAddress(LibHandle, PChar('ioctl')); + WSAGetLastError := LSWSAGetLastError; + WSAStartup := LSWSAStartup; + WSACleanup := LSWSACleanup; + ssAccept := GetProcAddress(LibHandle, PChar('accept')); + ssBind := GetProcAddress(LibHandle, PChar('bind')); + ssConnect := GetProcAddress(LibHandle, PChar('connect')); + ssGetPeerName := GetProcAddress(LibHandle, PChar('getpeername')); + ssGetSockName := GetProcAddress(LibHandle, PChar('getsockname')); + GetSockOpt := GetProcAddress(LibHandle, PChar('getsockopt')); + Htonl := GetProcAddress(LibHandle, PChar('htonl')); + Htons := GetProcAddress(LibHandle, PChar('htons')); + Inet_Addr := GetProcAddress(LibHandle, PChar('inet_addr')); + Inet_Ntoa := GetProcAddress(LibHandle, PChar('inet_ntoa')); + Listen := GetProcAddress(LibHandle, PChar('listen')); + Ntohl := GetProcAddress(LibHandle, PChar('ntohl')); + Ntohs := GetProcAddress(LibHandle, PChar('ntohs')); + ssRecv := GetProcAddress(LibHandle, PChar('recv')); + ssRecvFrom := GetProcAddress(LibHandle, PChar('recvfrom')); + Select := GetProcAddress(LibHandle, PChar('select')); + ssSend := GetProcAddress(LibHandle, PChar('send')); + ssSendTo := GetProcAddress(LibHandle, PChar('sendto')); + SetSockOpt := GetProcAddress(LibHandle, PChar('setsockopt')); + ShutDown := GetProcAddress(LibHandle, PChar('shutdown')); + Socket := GetProcAddress(LibHandle, PChar('socket')); + GetHostByAddr := GetProcAddress(LibHandle, PChar('gethostbyaddr')); + GetHostByName := GetProcAddress(LibHandle, PChar('gethostbyname')); + GetProtoByName := GetProcAddress(LibHandle, PChar('getprotobyname')); + GetProtoByNumber := GetProcAddress(LibHandle, PChar('getprotobynumber')); + GetServByName := GetProcAddress(LibHandle, PChar('getservbyname')); + GetServByPort := GetProcAddress(LibHandle, PChar('getservbyport')); + ssGetHostName := GetProcAddress(LibHandle, PChar('gethostname')); + +{$IFNDEF FORCEOLDAPI} + GetAddrInfo := GetProcAddress(LibHandle, PChar('getaddrinfo')); + FreeAddrInfo := GetProcAddress(LibHandle, PChar('freeaddrinfo')); + GetNameInfo := GetProcAddress(LibHandle, PChar('getnameinfo')); + SockEnhancedApi := Assigned(GetAddrInfo) and Assigned(FreeAddrInfo) + and Assigned(GetNameInfo); +{$ENDIF} + Result := True; + end; + end + else Result := True; + if Result then + Inc(SynSockCount); + finally + SynSockCS.Leave; + end; +end; + +function DestroySocketInterface: Boolean; +begin + SynSockCS.Enter; + try + Dec(SynSockCount); + if SynSockCount < 0 then + SynSockCount := 0; + if SynSockCount = 0 then + begin + if LibHandle <> 0 then + begin + FreeLibrary(libHandle); + LibHandle := 0; + end; + if LibWship6Handle <> 0 then + begin + FreeLibrary(LibWship6Handle); + LibWship6Handle := 0; + end; + end; + finally + SynSockCS.Leave; + end; + Result := True; +end; + +initialization +begin + SynSockCS := SyncObjs.TCriticalSection.Create; + SET_IN6_IF_ADDR_ANY (@in6addr_any); + SET_LOOPBACK_ADDR6 (@in6addr_loopback); +end; + +finalization +begin + SynSockCS.Free; +end; + +{$ENDIF} + diff --git a/synapse/sswin32.inc b/synapse/sswin32.inc new file mode 100644 index 0000000..0b55e00 --- /dev/null +++ b/synapse/sswin32.inc @@ -0,0 +1,1615 @@ +{==============================================================================| +| Project : Ararat Synapse | 002.003.000 | +|==============================================================================| +| Content: Socket Independent Platform Layer - Win32/64 definition include | +|==============================================================================| +| 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)2003-2011. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +{:@exclude} + +//{$DEFINE WINSOCK1} +{Note about define WINSOCK1: +If you activate this compiler directive, then socket interface level 1.1 is +used instead default level 2.2. Level 2.2 is not available on old W95, however +you can install update. +} + +//{$DEFINE FORCEOLDAPI} +{Note about define FORCEOLDAPI: +If you activate this compiler directive, then is allways used old socket API +for name resolution. If you leave this directive inactive, then the new API +is used, when running system allows it. + +For IPv6 support you must have new API! +} + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$H+} +{$IFDEF VER125} + {$DEFINE BCB} +{$ENDIF} +{$IFDEF BCB} + {$ObjExportAll On} + (*$HPPEMIT '/* EDE 2003-02-19 */' *) + (*$HPPEMIT 'namespace Synsock { using System::Shortint; }' *) + (*$HPPEMIT '#undef h_addr' *) + (*$HPPEMIT '#undef IOCPARM_MASK' *) + (*$HPPEMIT '#undef FD_SETSIZE' *) + (*$HPPEMIT '#undef IOC_VOID' *) + (*$HPPEMIT '#undef IOC_OUT' *) + (*$HPPEMIT '#undef IOC_IN' *) + (*$HPPEMIT '#undef IOC_INOUT' *) + (*$HPPEMIT '#undef FIONREAD' *) + (*$HPPEMIT '#undef FIONBIO' *) + (*$HPPEMIT '#undef FIOASYNC' *) + (*$HPPEMIT '#undef IPPROTO_IP' *) + (*$HPPEMIT '#undef IPPROTO_ICMP' *) + (*$HPPEMIT '#undef IPPROTO_IGMP' *) + (*$HPPEMIT '#undef IPPROTO_TCP' *) + (*$HPPEMIT '#undef IPPROTO_UDP' *) + (*$HPPEMIT '#undef IPPROTO_RAW' *) + (*$HPPEMIT '#undef IPPROTO_MAX' *) + (*$HPPEMIT '#undef INADDR_ANY' *) + (*$HPPEMIT '#undef INADDR_LOOPBACK' *) + (*$HPPEMIT '#undef INADDR_BROADCAST' *) + (*$HPPEMIT '#undef INADDR_NONE' *) + (*$HPPEMIT '#undef INVALID_SOCKET' *) + (*$HPPEMIT '#undef SOCKET_ERROR' *) + (*$HPPEMIT '#undef WSADESCRIPTION_LEN' *) + (*$HPPEMIT '#undef WSASYS_STATUS_LEN' *) + (*$HPPEMIT '#undef IP_OPTIONS' *) + (*$HPPEMIT '#undef IP_TOS' *) + (*$HPPEMIT '#undef IP_TTL' *) + (*$HPPEMIT '#undef IP_MULTICAST_IF' *) + (*$HPPEMIT '#undef IP_MULTICAST_TTL' *) + (*$HPPEMIT '#undef IP_MULTICAST_LOOP' *) + (*$HPPEMIT '#undef IP_ADD_MEMBERSHIP' *) + (*$HPPEMIT '#undef IP_DROP_MEMBERSHIP' *) + (*$HPPEMIT '#undef IP_DONTFRAGMENT' *) + (*$HPPEMIT '#undef IP_DEFAULT_MULTICAST_TTL' *) + (*$HPPEMIT '#undef IP_DEFAULT_MULTICAST_LOOP' *) + (*$HPPEMIT '#undef IP_MAX_MEMBERSHIPS' *) + (*$HPPEMIT '#undef SOL_SOCKET' *) + (*$HPPEMIT '#undef SO_DEBUG' *) + (*$HPPEMIT '#undef SO_ACCEPTCONN' *) + (*$HPPEMIT '#undef SO_REUSEADDR' *) + (*$HPPEMIT '#undef SO_KEEPALIVE' *) + (*$HPPEMIT '#undef SO_DONTROUTE' *) + (*$HPPEMIT '#undef SO_BROADCAST' *) + (*$HPPEMIT '#undef SO_USELOOPBACK' *) + (*$HPPEMIT '#undef SO_LINGER' *) + (*$HPPEMIT '#undef SO_OOBINLINE' *) + (*$HPPEMIT '#undef SO_DONTLINGER' *) + (*$HPPEMIT '#undef SO_SNDBUF' *) + (*$HPPEMIT '#undef SO_RCVBUF' *) + (*$HPPEMIT '#undef SO_SNDLOWAT' *) + (*$HPPEMIT '#undef SO_RCVLOWAT' *) + (*$HPPEMIT '#undef SO_SNDTIMEO' *) + (*$HPPEMIT '#undef SO_RCVTIMEO' *) + (*$HPPEMIT '#undef SO_ERROR' *) + (*$HPPEMIT '#undef SO_OPENTYPE' *) + (*$HPPEMIT '#undef SO_SYNCHRONOUS_ALERT' *) + (*$HPPEMIT '#undef SO_SYNCHRONOUS_NONALERT' *) + (*$HPPEMIT '#undef SO_MAXDG' *) + (*$HPPEMIT '#undef SO_MAXPATHDG' *) + (*$HPPEMIT '#undef SO_UPDATE_ACCEPT_CONTEXT' *) + (*$HPPEMIT '#undef SO_CONNECT_TIME' *) + (*$HPPEMIT '#undef SO_TYPE' *) + (*$HPPEMIT '#undef SOCK_STREAM' *) + (*$HPPEMIT '#undef SOCK_DGRAM' *) + (*$HPPEMIT '#undef SOCK_RAW' *) + (*$HPPEMIT '#undef SOCK_RDM' *) + (*$HPPEMIT '#undef SOCK_SEQPACKET' *) + (*$HPPEMIT '#undef TCP_NODELAY' *) + (*$HPPEMIT '#undef AF_UNSPEC' *) + (*$HPPEMIT '#undef SOMAXCONN' *) + (*$HPPEMIT '#undef AF_INET' *) + (*$HPPEMIT '#undef AF_MAX' *) + (*$HPPEMIT '#undef PF_UNSPEC' *) + (*$HPPEMIT '#undef PF_INET' *) + (*$HPPEMIT '#undef PF_MAX' *) + (*$HPPEMIT '#undef MSG_OOB' *) + (*$HPPEMIT '#undef MSG_PEEK' *) + (*$HPPEMIT '#undef WSABASEERR' *) + (*$HPPEMIT '#undef WSAEINTR' *) + (*$HPPEMIT '#undef WSAEBADF' *) + (*$HPPEMIT '#undef WSAEACCES' *) + (*$HPPEMIT '#undef WSAEFAULT' *) + (*$HPPEMIT '#undef WSAEINVAL' *) + (*$HPPEMIT '#undef WSAEMFILE' *) + (*$HPPEMIT '#undef WSAEWOULDBLOCK' *) + (*$HPPEMIT '#undef WSAEINPROGRESS' *) + (*$HPPEMIT '#undef WSAEALREADY' *) + (*$HPPEMIT '#undef WSAENOTSOCK' *) + (*$HPPEMIT '#undef WSAEDESTADDRREQ' *) + (*$HPPEMIT '#undef WSAEMSGSIZE' *) + (*$HPPEMIT '#undef WSAEPROTOTYPE' *) + (*$HPPEMIT '#undef WSAENOPROTOOPT' *) + (*$HPPEMIT '#undef WSAEPROTONOSUPPORT' *) + (*$HPPEMIT '#undef WSAESOCKTNOSUPPORT' *) + (*$HPPEMIT '#undef WSAEOPNOTSUPP' *) + (*$HPPEMIT '#undef WSAEPFNOSUPPORT' *) + (*$HPPEMIT '#undef WSAEAFNOSUPPORT' *) + (*$HPPEMIT '#undef WSAEADDRINUSE' *) + (*$HPPEMIT '#undef WSAEADDRNOTAVAIL' *) + (*$HPPEMIT '#undef WSAENETDOWN' *) + (*$HPPEMIT '#undef WSAENETUNREACH' *) + (*$HPPEMIT '#undef WSAENETRESET' *) + (*$HPPEMIT '#undef WSAECONNABORTED' *) + (*$HPPEMIT '#undef WSAECONNRESET' *) + (*$HPPEMIT '#undef WSAENOBUFS' *) + (*$HPPEMIT '#undef WSAEISCONN' *) + (*$HPPEMIT '#undef WSAENOTCONN' *) + (*$HPPEMIT '#undef WSAESHUTDOWN' *) + (*$HPPEMIT '#undef WSAETOOMANYREFS' *) + (*$HPPEMIT '#undef WSAETIMEDOUT' *) + (*$HPPEMIT '#undef WSAECONNREFUSED' *) + (*$HPPEMIT '#undef WSAELOOP' *) + (*$HPPEMIT '#undef WSAENAMETOOLONG' *) + (*$HPPEMIT '#undef WSAEHOSTDOWN' *) + (*$HPPEMIT '#undef WSAEHOSTUNREACH' *) + (*$HPPEMIT '#undef WSAENOTEMPTY' *) + (*$HPPEMIT '#undef WSAEPROCLIM' *) + (*$HPPEMIT '#undef WSAEUSERS' *) + (*$HPPEMIT '#undef WSAEDQUOT' *) + (*$HPPEMIT '#undef WSAESTALE' *) + (*$HPPEMIT '#undef WSAEREMOTE' *) + (*$HPPEMIT '#undef WSASYSNOTREADY' *) + (*$HPPEMIT '#undef WSAVERNOTSUPPORTED' *) + (*$HPPEMIT '#undef WSANOTINITIALISED' *) + (*$HPPEMIT '#undef WSAEDISCON' *) + (*$HPPEMIT '#undef WSAENOMORE' *) + (*$HPPEMIT '#undef WSAECANCELLED' *) + (*$HPPEMIT '#undef WSAEEINVALIDPROCTABLE' *) + (*$HPPEMIT '#undef WSAEINVALIDPROVIDER' *) + (*$HPPEMIT '#undef WSAEPROVIDERFAILEDINIT' *) + (*$HPPEMIT '#undef WSASYSCALLFAILURE' *) + (*$HPPEMIT '#undef WSASERVICE_NOT_FOUND' *) + (*$HPPEMIT '#undef WSATYPE_NOT_FOUND' *) + (*$HPPEMIT '#undef WSA_E_NO_MORE' *) + (*$HPPEMIT '#undef WSA_E_CANCELLED' *) + (*$HPPEMIT '#undef WSAEREFUSED' *) + (*$HPPEMIT '#undef WSAHOST_NOT_FOUND' *) + (*$HPPEMIT '#undef HOST_NOT_FOUND' *) + (*$HPPEMIT '#undef WSATRY_AGAIN' *) + (*$HPPEMIT '#undef TRY_AGAIN' *) + (*$HPPEMIT '#undef WSANO_RECOVERY' *) + (*$HPPEMIT '#undef NO_RECOVERY' *) + (*$HPPEMIT '#undef WSANO_DATA' *) + (*$HPPEMIT '#undef NO_DATA' *) + (*$HPPEMIT '#undef WSANO_ADDRESS' *) + (*$HPPEMIT '#undef ENAMETOOLONG' *) + (*$HPPEMIT '#undef ENOTEMPTY' *) + (*$HPPEMIT '#undef FD_CLR' *) + (*$HPPEMIT '#undef FD_ISSET' *) + (*$HPPEMIT '#undef FD_SET' *) + (*$HPPEMIT '#undef FD_ZERO' *) + (*$HPPEMIT '#undef NO_ADDRESS' *) + (*$HPPEMIT '#undef ADDR_ANY' *) + (*$HPPEMIT '#undef SO_GROUP_ID' *) + (*$HPPEMIT '#undef SO_GROUP_PRIORITY' *) + (*$HPPEMIT '#undef SO_MAX_MSG_SIZE' *) + (*$HPPEMIT '#undef SO_PROTOCOL_INFOA' *) + (*$HPPEMIT '#undef SO_PROTOCOL_INFOW' *) + (*$HPPEMIT '#undef SO_PROTOCOL_INFO' *) + (*$HPPEMIT '#undef PVD_CONFIG' *) + (*$HPPEMIT '#undef AF_INET6' *) + (*$HPPEMIT '#undef PF_INET6' *) +{$ENDIF} + +{$IFDEF FPC} + {$IFDEF WIN32} + {$ALIGN OFF} + {$ELSE} + {$PACKRECORDS C} + {$ENDIF} +{$ENDIF} + +interface + +uses + SyncObjs, SysUtils, Classes, + Windows; + +function InitSocketInterface(stack: String): Boolean; +function DestroySocketInterface: Boolean; + +const +{$IFDEF WINSOCK1} + WinsockLevel = $0101; +{$ELSE} + WinsockLevel = $0202; +{$ENDIF} + +type + u_short = Word; + u_int = Integer; + u_long = Longint; + pu_long = ^u_long; + pu_short = ^u_short; +{$IFDEF FPC} + TSocket = ptruint; +{$ELSE} + {$IFDEF WIN64} + TSocket = UINT_PTR; + {$ELSE} + TSocket = u_int; + {$ENDIF} +{$ENDIF} + TAddrFamily = integer; + + TMemory = pointer; + +const + {$IFDEF WINCE} + DLLStackName = 'ws2.dll'; + {$ELSE} + {$IFDEF WINSOCK1} + DLLStackName = 'wsock32.dll'; + {$ELSE} + DLLStackName = 'ws2_32.dll'; + {$ENDIF} + {$ENDIF} + DLLwship6 = 'wship6.dll'; + + cLocalhost = '127.0.0.1'; + cAnyHost = '0.0.0.0'; + cBroadcast = '255.255.255.255'; + c6Localhost = '::1'; + c6AnyHost = '::0'; + c6Broadcast = 'ffff::1'; + cAnyPort = '0'; + + +const + FD_SETSIZE = 64; +type + PFDSet = ^TFDSet; + TFDSet = record + fd_count: u_int; + fd_array: array[0..FD_SETSIZE-1] of TSocket; + end; + +const + FIONREAD = $4004667f; + FIONBIO = $8004667e; + FIOASYNC = $8004667d; + +type + PTimeVal = ^TTimeVal; + TTimeVal = record + tv_sec: Longint; + tv_usec: Longint; + end; + +const + IPPROTO_IP = 0; { Dummy } + IPPROTO_ICMP = 1; { Internet Control Message Protocol } + IPPROTO_IGMP = 2; { Internet Group Management Protocol} + IPPROTO_TCP = 6; { TCP } + IPPROTO_UDP = 17; { User Datagram Protocol } + IPPROTO_IPV6 = 41; + IPPROTO_ICMPV6 = 58; + IPPROTO_RM = 113; + + IPPROTO_RAW = 255; + IPPROTO_MAX = 256; + +type + + PInAddr = ^TInAddr; + TInAddr = record + case integer of + 0: (S_bytes: packed array [0..3] of byte); + 1: (S_addr: u_long); + end; + + PSockAddrIn = ^TSockAddrIn; + TSockAddrIn = record + case Integer of + 0: (sin_family: u_short; + sin_port: u_short; + sin_addr: TInAddr; + sin_zero: array[0..7] of byte); + 1: (sa_family: u_short; + sa_data: array[0..13] of byte) + end; + + TIP_mreq = record + imr_multiaddr: TInAddr; { IP multicast address of group } + imr_interface: TInAddr; { local IP address of interface } + end; + + PInAddr6 = ^TInAddr6; + TInAddr6 = record + case integer of + 0: (S6_addr: packed array [0..15] of byte); + 1: (u6_addr8: packed array [0..15] of byte); + 2: (u6_addr16: packed array [0..7] of word); + 3: (u6_addr32: packed array [0..3] of integer); + end; + + PSockAddrIn6 = ^TSockAddrIn6; + TSockAddrIn6 = record + sin6_family: u_short; // AF_INET6 + sin6_port: u_short; // Transport level port number + sin6_flowinfo: u_long; // IPv6 flow information + sin6_addr: TInAddr6; // IPv6 address + sin6_scope_id: u_long; // Scope Id: IF number for link-local + // SITE id for site-local + end; + + TIPv6_mreq = record + ipv6mr_multiaddr: TInAddr6; // IPv6 multicast address. + ipv6mr_interface: integer; // Interface index. + padding: integer; + end; + + PHostEnt = ^THostEnt; + THostEnt = record + h_name: PAnsiChar; + h_aliases: ^PAnsiChar; + h_addrtype: Smallint; + h_length: Smallint; + case integer of + 0: (h_addr_list: ^PAnsiChar); + 1: (h_addr: ^PInAddr); + end; + + PNetEnt = ^TNetEnt; + TNetEnt = record + n_name: PAnsiChar; + n_aliases: ^PAnsiChar; + n_addrtype: Smallint; + n_net: u_long; + end; + + PServEnt = ^TServEnt; + TServEnt = record + s_name: PAnsiChar; + s_aliases: ^PAnsiChar; +{$ifdef WIN64} + s_proto: PAnsiChar; + s_port: Smallint; +{$else} + s_port: Smallint; + s_proto: PAnsiChar; +{$endif} + end; + + PProtoEnt = ^TProtoEnt; + TProtoEnt = record + p_name: PAnsiChar; + p_aliases: ^PAnsichar; + p_proto: Smallint; + end; + +const + INADDR_ANY = $00000000; + INADDR_LOOPBACK = $7F000001; + INADDR_BROADCAST = $FFFFFFFF; + INADDR_NONE = $FFFFFFFF; + ADDR_ANY = INADDR_ANY; + INVALID_SOCKET = TSocket(NOT(0)); + SOCKET_ERROR = -1; + +Const + {$IFDEF WINSOCK1} + IP_OPTIONS = 1; + IP_MULTICAST_IF = 2; { set/get IP multicast interface } + IP_MULTICAST_TTL = 3; { set/get IP multicast timetolive } + IP_MULTICAST_LOOP = 4; { set/get IP multicast loopback } + IP_ADD_MEMBERSHIP = 5; { add an IP group membership } + IP_DROP_MEMBERSHIP = 6; { drop an IP group membership } + IP_TTL = 7; { set/get IP Time To Live } + IP_TOS = 8; { set/get IP Type Of Service } + IP_DONTFRAGMENT = 9; { set/get IP Don't Fragment flag } + {$ELSE} + IP_OPTIONS = 1; + IP_HDRINCL = 2; + IP_TOS = 3; { set/get IP Type Of Service } + IP_TTL = 4; { set/get IP Time To Live } + IP_MULTICAST_IF = 9; { set/get IP multicast interface } + IP_MULTICAST_TTL = 10; { set/get IP multicast timetolive } + IP_MULTICAST_LOOP = 11; { set/get IP multicast loopback } + IP_ADD_MEMBERSHIP = 12; { add an IP group membership } + IP_DROP_MEMBERSHIP = 13; { drop an IP group membership } + IP_DONTFRAGMENT = 14; { set/get IP Don't Fragment flag } + {$ENDIF} + + IP_DEFAULT_MULTICAST_TTL = 1; { normally limit m'casts to 1 hop } + IP_DEFAULT_MULTICAST_LOOP = 1; { normally hear sends if a member } + IP_MAX_MEMBERSHIPS = 20; { per socket; must fit in one mbuf } + + SOL_SOCKET = $ffff; {options for socket level } +{ Option flags per-socket. } + SO_DEBUG = $0001; { turn on debugging info recording } + SO_ACCEPTCONN = $0002; { socket has had listen() } + SO_REUSEADDR = $0004; { allow local address reuse } + SO_KEEPALIVE = $0008; { keep connections alive } + SO_DONTROUTE = $0010; { just use interface addresses } + SO_BROADCAST = $0020; { permit sending of broadcast msgs } + SO_USELOOPBACK = $0040; { bypass hardware when possible } + SO_LINGER = $0080; { linger on close if data present } + SO_OOBINLINE = $0100; { leave received OOB data in line } + SO_DONTLINGER = $ff7f; +{ Additional options. } + SO_SNDBUF = $1001; { send buffer size } + SO_RCVBUF = $1002; { receive buffer size } + SO_SNDLOWAT = $1003; { send low-water mark } + SO_RCVLOWAT = $1004; { receive low-water mark } + SO_SNDTIMEO = $1005; { send timeout } + SO_RCVTIMEO = $1006; { receive timeout } + SO_ERROR = $1007; { get error status and clear } + SO_TYPE = $1008; { get socket type } +{ WinSock 2 extension -- new options } + SO_GROUP_ID = $2001; { ID of a socket group} + SO_GROUP_PRIORITY = $2002; { the relative priority within a group} + SO_MAX_MSG_SIZE = $2003; { maximum message size } + SO_PROTOCOL_INFOA = $2004; { WSAPROTOCOL_INFOA structure } + SO_PROTOCOL_INFOW = $2005; { WSAPROTOCOL_INFOW structure } + SO_PROTOCOL_INFO = SO_PROTOCOL_INFOA; + PVD_CONFIG = $3001; {configuration info for service provider } +{ Option for opening sockets for synchronous access. } + SO_OPENTYPE = $7008; + SO_SYNCHRONOUS_ALERT = $10; + SO_SYNCHRONOUS_NONALERT = $20; +{ Other NT-specific options. } + SO_MAXDG = $7009; + SO_MAXPATHDG = $700A; + SO_UPDATE_ACCEPT_CONTEXT = $700B; + SO_CONNECT_TIME = $700C; + + SOMAXCONN = $7fffffff; + + IPV6_UNICAST_HOPS = 8; // ??? + IPV6_MULTICAST_IF = 9; // set/get IP multicast i/f + IPV6_MULTICAST_HOPS = 10; // set/get IP multicast ttl + IPV6_MULTICAST_LOOP = 11; // set/get IP multicast loopback + IPV6_JOIN_GROUP = 12; // add an IP group membership + IPV6_LEAVE_GROUP = 13; // drop an IP group membership + + MSG_NOSIGNAL = 0; + + // getnameinfo constants + NI_MAXHOST = 1025; + NI_MAXSERV = 32; + NI_NOFQDN = $1; + NI_NUMERICHOST = $2; + NI_NAMEREQD = $4; + NI_NUMERICSERV = $8; + NI_DGRAM = $10; + + +const + SOCK_STREAM = 1; { stream socket } + SOCK_DGRAM = 2; { datagram socket } + SOCK_RAW = 3; { raw-protocol interface } + SOCK_RDM = 4; { reliably-delivered message } + SOCK_SEQPACKET = 5; { sequenced packet stream } + +{ TCP options. } + TCP_NODELAY = $0001; + +{ Address families. } + + AF_UNSPEC = 0; { unspecified } + AF_INET = 2; { internetwork: UDP, TCP, etc. } + AF_INET6 = 23; { Internetwork Version 6 } + AF_MAX = 24; + +{ Protocol families, same as address families for now. } + PF_UNSPEC = AF_UNSPEC; + PF_INET = AF_INET; + PF_INET6 = AF_INET6; + PF_MAX = AF_MAX; + +type + { Structure used by kernel to store most addresses. } + PSockAddr = ^TSockAddr; + TSockAddr = TSockAddrIn; + + { Structure used by kernel to pass protocol information in raw sockets. } + PSockProto = ^TSockProto; + TSockProto = record + sp_family: u_short; + sp_protocol: u_short; + end; + +type + PAddrInfo = ^TAddrInfo; + TAddrInfo = record + ai_flags: integer; // AI_PASSIVE, AI_CANONNAME, AI_NUMERICHOST. + ai_family: integer; // PF_xxx. + ai_socktype: integer; // SOCK_xxx. + ai_protocol: integer; // 0 or IPPROTO_xxx for IPv4 and IPv6. + ai_addrlen: u_int; // Length of ai_addr. + ai_canonname: PAnsiChar; // Canonical name for nodename. + ai_addr: PSockAddr; // Binary address. + ai_next: PAddrInfo; // Next structure in linked list. + end; + +const + // Flags used in "hints" argument to getaddrinfo(). + AI_PASSIVE = $1; // Socket address will be used in bind() call. + AI_CANONNAME = $2; // Return canonical name in first ai_canonname. + AI_NUMERICHOST = $4; // Nodename must be a numeric address string. + +type +{ Structure used for manipulating linger option. } + PLinger = ^TLinger; + TLinger = record + l_onoff: u_short; + l_linger: u_short; + end; + +const + + MSG_OOB = $01; // Process out-of-band data. + MSG_PEEK = $02; // Peek at incoming messages. + +const + +{ All Windows Sockets error constants are biased by WSABASEERR from the "normal" } + WSABASEERR = 10000; + +{ Windows Sockets definitions of regular Microsoft C error constants } + + WSAEINTR = (WSABASEERR+4); + WSAEBADF = (WSABASEERR+9); + WSAEACCES = (WSABASEERR+13); + WSAEFAULT = (WSABASEERR+14); + WSAEINVAL = (WSABASEERR+22); + WSAEMFILE = (WSABASEERR+24); + +{ Windows Sockets definitions of regular Berkeley error constants } + + WSAEWOULDBLOCK = (WSABASEERR+35); + WSAEINPROGRESS = (WSABASEERR+36); + WSAEALREADY = (WSABASEERR+37); + WSAENOTSOCK = (WSABASEERR+38); + WSAEDESTADDRREQ = (WSABASEERR+39); + WSAEMSGSIZE = (WSABASEERR+40); + WSAEPROTOTYPE = (WSABASEERR+41); + WSAENOPROTOOPT = (WSABASEERR+42); + WSAEPROTONOSUPPORT = (WSABASEERR+43); + WSAESOCKTNOSUPPORT = (WSABASEERR+44); + WSAEOPNOTSUPP = (WSABASEERR+45); + WSAEPFNOSUPPORT = (WSABASEERR+46); + WSAEAFNOSUPPORT = (WSABASEERR+47); + WSAEADDRINUSE = (WSABASEERR+48); + WSAEADDRNOTAVAIL = (WSABASEERR+49); + WSAENETDOWN = (WSABASEERR+50); + WSAENETUNREACH = (WSABASEERR+51); + WSAENETRESET = (WSABASEERR+52); + WSAECONNABORTED = (WSABASEERR+53); + WSAECONNRESET = (WSABASEERR+54); + WSAENOBUFS = (WSABASEERR+55); + WSAEISCONN = (WSABASEERR+56); + WSAENOTCONN = (WSABASEERR+57); + WSAESHUTDOWN = (WSABASEERR+58); + WSAETOOMANYREFS = (WSABASEERR+59); + WSAETIMEDOUT = (WSABASEERR+60); + WSAECONNREFUSED = (WSABASEERR+61); + WSAELOOP = (WSABASEERR+62); + WSAENAMETOOLONG = (WSABASEERR+63); + WSAEHOSTDOWN = (WSABASEERR+64); + WSAEHOSTUNREACH = (WSABASEERR+65); + WSAENOTEMPTY = (WSABASEERR+66); + WSAEPROCLIM = (WSABASEERR+67); + WSAEUSERS = (WSABASEERR+68); + WSAEDQUOT = (WSABASEERR+69); + WSAESTALE = (WSABASEERR+70); + WSAEREMOTE = (WSABASEERR+71); + +{ Extended Windows Sockets error constant definitions } + + WSASYSNOTREADY = (WSABASEERR+91); + WSAVERNOTSUPPORTED = (WSABASEERR+92); + WSANOTINITIALISED = (WSABASEERR+93); + WSAEDISCON = (WSABASEERR+101); + WSAENOMORE = (WSABASEERR+102); + WSAECANCELLED = (WSABASEERR+103); + WSAEEINVALIDPROCTABLE = (WSABASEERR+104); + WSAEINVALIDPROVIDER = (WSABASEERR+105); + WSAEPROVIDERFAILEDINIT = (WSABASEERR+106); + WSASYSCALLFAILURE = (WSABASEERR+107); + WSASERVICE_NOT_FOUND = (WSABASEERR+108); + WSATYPE_NOT_FOUND = (WSABASEERR+109); + WSA_E_NO_MORE = (WSABASEERR+110); + WSA_E_CANCELLED = (WSABASEERR+111); + WSAEREFUSED = (WSABASEERR+112); + +{ Error return codes from gethostbyname() and gethostbyaddr() + (when using the resolver). Note that these errors are + retrieved via WSAGetLastError() and must therefore follow + the rules for avoiding clashes with error numbers from + specific implementations or language run-time systems. + For this reason the codes are based at WSABASEERR+1001. + Note also that [WSA]NO_ADDRESS is defined only for + compatibility purposes. } + +{ Authoritative Answer: Host not found } + WSAHOST_NOT_FOUND = (WSABASEERR+1001); + HOST_NOT_FOUND = WSAHOST_NOT_FOUND; +{ Non-Authoritative: Host not found, or SERVERFAIL } + WSATRY_AGAIN = (WSABASEERR+1002); + TRY_AGAIN = WSATRY_AGAIN; +{ Non recoverable errors, FORMERR, REFUSED, NOTIMP } + WSANO_RECOVERY = (WSABASEERR+1003); + NO_RECOVERY = WSANO_RECOVERY; +{ Valid name, no data record of requested type } + WSANO_DATA = (WSABASEERR+1004); + NO_DATA = WSANO_DATA; +{ no address, look for MX record } + WSANO_ADDRESS = WSANO_DATA; + NO_ADDRESS = WSANO_ADDRESS; + + EWOULDBLOCK = WSAEWOULDBLOCK; + EINPROGRESS = WSAEINPROGRESS; + EALREADY = WSAEALREADY; + ENOTSOCK = WSAENOTSOCK; + EDESTADDRREQ = WSAEDESTADDRREQ; + EMSGSIZE = WSAEMSGSIZE; + EPROTOTYPE = WSAEPROTOTYPE; + ENOPROTOOPT = WSAENOPROTOOPT; + EPROTONOSUPPORT = WSAEPROTONOSUPPORT; + ESOCKTNOSUPPORT = WSAESOCKTNOSUPPORT; + EOPNOTSUPP = WSAEOPNOTSUPP; + EPFNOSUPPORT = WSAEPFNOSUPPORT; + EAFNOSUPPORT = WSAEAFNOSUPPORT; + EADDRINUSE = WSAEADDRINUSE; + EADDRNOTAVAIL = WSAEADDRNOTAVAIL; + ENETDOWN = WSAENETDOWN; + ENETUNREACH = WSAENETUNREACH; + ENETRESET = WSAENETRESET; + ECONNABORTED = WSAECONNABORTED; + ECONNRESET = WSAECONNRESET; + ENOBUFS = WSAENOBUFS; + EISCONN = WSAEISCONN; + ENOTCONN = WSAENOTCONN; + ESHUTDOWN = WSAESHUTDOWN; + ETOOMANYREFS = WSAETOOMANYREFS; + ETIMEDOUT = WSAETIMEDOUT; + ECONNREFUSED = WSAECONNREFUSED; + ELOOP = WSAELOOP; + ENAMETOOLONG = WSAENAMETOOLONG; + EHOSTDOWN = WSAEHOSTDOWN; + EHOSTUNREACH = WSAEHOSTUNREACH; + ENOTEMPTY = WSAENOTEMPTY; + EPROCLIM = WSAEPROCLIM; + EUSERS = WSAEUSERS; + EDQUOT = WSAEDQUOT; + ESTALE = WSAESTALE; + EREMOTE = WSAEREMOTE; + + EAI_ADDRFAMILY = 1; // Address family for nodename not supported. + EAI_AGAIN = 2; // Temporary failure in name resolution. + EAI_BADFLAGS = 3; // Invalid value for ai_flags. + EAI_FAIL = 4; // Non-recoverable failure in name resolution. + EAI_FAMILY = 5; // Address family ai_family not supported. + EAI_MEMORY = 6; // Memory allocation failure. + EAI_NODATA = 7; // No address associated with nodename. + EAI_NONAME = 8; // Nodename nor servname provided, or not known. + EAI_SERVICE = 9; // Servname not supported for ai_socktype. + EAI_SOCKTYPE = 10; // Socket type ai_socktype not supported. + EAI_SYSTEM = 11; // System error returned in errno. + +const + WSADESCRIPTION_LEN = 256; + WSASYS_STATUS_LEN = 128; +type + PWSAData = ^TWSAData; + TWSAData = record + wVersion: Word; + wHighVersion: Word; +{$ifdef win64} + iMaxSockets : Word; + iMaxUdpDg : Word; + lpVendorInfo : PAnsiChar; + szDescription : array[0..WSADESCRIPTION_LEN] of AnsiChar; + szSystemStatus : array[0..WSASYS_STATUS_LEN] of AnsiChar; +{$else} + szDescription: array[0..WSADESCRIPTION_LEN] of AnsiChar; + szSystemStatus: array[0..WSASYS_STATUS_LEN] of AnsiChar; + iMaxSockets: Word; + iMaxUdpDg: Word; + lpVendorInfo: PAnsiChar; +{$endif} + end; + + function IN6_IS_ADDR_UNSPECIFIED(const a: PInAddr6): boolean; + function IN6_IS_ADDR_LOOPBACK(const a: PInAddr6): boolean; + function IN6_IS_ADDR_LINKLOCAL(const a: PInAddr6): boolean; + function IN6_IS_ADDR_SITELOCAL(const a: PInAddr6): boolean; + function IN6_IS_ADDR_MULTICAST(const a: PInAddr6): boolean; + function IN6_ADDR_EQUAL(const a: PInAddr6; const b: PInAddr6):boolean; + procedure SET_IN6_IF_ADDR_ANY (const a: PInAddr6); + procedure SET_LOOPBACK_ADDR6 (const a: PInAddr6); +var + in6addr_any, in6addr_loopback : TInAddr6; + +procedure FD_CLR(Socket: TSocket; var FDSet: TFDSet); +function FD_ISSET(Socket: TSocket; var FDSet: TFDSet): Boolean; +procedure FD_SET(Socket: TSocket; var FDSet: TFDSet); +procedure FD_ZERO(var FDSet: TFDSet); + +{=============================================================================} + +type + TWSAStartup = function(wVersionRequired: Word; var WSData: TWSAData): Integer; + stdcall; + TWSACleanup = function: Integer; + stdcall; + TWSAGetLastError = function: Integer; + stdcall; + TGetServByName = function(name, proto: PAnsiChar): PServEnt; + stdcall; + TGetServByPort = function(port: Integer; proto: PAnsiChar): PServEnt; + stdcall; + TGetProtoByName = function(name: PAnsiChar): PProtoEnt; + stdcall; + TGetProtoByNumber = function(proto: Integer): PProtoEnt; + stdcall; + TGetHostByName = function(name: PAnsiChar): PHostEnt; + stdcall; + TGetHostByAddr = function(addr: Pointer; len, Struc: Integer): PHostEnt; + stdcall; + TGetHostName = function(name: PAnsiChar; len: Integer): Integer; + stdcall; + TShutdown = function(s: TSocket; how: Integer): Integer; + stdcall; + TSetSockOpt = function(s: TSocket; level, optname: Integer; optval: PAnsiChar; + optlen: Integer): Integer; + stdcall; + TGetSockOpt = function(s: TSocket; level, optname: Integer; optval: PAnsiChar; + var optlen: Integer): Integer; + stdcall; + TSendTo = function(s: TSocket; const Buf; len, flags: Integer; addrto: PSockAddr; + tolen: Integer): Integer; + stdcall; + TSend = function(s: TSocket; const Buf; len, flags: Integer): Integer; + stdcall; + TRecv = function(s: TSocket; var Buf; len, flags: Integer): Integer; + stdcall; + TRecvFrom = function(s: TSocket; var Buf; len, flags: Integer; from: PSockAddr; + var fromlen: Integer): Integer; + stdcall; + Tntohs = function(netshort: u_short): u_short; + stdcall; + Tntohl = function(netlong: u_long): u_long; + stdcall; + TListen = function(s: TSocket; backlog: Integer): Integer; + stdcall; + TIoctlSocket = function(s: TSocket; cmd: DWORD; var arg: Integer): Integer; + stdcall; + TInet_ntoa = function(inaddr: TInAddr): PAnsiChar; + stdcall; + TInet_addr = function(cp: PAnsiChar): u_long; + stdcall; + Thtons = function(hostshort: u_short): u_short; + stdcall; + Thtonl = function(hostlong: u_long): u_long; + stdcall; + TGetSockName = function(s: TSocket; name: PSockAddr; var namelen: Integer): Integer; + stdcall; + TGetPeerName = function(s: TSocket; name: PSockAddr; var namelen: Integer): Integer; + stdcall; + TConnect = function(s: TSocket; name: PSockAddr; namelen: Integer): Integer; + stdcall; + TCloseSocket = function(s: TSocket): Integer; + stdcall; + TBind = function(s: TSocket; addr: PSockAddr; namelen: Integer): Integer; + stdcall; + TAccept = function(s: TSocket; addr: PSockAddr; var addrlen: Integer): TSocket; + stdcall; + TTSocket = function(af, Struc, Protocol: Integer): TSocket; + stdcall; + TSelect = function(nfds: Integer; readfds, writefds, exceptfds: PFDSet; + timeout: PTimeVal): Longint; + stdcall; + + TGetAddrInfo = function(NodeName: PAnsiChar; ServName: PAnsiChar; Hints: PAddrInfo; + var Addrinfo: PAddrInfo): integer; + stdcall; + TFreeAddrInfo = procedure(ai: PAddrInfo); + stdcall; + TGetNameInfo = function( addr: PSockAddr; namelen: Integer; host: PAnsiChar; + hostlen: DWORD; serv: PAnsiChar; servlen: DWORD; flags: integer): integer; + stdcall; + + T__WSAFDIsSet = function (s: TSocket; var FDSet: TFDSet): Bool; + stdcall; + + TWSAIoctl = function (s: TSocket; dwIoControlCode: DWORD; lpvInBuffer: Pointer; + cbInBuffer: DWORD; lpvOutBuffer: Pointer; cbOutBuffer: DWORD; + lpcbBytesReturned: PDWORD; lpOverlapped: Pointer; + lpCompletionRoutine: pointer): u_int; + stdcall; + +var + WSAStartup: TWSAStartup = nil; + WSACleanup: TWSACleanup = nil; + WSAGetLastError: TWSAGetLastError = nil; + GetServByName: TGetServByName = nil; + GetServByPort: TGetServByPort = nil; + GetProtoByName: TGetProtoByName = nil; + GetProtoByNumber: TGetProtoByNumber = nil; + GetHostByName: TGetHostByName = nil; + GetHostByAddr: TGetHostByAddr = nil; + ssGetHostName: TGetHostName = nil; + Shutdown: TShutdown = nil; + SetSockOpt: TSetSockOpt = nil; + GetSockOpt: TGetSockOpt = nil; + ssSendTo: TSendTo = nil; + ssSend: TSend = nil; + ssRecv: TRecv = nil; + ssRecvFrom: TRecvFrom = nil; + ntohs: Tntohs = nil; + ntohl: Tntohl = nil; + Listen: TListen = nil; + IoctlSocket: TIoctlSocket = nil; + Inet_ntoa: TInet_ntoa = nil; + Inet_addr: TInet_addr = nil; + htons: Thtons = nil; + htonl: Thtonl = nil; + ssGetSockName: TGetSockName = nil; + ssGetPeerName: TGetPeerName = nil; + ssConnect: TConnect = nil; + CloseSocket: TCloseSocket = nil; + ssBind: TBind = nil; + ssAccept: TAccept = nil; + Socket: TTSocket = nil; + Select: TSelect = nil; + + GetAddrInfo: TGetAddrInfo = nil; + FreeAddrInfo: TFreeAddrInfo = nil; + GetNameInfo: TGetNameInfo = nil; + + __WSAFDIsSet: T__WSAFDIsSet = nil; + + WSAIoctl: TWSAIoctl = nil; + +var + SynSockCS: SyncObjs.TCriticalSection; + SockEnhancedApi: Boolean; + SockWship6Api: Boolean; + +type + TVarSin = packed record + case integer of + 0: (AddressFamily: u_short); + 1: ( + case sin_family: u_short of + AF_INET: (sin_port: u_short; + sin_addr: TInAddr; + sin_zero: array[0..7] of byte); + AF_INET6: (sin6_port: u_short; + sin6_flowinfo: u_long; + sin6_addr: TInAddr6; + sin6_scope_id: u_long); + ); + end; + +function SizeOfVarSin(sin: TVarSin): integer; + +function Bind(s: TSocket; const addr: TVarSin): Integer; +function Connect(s: TSocket; const name: TVarSin): Integer; +function GetSockName(s: TSocket; var name: TVarSin): Integer; +function GetPeerName(s: TSocket; var name: TVarSin): Integer; +function GetHostName: AnsiString; +function Send(s: TSocket; Buf: TMemory; len, flags: Integer): Integer; +function Recv(s: TSocket; Buf: TMemory; len, flags: Integer): Integer; +function SendTo(s: TSocket; Buf: TMemory; len, flags: Integer; addrto: TVarSin): Integer; +function RecvFrom(s: TSocket; Buf: TMemory; len, flags: Integer; var from: TVarSin): Integer; +function Accept(s: TSocket; var addr: TVarSin): TSocket; + +function IsNewApi(Family: integer): Boolean; +function SetVarSin(var Sin: TVarSin; IP, Port: AnsiString; Family, SockProtocol, SockType: integer; PreferIP4: Boolean): integer; +function GetSinIP(Sin: TVarSin): AnsiString; +function GetSinPort(Sin: TVarSin): Integer; +procedure ResolveNameToIP(Name: AnsiString; Family, SockProtocol, SockType: integer; const IPList: TStrings); +function ResolveIPToName(IP: AnsiString; Family, SockProtocol, SockType: integer): AnsiString; +function ResolvePort(Port: AnsiString; Family, SockProtocol, SockType: integer): Word; + +{==============================================================================} +implementation + +var + SynSockCount: Integer = 0; + LibHandle: THandle = 0; + Libwship6Handle: THandle = 0; + +function IN6_IS_ADDR_UNSPECIFIED(const a: PInAddr6): boolean; +begin + Result := ((a^.u6_addr32[0] = 0) and (a^.u6_addr32[1] = 0) and + (a^.u6_addr32[2] = 0) and (a^.u6_addr32[3] = 0)); +end; + +function IN6_IS_ADDR_LOOPBACK(const a: PInAddr6): boolean; +begin + Result := ((a^.u6_addr32[0] = 0) and (a^.u6_addr32[1] = 0) and + (a^.u6_addr32[2] = 0) and + (a^.u6_addr8[12] = 0) and (a^.u6_addr8[13] = 0) and + (a^.u6_addr8[14] = 0) and (a^.u6_addr8[15] = 1)); +end; + +function IN6_IS_ADDR_LINKLOCAL(const a: PInAddr6): boolean; +begin + Result := ((a^.u6_addr8[0] = $FE) and (a^.u6_addr8[1] = $80)); +end; + +function IN6_IS_ADDR_SITELOCAL(const a: PInAddr6): boolean; +begin + Result := ((a^.u6_addr8[0] = $FE) and (a^.u6_addr8[1] = $C0)); +end; + +function IN6_IS_ADDR_MULTICAST(const a: PInAddr6): boolean; +begin + Result := (a^.u6_addr8[0] = $FF); +end; + +function IN6_ADDR_EQUAL(const a: PInAddr6; const b: PInAddr6): boolean; +begin + Result := (CompareMem( a, b, sizeof(TInAddr6))); +end; + +procedure SET_IN6_IF_ADDR_ANY (const a: PInAddr6); +begin + FillChar(a^, sizeof(TInAddr6), 0); +end; + +procedure SET_LOOPBACK_ADDR6 (const a: PInAddr6); +begin + FillChar(a^, sizeof(TInAddr6), 0); + a^.u6_addr8[15] := 1; +end; + +{=============================================================================} +procedure FD_CLR(Socket: TSocket; var FDSet: TFDSet); +var + I: Integer; +begin + I := 0; + while I < FDSet.fd_count do + begin + if FDSet.fd_array[I] = Socket then + begin + while I < FDSet.fd_count - 1 do + begin + FDSet.fd_array[I] := FDSet.fd_array[I + 1]; + Inc(I); + end; + Dec(FDSet.fd_count); + Break; + end; + Inc(I); + end; +end; + +function FD_ISSET(Socket: TSocket; var FDSet: TFDSet): Boolean; +begin + Result := __WSAFDIsSet(Socket, FDSet); +end; + +procedure FD_SET(Socket: TSocket; var FDSet: TFDSet); +begin + if FDSet.fd_count < FD_SETSIZE then + begin + FDSet.fd_array[FDSet.fd_count] := Socket; + Inc(FDSet.fd_count); + end; +end; + +procedure FD_ZERO(var FDSet: TFDSet); +begin + FDSet.fd_count := 0; +end; + +{=============================================================================} + +function SizeOfVarSin(sin: TVarSin): integer; +begin + case sin.sin_family of + AF_INET: + Result := SizeOf(TSockAddrIn); + AF_INET6: + Result := SizeOf(TSockAddrIn6); + else + Result := 0; + end; +end; + +{=============================================================================} + +function Bind(s: TSocket; const addr: TVarSin): Integer; +begin + Result := ssBind(s, @addr, SizeOfVarSin(addr)); +end; + +function Connect(s: TSocket; const name: TVarSin): Integer; +begin + Result := ssConnect(s, @name, SizeOfVarSin(name)); +end; + +function GetSockName(s: TSocket; var name: TVarSin): Integer; +var + len: integer; +begin + len := SizeOf(name); + FillChar(name, len, 0); + Result := ssGetSockName(s, @name, Len); +end; + +function GetPeerName(s: TSocket; var name: TVarSin): Integer; +var + len: integer; +begin + len := SizeOf(name); + FillChar(name, len, 0); + Result := ssGetPeerName(s, @name, Len); +end; + +function GetHostName: AnsiString; +var + s: AnsiString; +begin + Result := ''; + setlength(s, 255); + ssGetHostName(pAnsichar(s), Length(s) - 1); + Result := PAnsichar(s); +end; + +function Send(s: TSocket; Buf: TMemory; len, flags: Integer): Integer; +begin + Result := ssSend(s, Buf^, len, flags); +end; + +function Recv(s: TSocket; Buf: TMemory; len, flags: Integer): Integer; +begin + Result := ssRecv(s, Buf^, len, flags); +end; + +function SendTo(s: TSocket; Buf: TMemory; len, flags: Integer; addrto: TVarSin): Integer; +begin + Result := ssSendTo(s, Buf^, len, flags, @addrto, SizeOfVarSin(addrto)); +end; + +function RecvFrom(s: TSocket; Buf: TMemory; len, flags: Integer; var from: TVarSin): Integer; +var + x: integer; +begin + x := SizeOf(from); + Result := ssRecvFrom(s, Buf^, len, flags, @from, x); +end; + +function Accept(s: TSocket; var addr: TVarSin): TSocket; +var + x: integer; +begin + x := SizeOf(addr); + Result := ssAccept(s, @addr, x); +end; + +{=============================================================================} +function IsNewApi(Family: integer): Boolean; +begin + Result := SockEnhancedApi; + if not Result then + Result := (Family = AF_INET6) and SockWship6Api; +end; + +function SetVarSin(var Sin: TVarSin; IP, Port: AnsiString; Family, SockProtocol, SockType: integer; PreferIP4: Boolean): integer; +type + pu_long = ^u_long; +var + ProtoEnt: PProtoEnt; + ServEnt: PServEnt; + HostEnt: PHostEnt; + r: integer; + Hints1, Hints2: TAddrInfo; + Sin1, Sin2: TVarSin; + TwoPass: boolean; + + function GetAddr(const IP, port: AnsiString; Hints: TAddrInfo; var Sin: TVarSin): integer; + var + Addr: PAddrInfo; + begin + Addr := nil; + try + FillChar(Sin, Sizeof(Sin), 0); + if Hints.ai_socktype = SOCK_RAW then + begin + Hints.ai_socktype := 0; + Hints.ai_protocol := 0; + Result := synsock.GetAddrInfo(PAnsiChar(IP), nil, @Hints, Addr); + end + else + begin + if (IP = cAnyHost) or (IP = c6AnyHost) then + begin + Hints.ai_flags := AI_PASSIVE; + Result := synsock.GetAddrInfo(nil, PAnsiChar(Port), @Hints, Addr); + end + else + if (IP = cLocalhost) or (IP = c6Localhost) then + begin + Result := synsock.GetAddrInfo(nil, PAnsiChar(Port), @Hints, Addr); + end + else + begin + Result := synsock.GetAddrInfo(PAnsiChar(IP), PAnsiChar(Port), @Hints, Addr); + end; + end; + if Result = 0 then + if (Addr <> nil) then + Move(Addr^.ai_addr^, Sin, Addr^.ai_addrlen); + finally + if Assigned(Addr) then + synsock.FreeAddrInfo(Addr); + end; + end; + +begin + Result := 0; + FillChar(Sin, Sizeof(Sin), 0); + if not IsNewApi(family) then + begin + SynSockCS.Enter; + try + Sin.sin_family := AF_INET; + ProtoEnt := synsock.GetProtoByNumber(SockProtocol); + ServEnt := nil; + if (ProtoEnt <> nil) and (StrToIntDef(string(Port),-1) =-1) then + ServEnt := synsock.GetServByName(PAnsiChar(Port), ProtoEnt^.p_name); + if ServEnt = nil then + Sin.sin_port := synsock.htons(StrToIntDef(string(Port), 0)) + else + Sin.sin_port := ServEnt^.s_port; + if IP = cBroadcast then + Sin.sin_addr.s_addr := u_long(INADDR_BROADCAST) + else + begin + Sin.sin_addr.s_addr := synsock.inet_addr(PAnsiChar(IP)); + if Sin.sin_addr.s_addr = u_long(INADDR_NONE) then + begin + HostEnt := synsock.GetHostByName(PAnsiChar(IP)); + Result := synsock.WSAGetLastError; + if HostEnt <> nil then + Sin.sin_addr.S_addr := u_long(Pu_long(HostEnt^.h_addr_list^)^); + end; + end; + finally + SynSockCS.Leave; + end; + end + else + begin + FillChar(Hints1, Sizeof(Hints1), 0); + FillChar(Hints2, Sizeof(Hints2), 0); + TwoPass := False; + if Family = AF_UNSPEC then + begin + if PreferIP4 then + begin + Hints1.ai_family := AF_INET; + Hints2.ai_family := AF_INET6; + TwoPass := True; + end + else + begin + Hints2.ai_family := AF_INET; + Hints1.ai_family := AF_INET6; + TwoPass := True; + end; + end + else + Hints1.ai_family := Family; + + Hints1.ai_socktype := SockType; + Hints1.ai_protocol := SockProtocol; + Hints2.ai_socktype := Hints1.ai_socktype; + Hints2.ai_protocol := Hints1.ai_protocol; + + r := GetAddr(IP, Port, Hints1, Sin1); + Result := r; + sin := sin1; + if r <> 0 then + if TwoPass then + begin + r := GetAddr(IP, Port, Hints2, Sin2); + Result := r; + if r = 0 then + sin := sin2; + end; + end; +end; + +function GetSinIP(Sin: TVarSin): AnsiString; +var + p: PAnsiChar; + host, serv: AnsiString; + hostlen, servlen: integer; + r: integer; +begin + Result := ''; + if not IsNewApi(Sin.AddressFamily) then + begin + p := synsock.inet_ntoa(Sin.sin_addr); + if p <> nil then + Result := p; + end + else + begin + hostlen := NI_MAXHOST; + servlen := NI_MAXSERV; + setlength(host, hostlen); + setlength(serv, servlen); + r := getnameinfo(@sin, SizeOfVarSin(sin), PAnsiChar(host), hostlen, + PAnsiChar(serv), servlen, NI_NUMERICHOST + NI_NUMERICSERV); + if r = 0 then + Result := PAnsiChar(host); + end; +end; + +function GetSinPort(Sin: TVarSin): Integer; +begin + if (Sin.sin_family = AF_INET6) then + Result := synsock.ntohs(Sin.sin6_port) + else + Result := synsock.ntohs(Sin.sin_port); +end; + +procedure ResolveNameToIP(Name: AnsiString; Family, SockProtocol, SockType: integer; const IPList: TStrings); +type + TaPInAddr = array[0..250] of PInAddr; + PaPInAddr = ^TaPInAddr; +var + Hints: TAddrInfo; + Addr: PAddrInfo; + AddrNext: PAddrInfo; + r: integer; + host, serv: AnsiString; + hostlen, servlen: integer; + RemoteHost: PHostEnt; + IP: u_long; + PAdrPtr: PaPInAddr; + i: Integer; + s: String; + InAddr: TInAddr; +begin + IPList.Clear; + if not IsNewApi(Family) then + begin + IP := synsock.inet_addr(PAnsiChar(Name)); + if IP = u_long(INADDR_NONE) then + begin + SynSockCS.Enter; + try + RemoteHost := synsock.GetHostByName(PAnsiChar(Name)); + if RemoteHost <> nil then + begin + PAdrPtr := PAPInAddr(RemoteHost^.h_addr_list); + i := 0; + while PAdrPtr^[i] <> nil do + begin + InAddr := PAdrPtr^[i]^; + s := Format('%d.%d.%d.%d', [InAddr.S_bytes[0], InAddr.S_bytes[1], + InAddr.S_bytes[2], InAddr.S_bytes[3]]); + IPList.Add(s); + Inc(i); + end; + end; + finally + SynSockCS.Leave; + end; + end + else + IPList.Add(string(Name)); + end + else + begin + Addr := nil; + try + FillChar(Hints, Sizeof(Hints), 0); + Hints.ai_family := AF_UNSPEC; + Hints.ai_socktype := SockType; + Hints.ai_protocol := SockProtocol; + Hints.ai_flags := 0; + r := synsock.GetAddrInfo(PAnsiChar(Name), nil, @Hints, Addr); + if r = 0 then + begin + AddrNext := Addr; + while not(AddrNext = nil) do + begin + if not(((Family = AF_INET6) and (AddrNext^.ai_family = AF_INET)) + or ((Family = AF_INET) and (AddrNext^.ai_family = AF_INET6))) then + begin + hostlen := NI_MAXHOST; + servlen := NI_MAXSERV; + setlength(host, hostlen); + setlength(serv, servlen); + r := getnameinfo(AddrNext^.ai_addr, AddrNext^.ai_addrlen, + PAnsiChar(host), hostlen, PAnsiChar(serv), servlen, + NI_NUMERICHOST + NI_NUMERICSERV); + if r = 0 then + begin + host := PAnsiChar(host); + IPList.Add(string(host)); + end; + end; + AddrNext := AddrNext^.ai_next; + end; + end; + finally + if Assigned(Addr) then + synsock.FreeAddrInfo(Addr); + end; + end; + if IPList.Count = 0 then + IPList.Add(cAnyHost); +end; + +function ResolvePort(Port: AnsiString; Family, SockProtocol, SockType: integer): Word; +var + ProtoEnt: PProtoEnt; + ServEnt: PServEnt; + Hints: TAddrInfo; + Addr: PAddrInfo; + r: integer; +begin + Result := 0; + if not IsNewApi(Family) then + begin + SynSockCS.Enter; + try + ProtoEnt := synsock.GetProtoByNumber(SockProtocol); + ServEnt := nil; + if ProtoEnt <> nil then + ServEnt := synsock.GetServByName(PAnsiChar(Port), ProtoEnt^.p_name); + if ServEnt = nil then + Result := StrToIntDef(string(Port), 0) + else + Result := synsock.htons(ServEnt^.s_port); + finally + SynSockCS.Leave; + end; + end + else + begin + Addr := nil; + try + FillChar(Hints, Sizeof(Hints), 0); + Hints.ai_family := AF_UNSPEC; + Hints.ai_socktype := SockType; + Hints.ai_protocol := Sockprotocol; + Hints.ai_flags := AI_PASSIVE; + r := synsock.GetAddrInfo(nil, PAnsiChar(Port), @Hints, Addr); + if (r = 0) and Assigned(Addr) then + begin + if Addr^.ai_family = AF_INET then + Result := synsock.htons(Addr^.ai_addr^.sin_port); + if Addr^.ai_family = AF_INET6 then + Result := synsock.htons(PSockAddrIn6(Addr^.ai_addr)^.sin6_port); + end; + finally + if Assigned(Addr) then + synsock.FreeAddrInfo(Addr); + end; + end; +end; + +function ResolveIPToName(IP: AnsiString; Family, SockProtocol, SockType: integer): AnsiString; +var + Hints: TAddrInfo; + Addr: PAddrInfo; + r: integer; + host, serv: AnsiString; + hostlen, servlen: integer; + RemoteHost: PHostEnt; + IPn: u_long; +begin + Result := IP; + if not IsNewApi(Family) then + begin + IPn := synsock.inet_addr(PAnsiChar(IP)); + if IPn <> u_long(INADDR_NONE) then + begin + SynSockCS.Enter; + try + RemoteHost := GetHostByAddr(@IPn, SizeOf(IPn), AF_INET); + if RemoteHost <> nil then + Result := RemoteHost^.h_name; + finally + SynSockCS.Leave; + end; + end; + end + else + begin + Addr := nil; + try + FillChar(Hints, Sizeof(Hints), 0); + Hints.ai_family := AF_UNSPEC; + Hints.ai_socktype := SockType; + Hints.ai_protocol := SockProtocol; + Hints.ai_flags := 0; + r := synsock.GetAddrInfo(PAnsiChar(IP), nil, @Hints, Addr); + if (r = 0) and Assigned(Addr)then + begin + hostlen := NI_MAXHOST; + servlen := NI_MAXSERV; + setlength(host, hostlen); + setlength(serv, servlen); + r := getnameinfo(Addr^.ai_addr, Addr^.ai_addrlen, + PAnsiChar(host), hostlen, PAnsiChar(serv), servlen, + NI_NUMERICSERV); + if r = 0 then + Result := PAnsiChar(host); + end; + finally + if Assigned(Addr) then + synsock.FreeAddrInfo(Addr); + end; + end; +end; + +{=============================================================================} + +function InitSocketInterface(stack: String): Boolean; +begin + Result := False; + SockEnhancedApi := False; + if stack = '' then + stack := DLLStackName; + SynSockCS.Enter; + try + if SynSockCount = 0 then + begin + SockEnhancedApi := False; + SockWship6Api := False; + LibHandle := LoadLibrary(PChar(Stack)); + if LibHandle <> 0 then + begin + WSAIoctl := GetProcAddress(LibHandle, PAnsiChar(AnsiString('WSAIoctl'))); + __WSAFDIsSet := GetProcAddress(LibHandle, PAnsiChar(AnsiString('__WSAFDIsSet'))); + CloseSocket := GetProcAddress(LibHandle, PAnsiChar(AnsiString('closesocket'))); + IoctlSocket := GetProcAddress(LibHandle, PAnsiChar(AnsiString('ioctlsocket'))); + WSAGetLastError := GetProcAddress(LibHandle, PAnsiChar(AnsiString('WSAGetLastError'))); + WSAStartup := GetProcAddress(LibHandle, PAnsiChar(AnsiString('WSAStartup'))); + WSACleanup := GetProcAddress(LibHandle, PAnsiChar(AnsiString('WSACleanup'))); + ssAccept := GetProcAddress(LibHandle, PAnsiChar(AnsiString('accept'))); + ssBind := GetProcAddress(LibHandle, PAnsiChar(AnsiString('bind'))); + ssConnect := GetProcAddress(LibHandle, PAnsiChar(AnsiString('connect'))); + ssGetPeerName := GetProcAddress(LibHandle, PAnsiChar(AnsiString('getpeername'))); + ssGetSockName := GetProcAddress(LibHandle, PAnsiChar(AnsiString('getsockname'))); + GetSockOpt := GetProcAddress(LibHandle, PAnsiChar(AnsiString('getsockopt'))); + Htonl := GetProcAddress(LibHandle, PAnsiChar(AnsiString('htonl'))); + Htons := GetProcAddress(LibHandle, PAnsiChar(AnsiString('htons'))); + Inet_Addr := GetProcAddress(LibHandle, PAnsiChar(AnsiString('inet_addr'))); + Inet_Ntoa := GetProcAddress(LibHandle, PAnsiChar(AnsiString('inet_ntoa'))); + Listen := GetProcAddress(LibHandle, PAnsiChar(AnsiString('listen'))); + Ntohl := GetProcAddress(LibHandle, PAnsiChar(AnsiString('ntohl'))); + Ntohs := GetProcAddress(LibHandle, PAnsiChar(AnsiString('ntohs'))); + ssRecv := GetProcAddress(LibHandle, PAnsiChar(AnsiString('recv'))); + ssRecvFrom := GetProcAddress(LibHandle, PAnsiChar(AnsiString('recvfrom'))); + Select := GetProcAddress(LibHandle, PAnsiChar(AnsiString('select'))); + ssSend := GetProcAddress(LibHandle, PAnsiChar(AnsiString('send'))); + ssSendTo := GetProcAddress(LibHandle, PAnsiChar(AnsiString('sendto'))); + SetSockOpt := GetProcAddress(LibHandle, PAnsiChar(AnsiString('setsockopt'))); + ShutDown := GetProcAddress(LibHandle, PAnsiChar(AnsiString('shutdown'))); + Socket := GetProcAddress(LibHandle, PAnsiChar(AnsiString('socket'))); + GetHostByAddr := GetProcAddress(LibHandle, PAnsiChar(AnsiString('gethostbyaddr'))); + GetHostByName := GetProcAddress(LibHandle, PAnsiChar(AnsiString('gethostbyname'))); + GetProtoByName := GetProcAddress(LibHandle, PAnsiChar(AnsiString('getprotobyname'))); + GetProtoByNumber := GetProcAddress(LibHandle, PAnsiChar(AnsiString('getprotobynumber'))); + GetServByName := GetProcAddress(LibHandle, PAnsiChar(AnsiString('getservbyname'))); + GetServByPort := GetProcAddress(LibHandle, PAnsiChar(AnsiString('getservbyport'))); + ssGetHostName := GetProcAddress(LibHandle, PAnsiChar(AnsiString('gethostname'))); + +{$IFNDEF FORCEOLDAPI} + GetAddrInfo := GetProcAddress(LibHandle, PAnsiChar(AnsiString('getaddrinfo'))); + FreeAddrInfo := GetProcAddress(LibHandle, PAnsiChar(AnsiString('freeaddrinfo'))); + GetNameInfo := GetProcAddress(LibHandle, PAnsiChar(AnsiString('getnameinfo'))); + SockEnhancedApi := Assigned(GetAddrInfo) and Assigned(FreeAddrInfo) + and Assigned(GetNameInfo); + if not SockEnhancedApi then + begin + LibWship6Handle := LoadLibrary(PChar(DLLWship6)); + if LibWship6Handle <> 0 then + begin + GetAddrInfo := GetProcAddress(LibWship6Handle, PAnsiChar(AnsiString('getaddrinfo'))); + FreeAddrInfo := GetProcAddress(LibWship6Handle, PAnsiChar(AnsiString('freeaddrinfo'))); + GetNameInfo := GetProcAddress(LibWship6Handle, PAnsiChar(AnsiString('getnameinfo'))); + SockWship6Api := Assigned(GetAddrInfo) and Assigned(FreeAddrInfo) + and Assigned(GetNameInfo); + end; + end; +{$ENDIF} + Result := True; + end; + end + else Result := True; + if Result then + Inc(SynSockCount); + finally + SynSockCS.Leave; + end; +end; + +function DestroySocketInterface: Boolean; +begin + SynSockCS.Enter; + try + Dec(SynSockCount); + if SynSockCount < 0 then + SynSockCount := 0; + if SynSockCount = 0 then + begin + if LibHandle <> 0 then + begin + FreeLibrary(libHandle); + LibHandle := 0; + end; + if LibWship6Handle <> 0 then + begin + FreeLibrary(LibWship6Handle); + LibWship6Handle := 0; + end; + end; + finally + SynSockCS.Leave; + end; + Result := True; +end; + +initialization +begin + SynSockCS := SyncObjs.TCriticalSection.Create; + SET_IN6_IF_ADDR_ANY (@in6addr_any); + SET_LOOPBACK_ADDR6 (@in6addr_loopback); +end; + +finalization +begin + SynSockCS.Free; +end; \ No newline at end of file diff --git a/synapse/synachar.pas b/synapse/synachar.pas new file mode 100644 index 0000000..af889f0 --- /dev/null +++ b/synapse/synachar.pas @@ -0,0 +1,2035 @@ +{==============================================================================| +| Project : Ararat Synapse | 005.002.002 | +|==============================================================================| +| Content: Charset conversion support | +|==============================================================================| +| Copyright (c)1999-2004, 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-2004. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +{: @abstract(Charset conversion support) +This unit contains a routines for lot of charset conversions. + +It using built-in conversion tables or external Iconv library. Iconv is used + when needed conversion is known by Iconv library. When Iconv library is not + found or Iconv not know requested conversion, then are internal routines used + for conversion. (You can disable Iconv support from your program too!) + +Internal routines knows all major charsets for Europe or America. For East-Asian + charsets you must use Iconv library! +} + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$Q-} +{$H+} + +{$IFDEF UNICODE} + {$WARN IMPLICIT_STRING_CAST OFF} + {$WARN IMPLICIT_STRING_CAST_LOSS OFF} +{$ENDIF} + +unit synachar; + +interface + +uses +{$IFNDEF WIN32} + {$IFNDEF FPC} + Libc, + {$ELSE} + {$IFDEF FPC_USE_LIBC} + Libc, + {$ENDIF} + {$ENDIF} +{$ELSE} + Windows, +{$ENDIF} + SysUtils, + synautil, synacode, synaicnv; + +type + {:Type with all supported charsets.} + TMimeChar = (ISO_8859_1, ISO_8859_2, ISO_8859_3, ISO_8859_4, ISO_8859_5, + ISO_8859_6, ISO_8859_7, ISO_8859_8, ISO_8859_9, ISO_8859_10, ISO_8859_13, + ISO_8859_14, ISO_8859_15, CP1250, CP1251, CP1252, CP1253, CP1254, CP1255, + CP1256, CP1257, CP1258, KOI8_R, CP895, CP852, UCS_2, UCS_4, UTF_8, UTF_7, + UTF_7mod, UCS_2LE, UCS_4LE, + //next is supported by Iconv only... + UTF_16, UTF_16LE, UTF_32, UTF_32LE, C99, JAVA, ISO_8859_16, KOI8_U, KOI8_RU, + CP862, CP866, MAC, MACCE, MACICE, MACCRO, MACRO, MACCYR, MACUK, MACGR, MACTU, + MACHEB, MACAR, MACTH, ROMAN8, NEXTSTEP, ARMASCII, GEORGIAN_AC, GEORGIAN_PS, + KOI8_T, MULELAO, CP1133, TIS620, CP874, VISCII, TCVN, ISO_IR_14, JIS_X0201, + JIS_X0208, JIS_X0212, GB1988_80, GB2312_80, ISO_IR_165, ISO_IR_149, EUC_JP, + SHIFT_JIS, CP932, ISO_2022_JP, ISO_2022_JP1, ISO_2022_JP2, GB2312, CP936, + GB18030, ISO_2022_CN, ISO_2022_CNE, HZ, EUC_TW, BIG5, CP950, BIG5_HKSCS, + EUC_KR, CP949, CP1361, ISO_2022_KR, CP737, CP775, CP853, CP855, CP857, + CP858, CP860, CP861, CP863, CP864, CP865, CP869, CP1125); + + {:Set of any charsets.} + TMimeSetChar = set of TMimeChar; + +const + {:Set of charsets supported by Iconv library only.} + IconvOnlyChars: set of TMimeChar = [UTF_16, UTF_16LE, UTF_32, UTF_32LE, + C99, JAVA, ISO_8859_16, KOI8_U, KOI8_RU, CP862, CP866, MAC, MACCE, MACICE, + MACCRO, MACRO, MACCYR, MACUK, MACGR, MACTU, MACHEB, MACAR, MACTH, ROMAN8, + NEXTSTEP, ARMASCII, GEORGIAN_AC, GEORGIAN_PS, KOI8_T, MULELAO, CP1133, + TIS620, CP874, VISCII, TCVN, ISO_IR_14, JIS_X0201, JIS_X0208, JIS_X0212, + GB1988_80, GB2312_80, ISO_IR_165, ISO_IR_149, EUC_JP, SHIFT_JIS, CP932, + ISO_2022_JP, ISO_2022_JP1, ISO_2022_JP2, GB2312, CP936, GB18030, + ISO_2022_CN, ISO_2022_CNE, HZ, EUC_TW, BIG5, CP950, BIG5_HKSCS, EUC_KR, + CP949, CP1361, ISO_2022_KR, CP737, CP775, CP853, CP855, CP857, CP858, + CP860, CP861, CP863, CP864, CP865, CP869, CP1125]; + + {:Set of charsets supported by internal routines only.} + NoIconvChars: set of TMimeChar = [CP895, UTF_7mod]; + + {:null character replace table. (Usable for disable charater replacing.)} + Replace_None: array[0..0] of Word = + (0); + + {:Character replace table for remove Czech diakritics.} + Replace_Czech: array[0..59] of Word = + ( + $00E1, $0061, + $010D, $0063, + $010F, $0064, + $010E, $0044, + $00E9, $0065, + $011B, $0065, + $00ED, $0069, + $0148, $006E, + $00F3, $006F, + $0159, $0072, + $0161, $0073, + $0165, $0074, + $00FA, $0075, + $016F, $0075, + $00FD, $0079, + $017E, $007A, + $00C1, $0041, + $010C, $0043, + $00C9, $0045, + $011A, $0045, + $00CD, $0049, + $0147, $004E, + $00D3, $004F, + $0158, $0052, + $0160, $0053, + $0164, $0054, + $00DA, $0055, + $016E, $0055, + $00DD, $0059, + $017D, $005A + ); + +var + {:By this you can generally disable/enable Iconv support.} + DisableIconv: Boolean = False; + + {:Default set of charsets for @link(IdealCharsetCoding) function.} + IdealCharsets: TMimeSetChar = + [ISO_8859_1, ISO_8859_2, ISO_8859_3, ISO_8859_4, ISO_8859_5, + ISO_8859_6, ISO_8859_7, ISO_8859_8, ISO_8859_9, ISO_8859_10, + KOI8_R, KOI8_U + {$IFNDEF CIL} //error URW778 ??? :-O + , GB2312, EUC_KR, ISO_2022_JP, EUC_TW + {$ENDIF} + ]; + +{==============================================================================} +{:Convert Value from one charset to another. See: @link(CharsetConversionEx)} +function CharsetConversion(const Value: AnsiString; CharFrom: TMimeChar; + CharTo: TMimeChar): AnsiString; + +{:Convert Value from one charset to another with additional character conversion. +see: @link(Replace_None) and @link(Replace_Czech)} +function CharsetConversionEx(const Value: AnsiString; CharFrom: TMimeChar; + CharTo: TMimeChar; const TransformTable: array of Word): AnsiString; + +{:Convert Value from one charset to another with additional character conversion. + This funtion is similar to @link(CharsetConversionEx), but you can disable + transliteration of unconvertible characters.} +function CharsetConversionTrans(Value: AnsiString; CharFrom: TMimeChar; + CharTo: TMimeChar; const TransformTable: array of Word; Translit: Boolean): AnsiString; + +{:Returns charset used by operating system.} +function GetCurCP: TMimeChar; + +{:Returns charset used by operating system as OEM charset. (in Windows DOS box, + for example)} +function GetCurOEMCP: TMimeChar; + +{:Converting string with charset name to TMimeChar.} +function GetCPFromID(Value: AnsiString): TMimeChar; + +{:Converting TMimeChar to string with name of charset.} +function GetIDFromCP(Value: TMimeChar): AnsiString; + +{:return @true when value need to be converted. (It is not 7-bit ASCII)} +function NeedCharsetConversion(const Value: AnsiString): Boolean; + +{:Finding best target charset from set of TMimeChars with minimal count of + unconvertible characters.} +function IdealCharsetCoding(const Value: AnsiString; CharFrom: TMimeChar; + CharTo: TMimeSetChar): TMimeChar; + +{:Return BOM (Byte Order Mark) for given unicode charset.} +function GetBOM(Value: TMimeChar): AnsiString; + +{:Convert binary string with unicode content to WideString.} +function StringToWide(const Value: AnsiString): WideString; + +{:Convert WideString to binary string with unicode content.} +function WideToString(const Value: WideString): AnsiString; + +{==============================================================================} +implementation + +//character transcoding tables X to UCS-2 +{ +//dummy table +$0080, $0081, $0082, $0083, $0084, $0085, $0086, $0087, +$0088, $0089, $008A, $008B, $008C, $008D, $008E, $008F, +$0090, $0091, $0092, $0093, $0094, $0095, $0096, $0097, +$0098, $0099, $009A, $009B, $009C, $009D, $009E, $009F, +$00A0, $00A1, $00A2, $00A3, $00A4, $00A5, $00A6, $00A7, +$00A8, $00A9, $00AA, $00AB, $00AC, $00AD, $00AE, $00AF, +$00B0, $00B1, $00B2, $00B3, $00B4, $00B5, $00B6, $00B7, +$00B8, $00B9, $00BA, $00BB, $00BC, $00BD, $00BE, $00BF, +$00C0, $00C1, $00C2, $00C3, $00C4, $00C5, $00C6, $00C7, +$00C8, $00C9, $00CA, $00CB, $00CC, $00CD, $00CE, $00CF, +$00D0, $00D1, $00D2, $00D3, $00D4, $00D5, $00D6, $00D7, +$00D8, $00D9, $00DA, $00DB, $00DC, $00DD, $00DE, $00DF, +$00E0, $00E1, $00E2, $00E3, $00E4, $00E5, $00E6, $00E7, +$00E8, $00E9, $00EA, $00EB, $00EC, $00ED, $00EE, $00EF, +$00F0, $00F1, $00F2, $00F3, $00F4, $00F5, $00F6, $00F7, +$00F8, $00F9, $00FA, $00FB, $00FC, $00FD, $00FE, $00FF +} + +const + +{Latin-1 + Danish, Dutch, English, Faeroese, Finnish, French, German, Icelandic, + Irish, Italian, Norwegian, Portuguese, Spanish and Swedish. +} + CharISO_8859_1: array[128..255] of Word = + ( + $0080, $0081, $0082, $0083, $0084, $0085, $0086, $0087, + $0088, $0089, $008A, $008B, $008C, $008D, $008E, $008F, + $0090, $0091, $0092, $0093, $0094, $0095, $0096, $0097, + $0098, $0099, $009A, $009B, $009C, $009D, $009E, $009F, + $00A0, $00A1, $00A2, $00A3, $00A4, $00A5, $00A6, $00A7, + $00A8, $00A9, $00AA, $00AB, $00AC, $00AD, $00AE, $00AF, + $00B0, $00B1, $00B2, $00B3, $00B4, $00B5, $00B6, $00B7, + $00B8, $00B9, $00BA, $00BB, $00BC, $00BD, $00BE, $00BF, + $00C0, $00C1, $00C2, $00C3, $00C4, $00C5, $00C6, $00C7, + $00C8, $00C9, $00CA, $00CB, $00CC, $00CD, $00CE, $00CF, + $00D0, $00D1, $00D2, $00D3, $00D4, $00D5, $00D6, $00D7, + $00D8, $00D9, $00DA, $00DB, $00DC, $00DD, $00DE, $00DF, + $00E0, $00E1, $00E2, $00E3, $00E4, $00E5, $00E6, $00E7, + $00E8, $00E9, $00EA, $00EB, $00EC, $00ED, $00EE, $00EF, + $00F0, $00F1, $00F2, $00F3, $00F4, $00F5, $00F6, $00F7, + $00F8, $00F9, $00FA, $00FB, $00FC, $00FD, $00FE, $00FF + ); + +{Latin-2 + Albanian, Czech, English, German, Hungarian, Polish, Rumanian, + Serbo-Croatian, Slovak, Slovene and Swedish. +} + CharISO_8859_2: array[128..255] of Word = + ( + $0080, $0081, $0082, $0083, $0084, $0085, $0086, $0087, + $0088, $0089, $008A, $008B, $008C, $008D, $008E, $008F, + $0090, $0091, $0092, $0093, $0094, $0095, $0096, $0097, + $0098, $0099, $009A, $009B, $009C, $009D, $009E, $009F, + $00A0, $0104, $02D8, $0141, $00A4, $013D, $015A, $00A7, + $00A8, $0160, $015E, $0164, $0179, $00AD, $017D, $017B, + $00B0, $0105, $02DB, $0142, $00B4, $013E, $015B, $02C7, + $00B8, $0161, $015F, $0165, $017A, $02DD, $017E, $017C, + $0154, $00C1, $00C2, $0102, $00C4, $0139, $0106, $00C7, + $010C, $00C9, $0118, $00CB, $011A, $00CD, $00CE, $010E, + $0110, $0143, $0147, $00D3, $00D4, $0150, $00D6, $00D7, + $0158, $016E, $00DA, $0170, $00DC, $00DD, $0162, $00DF, + $0155, $00E1, $00E2, $0103, $00E4, $013A, $0107, $00E7, + $010D, $00E9, $0119, $00EB, $011B, $00ED, $00EE, $010F, + $0111, $0144, $0148, $00F3, $00F4, $0151, $00F6, $00F7, + $0159, $016F, $00FA, $0171, $00FC, $00FD, $0163, $02D9 + ); + +{Latin-3 + Afrikaans, Catalan, English, Esperanto, French, Galician, + German, Italian, Maltese and Turkish. +} + CharISO_8859_3: array[128..255] of Word = + ( + $0080, $0081, $0082, $0083, $0084, $0085, $0086, $0087, + $0088, $0089, $008A, $008B, $008C, $008D, $008E, $008F, + $0090, $0091, $0092, $0093, $0094, $0095, $0096, $0097, + $0098, $0099, $009A, $009B, $009C, $009D, $009E, $009F, + $00A0, $0126, $02D8, $00A3, $00A4, $FFFD, $0124, $00A7, + $00A8, $0130, $015E, $011E, $0134, $00AD, $FFFD, $017B, + $00B0, $0127, $00B2, $00B3, $00B4, $00B5, $0125, $00B7, + $00B8, $0131, $015F, $011F, $0135, $00BD, $FFFD, $017C, + $00C0, $00C1, $00C2, $FFFD, $00C4, $010A, $0108, $00C7, + $00C8, $00C9, $00CA, $00CB, $00CC, $00CD, $00CE, $00CF, + $FFFD, $00D1, $00D2, $00D3, $00D4, $0120, $00D6, $00D7, + $011C, $00D9, $00DA, $00DB, $00DC, $016C, $015C, $00DF, + $00E0, $00E1, $00E2, $FFFD, $00E4, $010B, $0109, $00E7, + $00E8, $00E9, $00EA, $00EB, $00EC, $00ED, $00EE, $00EF, + $FFFD, $00F1, $00F2, $00F3, $00F4, $0121, $00F6, $00F7, + $011D, $00F9, $00FA, $00FB, $00FC, $016D, $015D, $02D9 + ); + +{Latin-4 + Danish, English, Estonian, Finnish, German, Greenlandic, + Lappish, Latvian, Lithuanian, Norwegian and Swedish. +} + CharISO_8859_4: array[128..255] of Word = + ( + $0080, $0081, $0082, $0083, $0084, $0085, $0086, $0087, + $0088, $0089, $008A, $008B, $008C, $008D, $008E, $008F, + $0090, $0091, $0092, $0093, $0094, $0095, $0096, $0097, + $0098, $0099, $009A, $009B, $009C, $009D, $009E, $009F, + $00A0, $0104, $0138, $0156, $00A4, $0128, $013B, $00A7, + $00A8, $0160, $0112, $0122, $0166, $00AD, $017D, $00AF, + $00B0, $0105, $02DB, $0157, $00B4, $0129, $013C, $02C7, + $00B8, $0161, $0113, $0123, $0167, $014A, $017E, $014B, + $0100, $00C1, $00C2, $00C3, $00C4, $00C5, $00C6, $012E, + $010C, $00C9, $0118, $00CB, $0116, $00CD, $00CE, $012A, + $0110, $0145, $014C, $0136, $00D4, $00D5, $00D6, $00D7, + $00D8, $0172, $00DA, $00DB, $00DC, $0168, $016A, $00DF, + $0101, $00E1, $00E2, $00E3, $00E4, $00E5, $00E6, $012F, + $010D, $00E9, $0119, $00EB, $0117, $00ED, $00EE, $012B, + $0111, $0146, $014D, $0137, $00F4, $00F5, $00F6, $00F7, + $00F8, $0173, $00FA, $00FB, $00FC, $0169, $016B, $02D9 + ); + +{CYRILLIC + Bulgarian, Bielorussian, English, Macedonian, Russian, + Serbo-Croatian and Ukrainian. +} + CharISO_8859_5: array[128..255] of Word = + ( + $0080, $0081, $0082, $0083, $0084, $0085, $0086, $0087, + $0088, $0089, $008A, $008B, $008C, $008D, $008E, $008F, + $0090, $0091, $0092, $0093, $0094, $0095, $0096, $0097, + $0098, $0099, $009A, $009B, $009C, $009D, $009E, $009F, + $00A0, $0401, $0402, $0403, $0404, $0405, $0406, $0407, + $0408, $0409, $040A, $040B, $040C, $00AD, $040E, $040F, + $0410, $0411, $0412, $0413, $0414, $0415, $0416, $0417, + $0418, $0419, $041A, $041B, $041C, $041D, $041E, $041F, + $0420, $0421, $0422, $0423, $0424, $0425, $0426, $0427, + $0428, $0429, $042A, $042B, $042C, $042D, $042E, $042F, + $0430, $0431, $0432, $0433, $0434, $0435, $0436, $0437, + $0438, $0439, $043A, $043B, $043C, $043D, $043E, $043F, + $0440, $0441, $0442, $0443, $0444, $0445, $0446, $0447, + $0448, $0449, $044A, $044B, $044C, $044D, $044E, $044F, + $2116, $0451, $0452, $0453, $0454, $0455, $0456, $0457, + $0458, $0459, $045A, $045B, $045C, $00A7, $045E, $045F + ); + +{ARABIC +} + CharISO_8859_6: array[128..255] of Word = + ( + $0080, $0081, $0082, $0083, $0084, $0085, $0086, $0087, + $0088, $0089, $008A, $008B, $008C, $008D, $008E, $008F, + $0090, $0091, $0092, $0093, $0094, $0095, $0096, $0097, + $0098, $0099, $009A, $009B, $009C, $009D, $009E, $009F, + $00A0, $FFFD, $FFFD, $FFFD, $00A4, $FFFD, $FFFD, $FFFD, + $FFFD, $FFFD, $FFFD, $FFFD, $060C, $00AD, $FFFD, $FFFD, + $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, + $FFFD, $FFFD, $FFFD, $061B, $FFFD, $FFFD, $FFFD, $061F, + $FFFD, $0621, $0622, $0623, $0624, $0625, $0626, $0627, + $0628, $0629, $062A, $062B, $062C, $062D, $062E, $062F, + $0630, $0631, $0632, $0633, $0634, $0635, $0636, $0637, + $0638, $0639, $063A, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, + $0640, $0641, $0642, $0643, $0644, $0645, $0646, $0647, + $0648, $0649, $064A, $064B, $064C, $064D, $064E, $064F, + $0650, $0651, $0652, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, + $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD + ); + +{GREEK +} + CharISO_8859_7: array[128..255] of Word = + ( + $0080, $0081, $0082, $0083, $0084, $0085, $0086, $0087, + $0088, $0089, $008A, $008B, $008C, $008D, $008E, $008F, + $0090, $0091, $0092, $0093, $0094, $0095, $0096, $0097, + $0098, $0099, $009A, $009B, $009C, $009D, $009E, $009F, + $00A0, $2018, $2019, $00A3, $FFFD, $FFFD, $00A6, $00A7, + $00A8, $00A9, $FFFD, $00AB, $00AC, $00AD, $FFFD, $2015, + $00B0, $00B1, $00B2, $00B3, $0384, $0385, $0386, $00B7, + $0388, $0389, $038A, $00BB, $038C, $00BD, $038E, $038F, + $0390, $0391, $0392, $0393, $0394, $0395, $0396, $0397, + $0398, $0399, $039A, $039B, $039C, $039D, $039E, $039F, + $03A0, $03A1, $FFFD, $03A3, $03A4, $03A5, $03A6, $03A7, + $03A8, $03A9, $03AA, $03AB, $03AC, $03AD, $03AE, $03AF, + $03B0, $03B1, $03B2, $03B3, $03B4, $03B5, $03B6, $03B7, + $03B8, $03B9, $03BA, $03BB, $03BC, $03BD, $03BE, $03BF, + $03C0, $03C1, $03C2, $03C3, $03C4, $03C5, $03C6, $03C7, + $03C8, $03C9, $03CA, $03CB, $03CC, $03CD, $03CE, $FFFD + ); + +{HEBREW +} + CharISO_8859_8: array[128..255] of Word = + ( + $0080, $0081, $0082, $0083, $0084, $0085, $0086, $0087, + $0088, $0089, $008A, $008B, $008C, $008D, $008E, $008F, + $0090, $0091, $0092, $0093, $0094, $0095, $0096, $0097, + $0098, $0099, $009A, $009B, $009C, $009D, $009E, $009F, + $00A0, $FFFD, $00A2, $00A3, $00A4, $00A5, $00A6, $00A7, + $00A8, $00A9, $00D7, $00AB, $00AC, $00AD, $00AE, $00AF, + $00B0, $00B1, $00B2, $00B3, $00B4, $00B5, $00B6, $00B7, + $00B8, $00B9, $00F7, $00BB, $00BC, $00BD, $00BE, $FFFD, + $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, + $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, + $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, + $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $2017, + $05D0, $05D1, $05D2, $05D3, $05D4, $05D5, $05D6, $05D7, + $05D8, $05D9, $05DA, $05DB, $05DC, $05DD, $05DE, $05DF, + $05E0, $05E1, $05E2, $05E3, $05E4, $05E5, $05E6, $05E7, + $05E8, $05E9, $05EA, $FFFD, $FFFD, $200E, $200F, $FFFD + ); + +{Latin-5 + English, Finnish, French, German, Irish, Italian, Norwegian, + Portuguese, Spanish, Swedish and Turkish. +} + CharISO_8859_9: array[128..255] of Word = + ( + $0080, $0081, $0082, $0083, $0084, $0085, $0086, $0087, + $0088, $0089, $008A, $008B, $008C, $008D, $008E, $008F, + $0090, $0091, $0092, $0093, $0094, $0095, $0096, $0097, + $0098, $0099, $009A, $009B, $009C, $009D, $009E, $009F, + $00A0, $0104, $02D8, $0141, $00A4, $013D, $015A, $00A7, + $00A8, $0160, $015E, $0164, $0179, $00AD, $017D, $017B, + $00B0, $0105, $02DB, $0142, $00B4, $013E, $015B, $02C7, + $00B8, $0161, $015F, $0165, $017A, $02DD, $017E, $017C, + $0154, $00C1, $00C2, $0102, $00C4, $0139, $0106, $00C7, + $010C, $00C9, $0118, $00CB, $011A, $00CD, $00CE, $010E, + $011E, $00D1, $00D2, $00D3, $00D4, $00D5, $00D6, $00D7, + $00D8, $00D9, $00DA, $00DB, $00DC, $0130, $015E, $00DF, + $00E0, $00E1, $00E2, $00E3, $00E4, $00E5, $00E6, $00E7, + $00E8, $00E9, $00EA, $00EB, $00EC, $00ED, $00EE, $00EF, + $011F, $00F1, $00F2, $00F3, $00F4, $00F5, $00F6, $00F7, + $00F8, $00F9, $00FA, $00FB, $00FC, $0131, $015F, $00FF + ); + +{Latin-6 + Danish, English, Estonian, Faeroese, Finnish, German, Greenlandic, + Icelandic, Lappish, Latvian, Lithuanian, Norwegian and Swedish. +} + CharISO_8859_10: array[128..255] of Word = + ( + $0080, $0081, $0082, $0083, $0084, $0085, $0086, $0087, + $0088, $0089, $008A, $008B, $008C, $008D, $008E, $008F, + $0090, $0091, $0092, $0093, $0094, $0095, $0096, $0097, + $0098, $0099, $009A, $009B, $009C, $009D, $009E, $009F, + $00A0, $0104, $0112, $0122, $012A, $0128, $0136, $00A7, + $013B, $0110, $0160, $0166, $017D, $00AD, $016A, $014A, + $00B0, $0105, $0113, $0123, $012B, $0129, $0137, $00B7, + $013C, $0111, $0161, $0167, $017E, $2015, $016B, $014B, + $0100, $00C1, $00C2, $00C3, $00C4, $00C5, $00C6, $012E, + $010C, $00C9, $0118, $00CB, $0116, $00CD, $00CE, $00CF, + $00D0, $0145, $014C, $00D3, $00D4, $00D5, $00D6, $0168, + $00D8, $0172, $00DA, $00DB, $00DC, $00DD, $00DE, $00DF, + $0101, $00E1, $00E2, $00E3, $00E4, $00E5, $00E6, $012F, + $010D, $00E9, $0119, $00EB, $0117, $00ED, $00EE, $00EF, + $00F0, $0146, $014D, $00F3, $00F4, $00F5, $00F6, $0169, + $00F8, $0173, $00FA, $00FB, $00FC, $00FD, $00FE, $0138 + ); + + CharISO_8859_13: array[128..255] of Word = + ( + $0080, $0081, $0082, $0083, $0084, $0085, $0086, $0087, + $0088, $0089, $008A, $008B, $008C, $008D, $008E, $008F, + $0090, $0091, $0092, $0093, $0094, $0095, $0096, $0097, + $0098, $0099, $009A, $009B, $009C, $009D, $009E, $009F, + $00A0, $201D, $00A2, $00A3, $00A4, $201E, $00A6, $00A7, + $00D8, $00A9, $0156, $00AB, $00AC, $00AD, $00AE, $00C6, + $00B0, $00B1, $00B2, $00B3, $201C, $00B5, $00B6, $00B7, + $00F8, $00B9, $0157, $00BB, $00BC, $00BD, $00BE, $00E6, + $0104, $012E, $0100, $0106, $00C4, $00C5, $0118, $0112, + $010C, $00C9, $0179, $0116, $0122, $0136, $012A, $013B, + $0160, $0143, $0145, $00D3, $014C, $00D5, $00D6, $00D7, + $0172, $0141, $015A, $016A, $00DC, $017B, $017D, $00DF, + $0105, $012F, $0101, $0107, $00E4, $00E5, $0119, $0113, + $010D, $00E9, $017A, $0117, $0123, $0137, $012B, $013C, + $0161, $0144, $0146, $00F3, $014D, $00F5, $00F6, $00F7, + $0173, $0142, $015B, $016B, $00FC, $017C, $017E, $2019 + ); + + CharISO_8859_14: array[128..255] of Word = + ( + $0080, $0081, $0082, $0083, $0084, $0085, $0086, $0087, + $0088, $0089, $008A, $008B, $008C, $008D, $008E, $008F, + $0090, $0091, $0092, $0093, $0094, $0095, $0096, $0097, + $0098, $0099, $009A, $009B, $009C, $009D, $009E, $009F, + $00A0, $1E02, $1E03, $00A3, $010A, $010B, $1E0A, $00A7, + $1E80, $00A9, $1E82, $1E0B, $1EF2, $00AD, $00AE, $0178, + $1E1E, $1E1F, $0120, $0121, $1E40, $1E41, $00B6, $1E56, + $1E81, $1E57, $1E83, $1E60, $1EF3, $1E84, $1E85, $1E61, + $00C0, $00C1, $00C2, $00C3, $00C4, $00C5, $00C6, $00C7, + $00C8, $00C9, $00CA, $00CB, $00CC, $00CD, $00CE, $00CF, + $0174, $00D1, $00D2, $00D3, $00D4, $00D5, $00D6, $1E6A, + $00D8, $00D9, $00DA, $00DB, $00DC, $00DD, $0176, $00DF, + $00E0, $00E1, $00E2, $00E3, $00E4, $00E5, $00E6, $00E7, + $00E8, $00E9, $00EA, $00EB, $00EC, $00ED, $00EE, $00EF, + $0175, $00F1, $00F2, $00F3, $00F4, $00F5, $00F6, $1E6B, + $00F8, $00F9, $00FA, $00FB, $00FC, $00FD, $0177, $00FF + ); + + CharISO_8859_15: array[128..255] of Word = + ( + $0080, $0081, $0082, $0083, $0084, $0085, $0086, $0087, + $0088, $0089, $008A, $008B, $008C, $008D, $008E, $008F, + $0090, $0091, $0092, $0093, $0094, $0095, $0096, $0097, + $0098, $0099, $009A, $009B, $009C, $009D, $009E, $009F, + $00A0, $00A1, $00A2, $00A3, $20AC, $00A5, $0160, $00A7, + $0161, $00A9, $00AA, $00AB, $00AC, $00AD, $00AE, $00AF, + $00B0, $00B1, $00B2, $00B3, $017D, $00B5, $00B6, $00B7, + $017E, $00B9, $00BA, $00BB, $0152, $0153, $0178, $00BF, + $00C0, $00C1, $00C2, $00C3, $00C4, $00C5, $00C6, $00C7, + $00C8, $00C9, $00CA, $00CB, $00CC, $00CD, $00CE, $00CF, + $00D0, $00D1, $00D2, $00D3, $00D4, $00D5, $00D6, $00D7, + $00D8, $00D9, $00DA, $00DB, $00DC, $00DD, $00DE, $00DF, + $00E0, $00E1, $00E2, $00E3, $00E4, $00E5, $00E6, $00E7, + $00E8, $00E9, $00EA, $00EB, $00EC, $00ED, $00EE, $00EF, + $00F0, $00F1, $00F2, $00F3, $00F4, $00F5, $00F6, $00F7, + $00F8, $00F9, $00FA, $00FB, $00FC, $00FD, $00FE, $00FF + ); + +{Eastern European +} + CharCP_1250: array[128..255] of Word = + ( + $20AC, $FFFD, $201A, $FFFD, $201E, $2026, $2020, $2021, + $FFFD, $2030, $0160, $2039, $015A, $0164, $017D, $0179, + $FFFD, $2018, $2019, $201C, $201D, $2022, $2013, $2014, + $FFFD, $2122, $0161, $203A, $015B, $0165, $017E, $017A, + $00A0, $02C7, $02D8, $0141, $00A4, $0104, $00A6, $00A7, + $00A8, $00A9, $015E, $00AB, $00AC, $00AD, $00AE, $017B, + $00B0, $00B1, $02DB, $0142, $00B4, $00B5, $00B6, $00B7, + $00B8, $0105, $015F, $00BB, $013D, $02DD, $013E, $017C, + $0154, $00C1, $00C2, $0102, $00C4, $0139, $0106, $00C7, + $010C, $00C9, $0118, $00CB, $011A, $00CD, $00CE, $010E, + $0110, $0143, $0147, $00D3, $00D4, $0150, $00D6, $00D7, + $0158, $016E, $00DA, $0170, $00DC, $00DD, $0162, $00DF, + $0155, $00E1, $00E2, $0103, $00E4, $013A, $0107, $00E7, + $010D, $00E9, $0119, $00EB, $011B, $00ED, $00EE, $010F, + $0111, $0144, $0148, $00F3, $00F4, $0151, $00F6, $00F7, + $0159, $016F, $00FA, $0171, $00FC, $00FD, $0163, $02D9 + ); + +{Cyrillic +} + CharCP_1251: array[128..255] of Word = + ( + $0402, $0403, $201A, $0453, $201E, $2026, $2020, $2021, + $20AC, $2030, $0409, $2039, $040A, $040C, $040B, $040F, + $0452, $2018, $2019, $201C, $201D, $2022, $2013, $2014, + $FFFD, $2122, $0459, $203A, $045A, $045C, $045B, $045F, + $00A0, $040E, $045E, $0408, $00A4, $0490, $00A6, $00A7, + $0401, $00A9, $0404, $00AB, $00AC, $00AD, $00AE, $0407, + $00B0, $00B1, $0406, $0456, $0491, $00B5, $00B6, $00B7, + $0451, $2116, $0454, $00BB, $0458, $0405, $0455, $0457, + $0410, $0411, $0412, $0413, $0414, $0415, $0416, $0417, + $0418, $0419, $041A, $041B, $041C, $041D, $041E, $041F, + $0420, $0421, $0422, $0423, $0424, $0425, $0426, $0427, + $0428, $0429, $042A, $042B, $042C, $042D, $042E, $042F, + $0430, $0431, $0432, $0433, $0434, $0435, $0436, $0437, + $0438, $0439, $043A, $043B, $043C, $043D, $043E, $043F, + $0440, $0441, $0442, $0443, $0444, $0445, $0446, $0447, + $0448, $0449, $044A, $044B, $044C, $044D, $044E, $044F + ); + +{Latin-1 (US, Western Europe) +} + CharCP_1252: array[128..255] of Word = + ( + $20AC, $FFFD, $201A, $0192, $201E, $2026, $2020, $2021, + $02C6, $2030, $0160, $2039, $0152, $FFFD, $017D, $FFFD, + $FFFD, $2018, $2019, $201C, $201D, $2022, $2013, $2014, + $02DC, $2122, $0161, $203A, $0153, $FFFD, $017E, $0178, + $00A0, $00A1, $00A2, $00A3, $00A4, $00A5, $00A6, $00A7, + $00A8, $00A9, $00AA, $00AB, $00AC, $00AD, $00AE, $00AF, + $00B0, $00B1, $00B2, $00B3, $00B4, $00B5, $00B6, $00B7, + $00B8, $00B9, $00BA, $00BB, $00BC, $00BD, $00BE, $00BF, + $00C0, $00C1, $00C2, $00C3, $00C4, $00C5, $00C6, $00C7, + $00C8, $00C9, $00CA, $00CB, $00CC, $00CD, $00CE, $00CF, + $00D0, $00D1, $00D2, $00D3, $00D4, $00D5, $00D6, $00D7, + $00D8, $00D9, $00DA, $00DB, $00DC, $00DD, $00DE, $00DF, + $00E0, $00E1, $00E2, $00E3, $00E4, $00E5, $00E6, $00E7, + $00E8, $00E9, $00EA, $00EB, $00EC, $00ED, $00EE, $00EF, + $00F0, $00F1, $00F2, $00F3, $00F4, $00F5, $00F6, $00F7, + $00F8, $00F9, $00FA, $00FB, $00FC, $00FD, $00FE, $00FF + ); + +{Greek +} + CharCP_1253: array[128..255] of Word = + ( + $20AC, $FFFD, $201A, $0192, $201E, $2026, $2020, $2021, + $FFFD, $2030, $FFFD, $2039, $FFFD, $FFFD, $FFFD, $FFFD, + $FFFD, $2018, $2019, $201C, $201D, $2022, $2013, $2014, + $FFFD, $2122, $FFFD, $203A, $FFFD, $FFFD, $FFFD, $FFFD, + $00A0, $0385, $0386, $00A3, $00A4, $00A5, $00A6, $00A7, + $00A8, $00A9, $FFFD, $00AB, $00AC, $00AD, $00AE, $2015, + $00B0, $00B1, $00B2, $00B3, $0384, $00B5, $00B6, $00B7, + $0388, $0389, $038A, $00BB, $038C, $00BD, $038E, $038F, + $0390, $0391, $0392, $0393, $0394, $0395, $0396, $0397, + $0398, $0399, $039A, $039B, $039C, $039D, $039E, $039F, + $03A0, $03A1, $FFFD, $03A3, $03A4, $03A5, $03A6, $03A7, + $03A8, $03A9, $03AA, $03AB, $03AC, $03AD, $03AE, $03AF, + $03B0, $03B1, $03B2, $03B3, $03B4, $03B5, $03B6, $03B7, + $03B8, $03B9, $03BA, $03BB, $03BC, $03BD, $03BE, $03BF, + $03C0, $03C1, $03C2, $03C3, $03C4, $03C5, $03C6, $03C7, + $03C8, $03C9, $03CA, $03CB, $03CC, $03CD, $03CE, $FFFD + ); + +{Turkish +} + CharCP_1254: array[128..255] of Word = + ( + $20AC, $FFFD, $201A, $0192, $201E, $2026, $2020, $2021, + $02C6, $2030, $0160, $2039, $0152, $FFFD, $FFFD, $FFFD, + $FFFD, $2018, $2019, $201C, $201D, $2022, $2013, $2014, + $02DC, $2122, $0161, $203A, $0153, $FFFD, $FFFD, $0178, + $00A0, $00A1, $00A2, $00A3, $00A4, $00A5, $00A6, $00A7, + $00A8, $00A9, $00AA, $00AB, $00AC, $00AD, $00AE, $00AF, + $00B0, $00B1, $00B2, $00B3, $00B4, $00B5, $00B6, $00B7, + $00B8, $00B9, $00BA, $00BB, $00BC, $00BD, $00BE, $00BF, + $00C0, $00C1, $00C2, $00C3, $00C4, $00C5, $00C6, $00C7, + $00C8, $00C9, $00CA, $00CB, $00CC, $00CD, $00CE, $00CF, + $011E, $00D1, $00D2, $00D3, $00D4, $00D5, $00D6, $00D7, + $00D8, $00D9, $00DA, $00DB, $00DC, $0130, $015E, $00DF, + $00E0, $00E1, $00E2, $00E3, $00E4, $00E5, $00E6, $00E7, + $00E8, $00E9, $00EA, $00EB, $00EC, $00ED, $00EE, $00EF, + $011F, $00F1, $00F2, $00F3, $00F4, $00F5, $00F6, $00F7, + $00F8, $00F9, $00FA, $00FB, $00FC, $0131, $015F, $00FF + ); + +{Hebrew +} + CharCP_1255: array[128..255] of Word = + ( + $20AC, $FFFD, $201A, $0192, $201E, $2026, $2020, $2021, + $02C6, $2030, $FFFD, $2039, $FFFD, $FFFD, $FFFD, $FFFD, + $FFFD, $2018, $2019, $201C, $201D, $2022, $2013, $2014, + $02DC, $2122, $FFFD, $203A, $FFFD, $FFFD, $FFFD, $FFFD, + $00A0, $00A1, $00A2, $00A3, $20AA, $00A5, $00A6, $00A7, + $00A8, $00A9, $00D7, $00AB, $00AC, $00AD, $00AE, $00AF, + $00B0, $00B1, $00B2, $00B3, $00B4, $00B5, $00B6, $00B7, + $00B8, $00B9, $00F7, $00BB, $00BC, $00BD, $00BE, $00BF, + $05B0, $05B1, $05B2, $05B3, $05B4, $05B5, $05B6, $05B7, + $05B8, $05B9, $FFFD, $05BB, $05BC, $05BD, $05BE, $05BF, + $05C0, $05C1, $05C2, $05C3, $05F0, $05F1, $05F2, $05F3, + $05F4, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, + $05D0, $05D1, $05D2, $05D3, $05D4, $05D5, $05D6, $05D7, + $05D8, $05D9, $05DA, $05DB, $05DC, $05DD, $05DE, $05DF, + $05E0, $05E1, $05E2, $05E3, $05E4, $05E5, $05E6, $05E7, + $05E8, $05E9, $05EA, $FFFD, $FFFD, $200E, $200F, $FFFD + ); + +{Arabic +} + CharCP_1256: array[128..255] of Word = + ( + $20AC, $067E, $201A, $0192, $201E, $2026, $2020, $2021, + $02C6, $2030, $0679, $2039, $0152, $0686, $0698, $0688, + $06AF, $2018, $2019, $201C, $201D, $2022, $2013, $2014, + $06A9, $2122, $0691, $203A, $0153, $200C, $200D, $06BA, + $00A0, $060C, $00A2, $00A3, $00A4, $00A5, $00A6, $00A7, + $00A8, $00A9, $06BE, $00AB, $00AC, $00AD, $00AE, $00AF, + $00B0, $00B1, $00B2, $00B3, $00B4, $00B5, $00B6, $00B7, + $00B8, $00B9, $061B, $00BB, $00BC, $00BD, $00BE, $061F, + $06C1, $0621, $0622, $0623, $0624, $0625, $0626, $0627, + $0628, $0629, $062A, $062B, $062C, $062D, $062E, $062F, + $0630, $0631, $0632, $0633, $0634, $0635, $0636, $00D7, + $0637, $0638, $0639, $063A, $0640, $0641, $0642, $0643, + $00E0, $0644, $00E2, $0645, $0646, $0647, $0648, $00E7, + $00E8, $00E9, $00EA, $00EB, $0649, $064A, $00EE, $00EF, + $064B, $064C, $064D, $064E, $00F4, $064F, $0650, $00F7, + $0651, $00F9, $0652, $00FB, $00FC, $200E, $200F, $06D2 + ); + +{Baltic +} + CharCP_1257: array[128..255] of Word = + ( + $20AC, $FFFD, $201A, $FFFD, $201E, $2026, $2020, $2021, + $FFFD, $2030, $FFFD, $2039, $FFFD, $00A8, $02C7, $00B8, + $FFFD, $2018, $2019, $201C, $201D, $2022, $2013, $2014, + $FFFD, $2122, $FFFD, $203A, $FFFD, $00AF, $02DB, $FFFD, + $00A0, $FFFD, $00A2, $00A3, $00A4, $FFFD, $00A6, $00A7, + $00D8, $00A9, $0156, $00AB, $00AC, $00AD, $00AE, $00C6, + $00B0, $00B1, $00B2, $00B3, $00B4, $00B5, $00B6, $00B7, + $00F8, $00B9, $0157, $00BB, $00BC, $00BD, $00BE, $00E6, + $0104, $012E, $0100, $0106, $00C4, $00C5, $0118, $0112, + $010C, $00C9, $0179, $0116, $0122, $0136, $012A, $013B, + $0160, $0143, $0145, $00D3, $014C, $00D5, $00D6, $00D7, + $0172, $0141, $015A, $016A, $00DC, $017B, $017D, $00DF, + $0105, $012F, $0101, $0107, $00E4, $00E5, $0119, $0113, + $010D, $00E9, $017A, $0117, $0123, $0137, $012B, $013C, + $0161, $0144, $0146, $00F3, $014D, $00F5, $00F6, $00F7, + $0173, $0142, $015B, $016B, $00FC, $017C, $017E, $02D9 + ); + +{Vietnamese +} + CharCP_1258: array[128..255] of Word = + ( + $20AC, $FFFD, $201A, $0192, $201E, $2026, $2020, $2021, + $02C6, $2030, $FFFD, $2039, $0152, $FFFD, $FFFD, $FFFD, + $FFFD, $2018, $2019, $201C, $201D, $2022, $2013, $2014, + $02DC, $2122, $FFFD, $203A, $0153, $FFFD, $FFFD, $0178, + $00A0, $00A1, $00A2, $00A3, $00A4, $00A5, $00A6, $00A7, + $00A8, $00A9, $00AA, $00AB, $00AC, $00AD, $00AE, $00AF, + $00B0, $00B1, $00B2, $00B3, $00B4, $00B5, $00B6, $00B7, + $00B8, $00B9, $00BA, $00BB, $00BC, $00BD, $00BE, $00BF, + $00C0, $00C1, $00C2, $0102, $00C4, $00C5, $00C6, $00C7, + $00C8, $00C9, $00CA, $00CB, $0300, $00CD, $00CE, $00CF, + $0110, $00D1, $0309, $00D3, $00D4, $01A0, $00D6, $00D7, + $00D8, $00D9, $00DA, $00DB, $00DC, $01AF, $0303, $00DF, + $00E0, $00E1, $00E2, $0103, $00E4, $00E5, $00E6, $00E7, + $00E8, $00E9, $00EA, $00EB, $0301, $00ED, $00EE, $00EF, + $0111, $00F1, $0323, $00F3, $00F4, $01A1, $00F6, $00F7, + $00F8, $00F9, $00FA, $00FB, $00FC, $01B0, $20AB, $00FF + ); + +{Cyrillic +} + CharKOI8_R: array[128..255] of Word = + ( + $2500, $2502, $250C, $2510, $2514, $2518, $251C, $2524, + $252C, $2534, $253C, $2580, $2584, $2588, $258C, $2590, + $2591, $2592, $2593, $2320, $25A0, $2219, $221A, $2248, + $2264, $2265, $00A0, $2321, $00B0, $00B2, $00B7, $00F7, + $2550, $2551, $2552, $0451, $2553, $2554, $2555, $2556, + $2557, $2558, $2559, $255A, $255B, $255C, $255D, $255E, + $255F, $2560, $2561, $0401, $2562, $2563, $2564, $2565, + $2566, $2567, $2568, $2569, $256A, $256B, $256C, $00A9, + $044E, $0430, $0431, $0446, $0434, $0435, $0444, $0433, + $0445, $0438, $0439, $043A, $043B, $043C, $043D, $043E, + $043F, $044F, $0440, $0441, $0442, $0443, $0436, $0432, + $044C, $044B, $0437, $0448, $044D, $0449, $0447, $044A, + $042E, $0410, $0411, $0426, $0414, $0415, $0424, $0413, + $0425, $0418, $0419, $041A, $041B, $041C, $041D, $041E, + $041F, $042F, $0420, $0421, $0422, $0423, $0416, $0412, + $042C, $042B, $0417, $0428, $042D, $0429, $0427, $042A + ); + +{Czech (Kamenicky) +} + CharCP_895: array[128..255] of Word = + ( + $010C, $00FC, $00E9, $010F, $00E4, $010E, $0164, $010D, + $011B, $011A, $0139, $00CD, $013E, $013A, $00C4, $00C1, + $00C9, $017E, $017D, $00F4, $00F6, $00D3, $016F, $00DA, + $00FD, $00D6, $00DC, $0160, $013D, $00DD, $0158, $0165, + $00E1, $00ED, $00F3, $00FA, $0148, $0147, $016E, $00D4, + $0161, $0159, $0155, $0154, $00BC, $00A7, $00AB, $00BB, + $2591, $2592, $2593, $2502, $2524, $2561, $2562, $2556, + $2555, $2563, $2551, $2557, $255D, $255C, $255B, $2510, + $2514, $2534, $252C, $251C, $2500, $253C, $255E, $255F, + $255A, $2554, $2569, $2566, $2560, $2550, $256C, $2567, + $2568, $2564, $2565, $2559, $2558, $2552, $2553, $256B, + $256A, $2518, $250C, $2588, $2584, $258C, $2590, $2580, + $03B1, $03B2, $0393, $03C0, $03A3, $03C3, $03BC, $03C4, + $03A6, $0398, $03A9, $03B4, $221E, $2205, $03B5, $2229, + $2261, $00B1, $2265, $2264, $2320, $2321, $00F7, $2248, + $2218, $00B7, $2219, $221A, $207F, $00B2, $25A0, $00A0 + ); + +{Eastern European +} + CharCP_852: array[128..255] of Word = + ( + $00C7, $00FC, $00E9, $00E2, $00E4, $016F, $0107, $00E7, + $0142, $00EB, $0150, $0151, $00EE, $0179, $00C4, $0106, + $00C9, $0139, $013A, $00F4, $00F6, $013D, $013E, $015A, + $015B, $00D6, $00DC, $0164, $0165, $0141, $00D7, $010D, + $00E1, $00ED, $00F3, $00FA, $0104, $0105, $017D, $017E, + $0118, $0119, $00AC, $017A, $010C, $015F, $00AB, $00BB, + $2591, $2592, $2593, $2502, $2524, $00C1, $00C2, $011A, + $015E, $2563, $2551, $2557, $255D, $017B, $017C, $2510, + $2514, $2534, $252C, $251C, $2500, $253C, $0102, $0103, + $255A, $2554, $2569, $2566, $2560, $2550, $256C, $00A4, + $0111, $0110, $010E, $00CB, $010F, $0147, $00CD, $00CE, + $011B, $2518, $250C, $2588, $2584, $0162, $016E, $2580, + $00D3, $00DF, $00D4, $0143, $0144, $0148, $0160, $0161, + $0154, $00DA, $0155, $0170, $00FD, $00DD, $0163, $00B4, + $00AD, $02DD, $02DB, $02C7, $02D8, $00A7, $00F7, $00B8, + $00B0, $00A8, $02D9, $0171, $0158, $0159, $25A0, $00A0 + ); + +{==============================================================================} +type + TIconvChar = record + Charset: TMimeChar; + CharName: string; + end; + TIconvArr = array [0..112] of TIconvChar; + +const + NotFoundChar = '_'; + +var + SetTwo: set of TMimeChar = [UCS_2, UCS_2LE, UTF_7, UTF_7mod]; + SetFour: set of TMimeChar = [UCS_4, UCS_4LE, UTF_8]; + SetLE: set of TMimeChar = [UCS_2LE, UCS_4LE]; + + IconvArr: TIconvArr; + +{==============================================================================} +function FindIconvID(const Value, Charname: string): Boolean; +var + s: string; +begin + Result := True; + //exact match + if Value = Charname then + Exit; + //Value is on begin of charname + s := Value + ' '; + if s = Copy(Charname, 1, Length(s)) then + Exit; + //Value is on end of charname + s := ' ' + Value; + if s = Copy(Charname, Length(Charname) - Length(s) + 1, Length(s)) then + Exit; + //value is somewhere inside charname + if Pos( s + ' ', Charname) > 0 then + Exit; + Result := False; +end; + +function GetCPFromIconvID(Value: AnsiString): TMimeChar; +var + n: integer; +begin + Result := ISO_8859_1; + Value := UpperCase(Value); + for n := 0 to High(IconvArr) do + if FindIconvID(Value, IconvArr[n].Charname) then + begin + Result := IconvArr[n].Charset; + Break; + end; +end; + +{==============================================================================} +function GetIconvIDFromCP(Value: TMimeChar): AnsiString; +var + n: integer; +begin + Result := 'ISO-8859-1'; + for n := 0 to High(IconvArr) do + if IconvArr[n].Charset = Value then + begin + Result := Separateleft(IconvArr[n].Charname, ' '); + Break; + end; +end; + +{==============================================================================} +function ReplaceUnicode(Value: Word; const TransformTable: array of Word): Word; +var + n: integer; +begin + if High(TransformTable) <> 0 then + for n := 0 to High(TransformTable) do + if not odd(n) then + if TransformTable[n] = Value then + begin + Value := TransformTable[n+1]; + break; + end; + Result := Value; +end; + +{==============================================================================} +procedure CopyArray(const SourceTable: array of Word; + var TargetTable: array of Word); +var + n: Integer; +begin + for n := 0 to 127 do + TargetTable[n] := SourceTable[n]; +end; + +{==============================================================================} +procedure GetArray(CharSet: TMimeChar; var Result: array of Word); +begin + case CharSet of + ISO_8859_2: + CopyArray(CharISO_8859_2, Result); + ISO_8859_3: + CopyArray(CharISO_8859_3, Result); + ISO_8859_4: + CopyArray(CharISO_8859_4, Result); + ISO_8859_5: + CopyArray(CharISO_8859_5, Result); + ISO_8859_6: + CopyArray(CharISO_8859_6, Result); + ISO_8859_7: + CopyArray(CharISO_8859_7, Result); + ISO_8859_8: + CopyArray(CharISO_8859_8, Result); + ISO_8859_9: + CopyArray(CharISO_8859_9, Result); + ISO_8859_10: + CopyArray(CharISO_8859_10, Result); + ISO_8859_13: + CopyArray(CharISO_8859_13, Result); + ISO_8859_14: + CopyArray(CharISO_8859_14, Result); + ISO_8859_15: + CopyArray(CharISO_8859_15, Result); + CP1250: + CopyArray(CharCP_1250, Result); + CP1251: + CopyArray(CharCP_1251, Result); + CP1252: + CopyArray(CharCP_1252, Result); + CP1253: + CopyArray(CharCP_1253, Result); + CP1254: + CopyArray(CharCP_1254, Result); + CP1255: + CopyArray(CharCP_1255, Result); + CP1256: + CopyArray(CharCP_1256, Result); + CP1257: + CopyArray(CharCP_1257, Result); + CP1258: + CopyArray(CharCP_1258, Result); + KOI8_R: + CopyArray(CharKOI8_R, Result); + CP895: + CopyArray(CharCP_895, Result); + CP852: + CopyArray(CharCP_852, Result); + else + CopyArray(CharISO_8859_1, Result); + end; +end; + +{==============================================================================} +procedure ReadMulti(const Value: AnsiString; var Index: Integer; mb: Byte; + var b1, b2, b3, b4: Byte; le: boolean); +Begin + b1 := 0; + b2 := 0; + b3 := 0; + b4 := 0; + if Index < 0 then + Index := 1; + if mb > 4 then + mb := 1; + if (Index + mb - 1) <= Length(Value) then + begin + if le then + Case mb Of + 1: + b1 := Ord(Value[Index]); + 2: + Begin + b1 := Ord(Value[Index]); + b2 := Ord(Value[Index + 1]); + End; + 3: + Begin + b1 := Ord(Value[Index]); + b2 := Ord(Value[Index + 1]); + b3 := Ord(Value[Index + 2]); + End; + 4: + Begin + b1 := Ord(Value[Index]); + b2 := Ord(Value[Index + 1]); + b3 := Ord(Value[Index + 2]); + b4 := Ord(Value[Index + 3]); + End; + end + else + Case mb Of + 1: + b1 := Ord(Value[Index]); + 2: + Begin + b2 := Ord(Value[Index]); + b1 := Ord(Value[Index + 1]); + End; + 3: + Begin + b3 := Ord(Value[Index]); + b2 := Ord(Value[Index + 1]); + b1 := Ord(Value[Index + 2]); + End; + 4: + Begin + b4 := Ord(Value[Index]); + b3 := Ord(Value[Index + 1]); + b2 := Ord(Value[Index + 2]); + b1 := Ord(Value[Index + 3]); + End; + end; + end; + Inc(Index, mb); +end; + +{==============================================================================} +function WriteMulti(b1, b2, b3, b4: Byte; mb: Byte; le: boolean): AnsiString; +begin + if mb > 4 then + mb := 1; + SetLength(Result, mb); + if le then + case mb Of + 1: + Result[1] := AnsiChar(b1); + 2: + begin + Result[1] := AnsiChar(b1); + Result[2] := AnsiChar(b2); + end; + 3: + begin + Result[1] := AnsiChar(b1); + Result[2] := AnsiChar(b2); + Result[3] := AnsiChar(b3); + end; + 4: + begin + Result[1] := AnsiChar(b1); + Result[2] := AnsiChar(b2); + Result[3] := AnsiChar(b3); + Result[4] := AnsiChar(b4); + end; + end + else + case mb Of + 1: + Result[1] := AnsiChar(b1); + 2: + begin + Result[2] := AnsiChar(b1); + Result[1] := AnsiChar(b2); + end; + 3: + begin + Result[3] := AnsiChar(b1); + Result[2] := AnsiChar(b2); + Result[1] := AnsiChar(b3); + end; + 4: + begin + Result[4] := AnsiChar(b1); + Result[3] := AnsiChar(b2); + Result[2] := AnsiChar(b3); + Result[1] := AnsiChar(b4); + end; + end; +end; + +{==============================================================================} +function UTF8toUCS4(const Value: AnsiString): AnsiString; +var + n, x, ul, m: Integer; + s: AnsiString; + w1, w2: Word; +begin + Result := ''; + n := 1; + while Length(Value) >= n do + begin + x := Ord(Value[n]); + Inc(n); + if x < 128 then + Result := Result + WriteMulti(x, 0, 0, 0, 4, false) + else + begin + m := 0; + if (x and $E0) = $C0 then + m := $1F; + if (x and $F0) = $E0 then + m := $0F; + if (x and $F8) = $F0 then + m := $07; + if (x and $FC) = $F8 then + m := $03; + if (x and $FE) = $FC then + m := $01; + ul := x and m; + s := IntToBin(ul, 0); + while Length(Value) >= n do + begin + x := Ord(Value[n]); + Inc(n); + if (x and $C0) = $80 then + s := s + IntToBin(x and $3F, 6) + else + begin + Dec(n); + Break; + end; + end; + ul := BinToInt(s); + w1 := ul div 65536; + w2 := ul mod 65536; + Result := Result + WriteMulti(Lo(w2), Hi(w2), Lo(w1), Hi(w1), 4, false); + end; + end; +end; + +{==============================================================================} +function UCS4toUTF8(const Value: AnsiString): AnsiString; +var + s, l, k: AnsiString; + b1, b2, b3, b4: Byte; + n, m, x, y: Integer; + b: Byte; +begin + Result := ''; + n := 1; + while Length(Value) >= n do + begin + ReadMulti(Value, n, 4, b1, b2, b3, b4, false); + if (b2 = 0) and (b3 = 0) and (b4 = 0) and (b1 < 128) then + Result := Result + AnsiChar(b1) + else + begin + x := (b1 + 256 * b2) + (b3 + 256 * b4) * 65536; + l := IntToBin(x, 0); + y := Length(l) div 6; + s := ''; + for m := 1 to y do + begin + k := Copy(l, Length(l) - 5, 6); + l := Copy(l, 1, Length(l) - 6); + b := BinToInt(k) or $80; + s := AnsiChar(b) + s; + end; + b := BinToInt(l); + case y of + 5: + b := b or $FC; + 4: + b := b or $F8; + 3: + b := b or $F0; + 2: + b := b or $E0; + 1: + b := b or $C0; + end; + s := AnsiChar(b) + s; + Result := Result + s; + end; + end; +end; + +{==============================================================================} +function UTF7toUCS2(const Value: AnsiString; Modified: Boolean): AnsiString; +var + n, i: Integer; + c: AnsiChar; + s, t: AnsiString; + shift: AnsiChar; + table: String; +begin + Result := ''; + n := 1; + if modified then + begin + shift := '&'; + table := TableBase64mod; + end + else + begin + shift := '+'; + table := TableBase64; + end; + while Length(Value) >= n do + begin + c := Value[n]; + Inc(n); + if c <> shift then + Result := Result + WriteMulti(Ord(c), 0, 0, 0, 2, false) + else + begin + s := ''; + while Length(Value) >= n do + begin + c := Value[n]; + Inc(n); + if c = '-' then + Break; + if (c = '=') or (Pos(c, table) < 1) then + begin + Dec(n); + Break; + end; + s := s + c; + end; + if s = '' then + s := WriteMulti(Ord(shift), 0, 0, 0, 2, false) + else + begin + if modified then + t := DecodeBase64mod(s) + else + t := DecodeBase64(s); + if not odd(length(t)) then + s := t + else + begin //ill-formed sequence + t := s; + s := WriteMulti(Ord(shift), 0, 0, 0, 2, false); + for i := 1 to length(t) do + s := s + WriteMulti(Ord(t[i]), 0, 0, 0, 2, false); + end; + end; + Result := Result + s; + end; + end; +end; + +{==============================================================================} +function UCS2toUTF7(const Value: AnsiString; Modified: Boolean): AnsiString; +var + s: AnsiString; + b1, b2, b3, b4: Byte; + n, m: Integer; + shift: AnsiChar; +begin + Result := ''; + n := 1; + if modified then + shift := '&' + else + shift := '+'; + while Length(Value) >= n do + begin + ReadMulti(Value, n, 2, b1, b2, b3, b4, false); + if (b2 = 0) and (b1 < 128) then + if AnsiChar(b1) = shift then + Result := Result + shift + '-' + else + Result := Result + AnsiChar(b1) + else + begin + s := AnsiChar(b2) + AnsiChar(b1); + while Length(Value) >= n do + begin + ReadMulti(Value, n, 2, b1, b2, b3, b4, false); + if (b2 = 0) and (b1 < 128) then + begin + Dec(n, 2); + Break; + end; + s := s + AnsiChar(b2) + AnsiChar(b1); + end; + if modified then + s := EncodeBase64mod(s) + else + s := EncodeBase64(s); + m := Pos('=', s); + if m > 0 then + s := Copy(s, 1, m - 1); + Result := Result + shift + s + '-'; + end; + end; +end; + +{==============================================================================} +function CharsetConversion(const Value: AnsiString; CharFrom: TMimeChar; + CharTo: TMimeChar): AnsiString; +begin + Result := CharsetConversionEx(Value, CharFrom, CharTo, Replace_None); +end; + +{==============================================================================} +function CharsetConversionEx(const Value: AnsiString; CharFrom: TMimeChar; + CharTo: TMimeChar; const TransformTable: array of Word): AnsiString; +begin + Result := CharsetConversionTrans(Value, CharFrom, CharTo, TransformTable, True); +end; + +{==============================================================================} + +function InternalToUcs(const Value: AnsiString; Charfrom: TMimeChar): AnsiString; +var + uni: Word; + n: Integer; + b1, b2, b3, b4: Byte; + SourceTable: array[128..255] of Word; + mbf: Byte; + lef: Boolean; + s: AnsiString; +begin + if CharFrom = UTF_8 then + s := UTF8toUCS4(Value) + else + if CharFrom = UTF_7 then + s := UTF7toUCS2(Value, False) + else + if CharFrom = UTF_7mod then + s := UTF7toUCS2(Value, True) + else + s := Value; + GetArray(CharFrom, SourceTable); + mbf := 1; + if CharFrom in SetTwo then + mbf := 2; + if CharFrom in SetFour then + mbf := 4; + lef := CharFrom in SetLe; + Result := ''; + n := 1; + while Length(s) >= n do + begin + ReadMulti(s, n, mbf, b1, b2, b3, b4, lef); + //handle BOM + if (b3 = 0) and (b4 = 0) then + begin + if (b1 = $FE) and (b2 = $FF) then + begin + lef := not lef; + continue; + end; + if (b1 = $FF) and (b2 = $FE) then + continue; + end; + if mbf = 1 then + if b1 > 127 then + begin + uni := SourceTable[b1]; + b1 := Lo(uni); + b2 := Hi(uni); + end; + Result := Result + WriteMulti(b1, b2, b3, b4, 2, False); + end; +end; + +function CharsetConversionTrans(Value: AnsiString; CharFrom: TMimeChar; + CharTo: TMimeChar; const TransformTable: array of Word; Translit: Boolean): AnsiString; +var + uni: Word; + n, m: Integer; + b: Byte; + b1, b2, b3, b4: Byte; + TargetTable: array[128..255] of Word; + mbt: Byte; + let: Boolean; + ucsstring, s, t: AnsiString; + cd: iconv_t; + f: Boolean; + NotNeedTransform: Boolean; + FromID, ToID: string; +begin + NotNeedTransform := (High(TransformTable) = 0); + if (CharFrom = CharTo) and NotNeedTransform then + begin + Result := Value; + Exit; + end; + FromID := GetIDFromCP(CharFrom); + ToID := GetIDFromCP(CharTo); + cd := Iconv_t(-1); + //do two-pass conversion. Transform to UCS-2 first. + if not DisableIconv then + cd := SynaIconvOpenIgnore('UCS-2BE', FromID); + try + if cd <> iconv_t(-1) then + SynaIconv(cd, Value, ucsstring) + else + ucsstring := InternalToUcs(Value, CharFrom); + finally + SynaIconvClose(cd); + end; + //here we allways have ucstring with UCS-2 encoding + //second pass... from UCS-2 to target encoding. + if not DisableIconv then + if translit then + cd := SynaIconvOpenTranslit(ToID, 'UCS-2BE') + else + cd := SynaIconvOpenIgnore(ToID, 'UCS-2BE'); + try + if (cd <> iconv_t(-1)) and NotNeedTransform then + begin + if CharTo = UTF_7 then + ucsstring := ucsstring + #0 + '-'; + //when transformtable is not needed and Iconv know target charset, + //do it fast by one call. + SynaIconv(cd, ucsstring, Result); + if CharTo = UTF_7 then + Delete(Result, Length(Result), 1); + end + else + begin + GetArray(CharTo, TargetTable); + mbt := 1; + if CharTo in SetTwo then + mbt := 2; + if CharTo in SetFour then + mbt := 4; + let := CharTo in SetLe; + b3 := 0; + b4 := 0; + Result := ''; + for n:= 0 to (Length(ucsstring) div 2) - 1 do + begin + s := Copy(ucsstring, n * 2 + 1, 2); + b2 := Ord(s[1]); + b1 := Ord(s[2]); + uni := b2 * 256 + b1; + if not NotNeedTransform then + begin + uni := ReplaceUnicode(uni, TransformTable); + b1 := Lo(uni); + b2 := Hi(uni); + s[1] := AnsiChar(b2); + s[2] := AnsiChar(b1); + end; + if cd <> iconv_t(-1) then + begin + if CharTo = UTF_7 then + s := s + #0 + '-'; + SynaIconv(cd, s, t); + if CharTo = UTF_7 then + Delete(t, Length(t), 1); + Result := Result + t; + end + else + begin + f := True; + if mbt = 1 then + if uni > 127 then + begin + f := False; + b := 0; + for m := 128 to 255 do + if TargetTable[m] = uni then + begin + b := m; + f := True; + Break; + end; + b1 := b; + b2 := 0; + end + else + b1 := Lo(uni); + if not f then + if translit then + begin + b1 := Ord(NotFoundChar); + b2 := 0; + f := True; + end; + if f then + Result := Result + WriteMulti(b1, b2, b3, b4, mbt, let) + end; + end; + if cd = iconv_t(-1) then + begin + if CharTo = UTF_7 then + Result := UCS2toUTF7(Result, false); + if CharTo = UTF_7mod then + Result := UCS2toUTF7(Result, true); + if CharTo = UTF_8 then + Result := UCS4toUTF8(Result); + end; + end; + finally + SynaIconvClose(cd); + end; +end; + +{==============================================================================} +{$IFNDEF WIN32} + +function GetCurCP: TMimeChar; +begin + {$IFNDEF FPC} + Result := GetCPFromID(nl_langinfo(_NL_CTYPE_CODESET_NAME)); + {$ELSE} + {$IFDEF FPC_USE_LIBC} + Result := GetCPFromID(nl_langinfo(_NL_CTYPE_CODESET_NAME)); + {$ELSE} + //How to get system codepage without LIBC? + Result := UTF_8; + {$ENDIF} + {$ENDIF} +end; + +function GetCurOEMCP: TMimeChar; +begin + Result := GetCurCP; +end; + +{$ELSE} + +function CPToMimeChar(Value: Integer): TMimeChar; +begin + case Value of + 437, 850, 20127: + Result := ISO_8859_1; //I know, it is not ideal! + 737: + Result := CP737; + 775: + Result := CP775; + 852: + Result := CP852; + 855: + Result := CP855; + 857: + Result := CP857; + 858: + Result := CP858; + 860: + Result := CP860; + 861: + Result := CP861; + 862: + Result := CP862; + 863: + Result := CP863; + 864: + Result := CP864; + 865: + Result := CP865; + 866: + Result := CP866; + 869: + Result := CP869; + 874: + Result := ISO_8859_15; + 895: + Result := CP895; + 932: + Result := CP932; + 936: + Result := CP936; + 949: + Result := CP949; + 950: + Result := CP950; + 1200: + Result := UCS_2LE; + 1201: + Result := UCS_2; + 1250: + Result := CP1250; + 1251: + Result := CP1251; + 1253: + Result := CP1253; + 1254: + Result := CP1254; + 1255: + Result := CP1255; + 1256: + Result := CP1256; + 1257: + Result := CP1257; + 1258: + Result := CP1258; + 1361: + Result := CP1361; + 10000: + Result := MAC; + 10004: + Result := MACAR; + 10005: + Result := MACHEB; + 10006: + Result := MACGR; + 10007: + Result := MACCYR; + 10010: + Result := MACRO; + 10017: + Result := MACUK; + 10021: + Result := MACTH; + 10029: + Result := MACCE; + 10079: + Result := MACICE; + 10081: + Result := MACTU; + 10082: + Result := MACCRO; + 12000: + Result := UCS_4LE; + 12001: + Result := UCS_4; + 20866: + Result := KOI8_R; + 20932: + Result := JIS_X0208; + 20936: + Result := GB2312; + 21866: + Result := KOI8_U; + 28591: + Result := ISO_8859_1; + 28592: + Result := ISO_8859_2; + 28593: + Result := ISO_8859_3; + 28594: + Result := ISO_8859_4; + 28595: + Result := ISO_8859_5; + 28596, 708: + Result := ISO_8859_6; + 28597: + Result := ISO_8859_7; + 28598, 38598: + Result := ISO_8859_8; + 28599: + Result := ISO_8859_9; + 28605: + Result := ISO_8859_15; + 50220: + Result := ISO_2022_JP; //? ISO 2022 Japanese with no halfwidth Katakana + 50221: + Result := ISO_2022_JP1;//? Japanese with halfwidth Katakana + 50222: + Result := ISO_2022_JP2;//? Japanese JIS X 0201-1989 + 50225: + Result := ISO_2022_KR; + 50227: + Result := ISO_2022_CN;//? ISO 2022 Simplified Chinese + 50229: + Result := ISO_2022_CNE;//? ISO 2022 Traditional Chinese + 51932: + Result := EUC_JP; + 51936: + Result := GB2312; + 51949: + Result := EUC_KR; + 52936: + Result := HZ; + 54936: + Result := GB18030; + 65000: + Result := UTF_7; + 65001: + Result := UTF_8; + 0: + Result := UCS_2LE; + else + Result := CP1252; + end; +end; + +function GetCurCP: TMimeChar; +begin + Result := CPToMimeChar(GetACP); +end; + +function GetCurOEMCP: TMimeChar; +begin + Result := CPToMimeChar(GetOEMCP); +end; +{$ENDIF} + +{==============================================================================} +function NeedCharsetConversion(const Value: AnsiString): Boolean; +var + n: Integer; +begin + Result := False; + for n := 1 to Length(Value) do + if (Ord(Value[n]) > 127) or (Ord(Value[n]) = 0) then + begin + Result := True; + Break; + end; +end; + +{==============================================================================} +function IdealCharsetCoding(const Value: AnsiString; CharFrom: TMimeChar; + CharTo: TMimeSetChar): TMimeChar; +var + n: Integer; + max: Integer; + s, t, u: AnsiString; + CharSet: TMimeChar; +begin + Result := ISO_8859_1; + s := Copy(Value, 1, 1024); //max first 1KB for next procedure + max := 0; + for n := Ord(Low(TMimeChar)) to Ord(High(TMimeChar)) do + begin + CharSet := TMimeChar(n); + if CharSet in CharTo then + begin + t := CharsetConversionTrans(s, CharFrom, CharSet, Replace_None, False); + u := CharsetConversionTrans(t, CharSet, CharFrom, Replace_None, False); + if s = u then + begin + Result := CharSet; + Exit; + end; + if Length(u) > max then + begin + Result := CharSet; + max := Length(u); + end; + end; + end; +end; + +{==============================================================================} +function GetBOM(Value: TMimeChar): AnsiString; +begin + Result := ''; + case Value of + UCS_2: + Result := #$fe + #$ff; + UCS_4: + Result := #$00 + #$00 + #$fe + #$ff; + UCS_2LE: + Result := #$ff + #$fe; + UCS_4LE: + Result := #$ff + #$fe + #$00 + #$00; + UTF_8: + Result := #$ef + #$bb + #$bf; + end; +end; + +{==============================================================================} +function GetCPFromID(Value: AnsiString): TMimeChar; +begin + Value := UpperCase(Value); + if (Pos('KAMENICKY', Value) > 0) or (Pos('895', Value) > 0) then + Result := CP895 + else + if Pos('MUTF-7', Value) > 0 then + Result := UTF_7mod + else + Result := GetCPFromIconvID(Value); +end; + +{==============================================================================} +function GetIDFromCP(Value: TMimeChar): AnsiString; +begin + case Value of + CP895: + Result := 'CP-895'; + UTF_7mod: + Result := 'mUTF-7'; + else + Result := GetIconvIDFromCP(Value); + end; +end; + +{==============================================================================} +function StringToWide(const Value: AnsiString): WideString; +var + n: integer; + x, y: integer; +begin + SetLength(Result, Length(Value) div 2); + for n := 1 to Length(Value) div 2 do + begin + x := Ord(Value[((n-1) * 2) + 1]); + y := Ord(Value[((n-1) * 2) + 2]); + Result[n] := WideChar(x * 256 + y); + end; +end; + +{==============================================================================} +function WideToString(const Value: WideString): AnsiString; +var + n: integer; + x: integer; +begin + SetLength(Result, Length(Value) * 2); + for n := 1 to Length(Value) do + begin + x := Ord(Value[n]); + Result[((n-1) * 2) + 1] := AnsiChar(x div 256); + Result[((n-1) * 2) + 2] := AnsiChar(x mod 256); + end; +end; + +{==============================================================================} +initialization +begin + IconvArr[0].Charset := ISO_8859_1; + IconvArr[0].Charname := 'ISO-8859-1 CP819 IBM819 ISO-IR-100 ISO8859-1 ISO_8859-1 ISO_8859-1:1987 L1 LATIN1 CSISOLATIN1'; + IconvArr[1].Charset := UTF_8; + IconvArr[1].Charname := 'UTF-8'; + IconvArr[2].Charset := UCS_2; + IconvArr[2].Charname := 'ISO-10646-UCS-2 UCS-2 CSUNICODE'; + IconvArr[3].Charset := UCS_2; + IconvArr[3].Charname := 'UCS-2BE UNICODE-1-1 UNICODEBIG CSUNICODE11'; + IconvArr[4].Charset := UCS_2LE; + IconvArr[4].Charname := 'UCS-2LE UNICODELITTLE'; + IconvArr[5].Charset := UCS_4; + IconvArr[5].Charname := 'ISO-10646-UCS-4 UCS-4 CSUCS4'; + IconvArr[6].Charset := UCS_4; + IconvArr[6].Charname := 'UCS-4BE'; + IconvArr[7].Charset := UCS_2LE; + IconvArr[7].Charname := 'UCS-4LE'; + IconvArr[8].Charset := UTF_16; + IconvArr[8].Charname := 'UTF-16'; + IconvArr[9].Charset := UTF_16; + IconvArr[9].Charname := 'UTF-16BE'; + IconvArr[10].Charset := UTF_16LE; + IconvArr[10].Charname := 'UTF-16LE'; + IconvArr[11].Charset := UTF_32; + IconvArr[11].Charname := 'UTF-32'; + IconvArr[12].Charset := UTF_32; + IconvArr[12].Charname := 'UTF-32BE'; + IconvArr[13].Charset := UTF_32; + IconvArr[13].Charname := 'UTF-32LE'; + IconvArr[14].Charset := UTF_7; + IconvArr[14].Charname := 'UNICODE-1-1-UTF-7 UTF-7 CSUNICODE11UTF7'; + IconvArr[15].Charset := C99; + IconvArr[15].Charname := 'C99'; + IconvArr[16].Charset := JAVA; + IconvArr[16].Charname := 'JAVA'; + IconvArr[17].Charset := ISO_8859_1; + IconvArr[17].Charname := 'US-ASCII ANSI_X3.4-1968 ANSI_X3.4-1986 ASCII CP367 IBM367 ISO-IR-6 ISO646-US ISO_646.IRV:1991 US CSASCII'; + IconvArr[18].Charset := ISO_8859_2; + IconvArr[18].Charname := 'ISO-8859-2 ISO-IR-101 ISO8859-2 ISO_8859-2 ISO_8859-2:1987 L2 LATIN2 CSISOLATIN2'; + IconvArr[19].Charset := ISO_8859_3; + IconvArr[19].Charname := 'ISO-8859-3 ISO-IR-109 ISO8859-3 ISO_8859-3 ISO_8859-3:1988 L3 LATIN3 CSISOLATIN3'; + IconvArr[20].Charset := ISO_8859_4; + IconvArr[20].Charname := 'ISO-8859-4 ISO-IR-110 ISO8859-4 ISO_8859-4 ISO_8859-4:1988 L4 LATIN4 CSISOLATIN4'; + IconvArr[21].Charset := ISO_8859_5; + IconvArr[21].Charname := 'ISO-8859-5 CYRILLIC ISO-IR-144 ISO8859-5 ISO_8859-5 ISO_8859-5:1988 CSISOLATINCYRILLIC'; + IconvArr[22].Charset := ISO_8859_6; + IconvArr[22].Charname := 'ISO-8859-6 ARABIC ASMO-708 ECMA-114 ISO-IR-127 ISO8859-6 ISO_8859-6 ISO_8859-6:1987 CSISOLATINARABIC'; + IconvArr[23].Charset := ISO_8859_7; + IconvArr[23].Charname := 'ISO-8859-7 ECMA-118 ELOT_928 GREEK GREEK8 ISO-IR-126 ISO8859-7 ISO_8859-7 ISO_8859-7:1987 CSISOLATINGREEK'; + IconvArr[24].Charset := ISO_8859_8; + IconvArr[24].Charname := 'ISO-8859-8 HEBREW ISO_8859-8 ISO-IR-138 ISO8859-8 ISO_8859-8:1988 CSISOLATINHEBREW ISO-8859-8-I'; + IconvArr[25].Charset := ISO_8859_9; + IconvArr[25].Charname := 'ISO-8859-9 ISO-IR-148 ISO8859-9 ISO_8859-9 ISO_8859-9:1989 L5 LATIN5 CSISOLATIN5'; + IconvArr[26].Charset := ISO_8859_10; + IconvArr[26].Charname := 'ISO-8859-10 ISO-IR-157 ISO8859-10 ISO_8859-10 ISO_8859-10:1992 L6 LATIN6 CSISOLATIN6'; + IconvArr[27].Charset := ISO_8859_13; + IconvArr[27].Charname := 'ISO-8859-13 ISO-IR-179 ISO8859-13 ISO_8859-13 L7 LATIN7'; + IconvArr[28].Charset := ISO_8859_14; + IconvArr[28].Charname := 'ISO-8859-14 ISO-CELTIC ISO-IR-199 ISO8859-14 ISO_8859-14 ISO_8859-14:1998 L8 LATIN8'; + IconvArr[29].Charset := ISO_8859_15; + IconvArr[29].Charname := 'ISO-8859-15 ISO-IR-203 ISO8859-15 ISO_8859-15 ISO_8859-15:1998'; + IconvArr[30].Charset := ISO_8859_16; + IconvArr[30].Charname := 'ISO-8859-16 ISO-IR-226 ISO8859-16 ISO_8859-16 ISO_8859-16:2000'; + IconvArr[31].Charset := KOI8_R; + IconvArr[31].Charname := 'KOI8-R CSKOI8R'; + IconvArr[32].Charset := KOI8_U; + IconvArr[32].Charname := 'KOI8-U'; + IconvArr[33].Charset := KOI8_RU; + IconvArr[33].Charname := 'KOI8-RU'; + IconvArr[34].Charset := CP1250; + IconvArr[34].Charname := 'WINDOWS-1250 CP1250 MS-EE'; + IconvArr[35].Charset := CP1251; + IconvArr[35].Charname := 'WINDOWS-1251 CP1251 MS-CYRL'; + IconvArr[36].Charset := CP1252; + IconvArr[36].Charname := 'WINDOWS-1252 CP1252 MS-ANSI'; + IconvArr[37].Charset := CP1253; + IconvArr[37].Charname := 'WINDOWS-1253 CP1253 MS-GREEK'; + IconvArr[38].Charset := CP1254; + IconvArr[38].Charname := 'WINDOWS-1254 CP1254 MS-TURK'; + IconvArr[39].Charset := CP1255; + IconvArr[39].Charname := 'WINDOWS-1255 CP1255 MS-HEBR'; + IconvArr[40].Charset := CP1256; + IconvArr[40].Charname := 'WINDOWS-1256 CP1256 MS-ARAB'; + IconvArr[41].Charset := CP1257; + IconvArr[41].Charname := 'WINDOWS-1257 CP1257 WINBALTRIM'; + IconvArr[42].Charset := CP1258; + IconvArr[42].Charname := 'WINDOWS-1258 CP1258'; + IconvArr[43].Charset := ISO_8859_1; + IconvArr[43].Charname := '850 CP850 IBM850 CSPC850MULTILINGUAL'; + IconvArr[44].Charset := CP862; + IconvArr[44].Charname := '862 CP862 IBM862 CSPC862LATINHEBREW'; + IconvArr[45].Charset := CP866; + IconvArr[45].Charname := '866 CP866 IBM866 CSIBM866'; + IconvArr[46].Charset := MAC; + IconvArr[46].Charname := 'MAC MACINTOSH MACROMAN CSMACINTOSH'; + IconvArr[47].Charset := MACCE; + IconvArr[47].Charname := 'MACCENTRALEUROPE'; + IconvArr[48].Charset := MACICE; + IconvArr[48].Charname := 'MACICELAND'; + IconvArr[49].Charset := MACCRO; + IconvArr[49].Charname := 'MACCROATIAN'; + IconvArr[50].Charset := MACRO; + IconvArr[50].Charname := 'MACROMANIA'; + IconvArr[51].Charset := MACCYR; + IconvArr[51].Charname := 'MACCYRILLIC'; + IconvArr[52].Charset := MACUK; + IconvArr[52].Charname := 'MACUKRAINE'; + IconvArr[53].Charset := MACGR; + IconvArr[53].Charname := 'MACGREEK'; + IconvArr[54].Charset := MACTU; + IconvArr[54].Charname := 'MACTURKISH'; + IconvArr[55].Charset := MACHEB; + IconvArr[55].Charname := 'MACHEBREW'; + IconvArr[56].Charset := MACAR; + IconvArr[56].Charname := 'MACARABIC'; + IconvArr[57].Charset := MACTH; + IconvArr[57].Charname := 'MACTHAI'; + IconvArr[58].Charset := ROMAN8; + IconvArr[58].Charname := 'HP-ROMAN8 R8 ROMAN8 CSHPROMAN8'; + IconvArr[59].Charset := NEXTSTEP; + IconvArr[59].Charname := 'NEXTSTEP'; + IconvArr[60].Charset := ARMASCII; + IconvArr[60].Charname := 'ARMSCII-8'; + IconvArr[61].Charset := GEORGIAN_AC; + IconvArr[61].Charname := 'GEORGIAN-ACADEMY'; + IconvArr[62].Charset := GEORGIAN_PS; + IconvArr[62].Charname := 'GEORGIAN-PS'; + IconvArr[63].Charset := KOI8_T; + IconvArr[63].Charname := 'KOI8-T'; + IconvArr[64].Charset := MULELAO; + IconvArr[64].Charname := 'MULELAO-1'; + IconvArr[65].Charset := CP1133; + IconvArr[65].Charname := 'CP1133 IBM-CP1133'; + IconvArr[66].Charset := TIS620; + IconvArr[66].Charname := 'TIS-620 ISO-IR-166 TIS620 TIS620-0 TIS620.2529-1 TIS620.2533-0 TIS620.2533-1'; + IconvArr[67].Charset := CP874; + IconvArr[67].Charname := 'CP874 WINDOWS-874'; + IconvArr[68].Charset := VISCII; + IconvArr[68].Charname := 'VISCII VISCII1.1-1 CSVISCII'; + IconvArr[69].Charset := TCVN; + IconvArr[69].Charname := 'TCVN TCVN-5712 TCVN5712-1 TCVN5712-1:1993'; + IconvArr[70].Charset := ISO_IR_14; + IconvArr[70].Charname := 'ISO-IR-14 ISO646-JP JIS_C6220-1969-RO JP CSISO14JISC6220RO'; + IconvArr[71].Charset := JIS_X0201; + IconvArr[71].Charname := 'JISX0201-1976 JIS_X0201 X0201 CSHALFWIDTHKATAKANA'; + IconvArr[72].Charset := JIS_X0208; + IconvArr[72].Charname := 'ISO-IR-87 JIS0208 JIS_C6226-1983 JIS_X0208 JIS_X0208-1983 JIS_X0208-1990 X0208 CSISO87JISX0208'; + IconvArr[73].Charset := JIS_X0212; + IconvArr[73].Charname := 'ISO-IR-159 JIS_X0212 JIS_X0212-1990 JIS_X0212.1990-0 X0212 CSISO159JISX02121990'; + IconvArr[74].Charset := GB1988_80; + IconvArr[74].Charname := 'CN GB_1988-80 ISO-IR-57 ISO646-CN CSISO57GB1988'; + IconvArr[75].Charset := GB2312_80; + IconvArr[75].Charname := 'CHINESE GB_2312-80 ISO-IR-58 CSISO58GB231280'; + IconvArr[76].Charset := ISO_IR_165; + IconvArr[76].Charname := 'CN-GB-ISOIR165 ISO-IR-165'; + IconvArr[77].Charset := ISO_IR_149; + IconvArr[77].Charname := 'ISO-IR-149 KOREAN KSC_5601 KS_C_5601-1987 KS_C_5601-1989 CSKSC56011987'; + IconvArr[78].Charset := EUC_JP; + IconvArr[78].Charname := 'EUC-JP EUCJP EXTENDED_UNIX_CODE_PACKED_FORMAT_FOR_JAPANESE CSEUCPKDFMTJAPANESE'; + IconvArr[79].Charset := SHIFT_JIS; + IconvArr[79].Charname := 'SHIFT-JIS MS_KANJI SHIFT_JIS SJIS CSSHIFTJIS'; + IconvArr[80].Charset := CP932; + IconvArr[80].Charname := 'CP932'; + IconvArr[81].Charset := ISO_2022_JP; + IconvArr[81].Charname := 'ISO-2022-JP CSISO2022JP'; + IconvArr[82].Charset := ISO_2022_JP1; + IconvArr[82].Charname := 'ISO-2022-JP-1'; + IconvArr[83].Charset := ISO_2022_JP2; + IconvArr[83].Charname := 'ISO-2022-JP-2 CSISO2022JP2'; + IconvArr[84].Charset := GB2312; + IconvArr[84].Charname := 'CN-GB EUC-CN EUCCN GB2312 CSGB2312'; + IconvArr[85].Charset := CP936; + IconvArr[85].Charname := 'CP936 GBK'; + IconvArr[86].Charset := GB18030; + IconvArr[86].Charname := 'GB18030'; + IconvArr[87].Charset := ISO_2022_CN; + IconvArr[87].Charname := 'ISO-2022-CN CSISO2022CN'; + IconvArr[88].Charset := ISO_2022_CNE; + IconvArr[88].Charname := 'ISO-2022-CN-EXT'; + IconvArr[89].Charset := HZ; + IconvArr[89].Charname := 'HZ HZ-GB-2312'; + IconvArr[90].Charset := EUC_TW; + IconvArr[90].Charname := 'EUC-TW EUCTW CSEUCTW'; + IconvArr[91].Charset := BIG5; + IconvArr[91].Charname := 'BIG5 BIG-5 BIG-FIVE BIGFIVE CN-BIG5 CSBIG5'; + IconvArr[92].Charset := CP950; + IconvArr[92].Charname := 'CP950'; + IconvArr[93].Charset := BIG5_HKSCS; + IconvArr[93].Charname := 'BIG5-HKSCS BIG5HKSCS'; + IconvArr[94].Charset := EUC_KR; + IconvArr[94].Charname := 'EUC-KR EUCKR CSEUCKR'; + IconvArr[95].Charset := CP949; + IconvArr[95].Charname := 'CP949 UHC'; + IconvArr[96].Charset := CP1361; + IconvArr[96].Charname := 'CP1361 JOHAB'; + IconvArr[97].Charset := ISO_2022_KR; + IconvArr[97].Charname := 'ISO-2022-KR CSISO2022KR'; + IconvArr[98].Charset := ISO_8859_1; + IconvArr[98].Charname := '437 CP437 IBM437 CSPC8CODEPAGE437'; + IconvArr[99].Charset := CP737; + IconvArr[99].Charname := 'CP737'; + IconvArr[100].Charset := CP775; + IconvArr[100].Charname := 'CP775 IBM775 CSPC775BALTIC'; + IconvArr[101].Charset := CP852; + IconvArr[101].Charname := '852 CP852 IBM852 CSPCP852'; + IconvArr[102].Charset := CP853; + IconvArr[102].Charname := 'CP853'; + IconvArr[103].Charset := CP855; + IconvArr[103].Charname := '855 CP855 IBM855 CSIBM855'; + IconvArr[104].Charset := CP857; + IconvArr[104].Charname := '857 CP857 IBM857 CSIBM857'; + IconvArr[105].Charset := CP858; + IconvArr[105].Charname := 'CP858'; + IconvArr[106].Charset := CP860; + IconvArr[106].Charname := '860 CP860 IBM860 CSIBM860'; + IconvArr[107].Charset := CP861; + IconvArr[107].Charname := '861 CP-IS CP861 IBM861 CSIBM861'; + IconvArr[108].Charset := CP863; + IconvArr[108].Charname := '863 CP863 IBM863 CSIBM863'; + IconvArr[109].Charset := CP864; + IconvArr[109].Charname := 'CP864 IBM864 CSIBM864'; + IconvArr[110].Charset := CP865; + IconvArr[110].Charname := '865 CP865 IBM865 CSIBM865'; + IconvArr[111].Charset := CP869; + IconvArr[111].Charname := '869 CP-GR CP869 IBM869 CSIBM869'; + IconvArr[112].Charset := CP1125; + IconvArr[112].Charname := 'CP1125'; +end; + +end. diff --git a/synapse/synacode.pas b/synapse/synacode.pas new file mode 100644 index 0000000..757a838 --- /dev/null +++ b/synapse/synacode.pas @@ -0,0 +1,1461 @@ +{==============================================================================| +| Project : Ararat Synapse | 002.002.001 | +|==============================================================================| +| Content: Coding and decoding support | +|==============================================================================| +| 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. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +{:@abstract(Various encoding and decoding support)} +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$Q-} +{$R-} +{$H+} +{$TYPEDADDRESS OFF} + +{$IFDEF UNICODE} + {$WARN IMPLICIT_STRING_CAST OFF} + {$WARN IMPLICIT_STRING_CAST_LOSS OFF} + {$WARN SUSPICIOUS_TYPECAST OFF} +{$ENDIF} + +unit synacode; + +interface + +uses + SysUtils; + +type + TSpecials = set of AnsiChar; + +const + + SpecialChar: TSpecials = + ['=', '(', ')', '[', ']', '<', '>', ':', ';', ',', '@', '/', '?', '\', + '"', '_']; + NonAsciiChar: TSpecials = + [#0..#31, #127..#255]; + URLFullSpecialChar: TSpecials = + [';', '/', '?', ':', '@', '=', '&', '#', '+']; + URLSpecialChar: TSpecials = + [#$00..#$20, '_', '<', '>', '"', '%', '{', '}', '|', '\', '^', '~', '[', ']', + '`', #$7F..#$FF]; + TableBase64 = + 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/='; + TableBase64mod = + 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+,='; + TableUU = + '`!"#$%&''()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_'; + TableXX = + '+-0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz'; + ReTablebase64 = + #$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$3E +#$40 + +#$40 +#$40 +#$3F +#$34 +#$35 +#$36 +#$37 +#$38 +#$39 +#$3A +#$3B +#$3C + +#$3D +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$00 +#$01 +#$02 +#$03 + +#$04 +#$05 +#$06 +#$07 +#$08 +#$09 +#$0A +#$0B +#$0C +#$0D +#$0E +#$0F + +#$10 +#$11 +#$12 +#$13 +#$14 +#$15 +#$16 +#$17 +#$18 +#$19 +#$40 +#$40 + +#$40 +#$40 +#$40 +#$40 +#$1A +#$1B +#$1C +#$1D +#$1E +#$1F +#$20 +#$21 + +#$22 +#$23 +#$24 +#$25 +#$26 +#$27 +#$28 +#$29 +#$2A +#$2B +#$2C +#$2D + +#$2E +#$2F +#$30 +#$31 +#$32 +#$33 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40; + ReTableUU = + #$01 +#$02 +#$03 +#$04 +#$05 +#$06 +#$07 +#$08 +#$09 +#$0A +#$0B +#$0C + +#$0D +#$0E +#$0F +#$10 +#$11 +#$12 +#$13 +#$14 +#$15 +#$16 +#$17 +#$18 + +#$19 +#$1A +#$1B +#$1C +#$1D +#$1E +#$1F +#$20 +#$21 +#$22 +#$23 +#$24 + +#$25 +#$26 +#$27 +#$28 +#$29 +#$2A +#$2B +#$2C +#$2D +#$2E +#$2F +#$30 + +#$31 +#$32 +#$33 +#$34 +#$35 +#$36 +#$37 +#$38 +#$39 +#$3A +#$3B +#$3C + +#$3D +#$3E +#$3F +#$00 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 + +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 + +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40; + ReTableXX = + #$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$00 +#$40 + +#$01 +#$40 +#$40 +#$02 +#$03 +#$04 +#$05 +#$06 +#$07 +#$08 +#$09 +#$0A + +#$0B +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$0C +#$0D +#$0E +#$0F + +#$10 +#$11 +#$12 +#$13 +#$14 +#$15 +#$16 +#$17 +#$18 +#$19 +#$1A +#$1B + +#$1C +#$1D +#$1E +#$1F +#$20 +#$21 +#$22 +#$23 +#$24 +#$25 +#$40 +#$40 + +#$40 +#$40 +#$40 +#$40 +#$26 +#$27 +#$28 +#$29 +#$2A +#$2B +#$2C +#$2D + +#$2E +#$2F +#$30 +#$31 +#$32 +#$33 +#$34 +#$35 +#$36 +#$37 +#$38 +#$39 + +#$3A +#$3B +#$3C +#$3D +#$3E +#$3F +#$40 +#$40 +#$40 +#$40 +#$40 +#$40; + +{:Decodes triplet encoding with a given character delimiter. It is used for + decoding quoted-printable or URL encoding.} +function DecodeTriplet(const Value: AnsiString; Delimiter: AnsiChar): AnsiString; + +{:Decodes a string from quoted printable form. (also decodes triplet sequences + like '=7F')} +function DecodeQuotedPrintable(const Value: AnsiString): AnsiString; + +{:Decodes a string of URL encoding. (also decodes triplet sequences like '%7F')} +function DecodeURL(const Value: AnsiString): AnsiString; + +{:Performs triplet encoding with a given character delimiter. Used for encoding + quoted-printable or URL encoding.} +function EncodeTriplet(const Value: AnsiString; Delimiter: AnsiChar; + Specials: TSpecials): AnsiString; + +{:Encodes a string to triplet quoted printable form. All @link(NonAsciiChar) + are encoded.} +function EncodeQuotedPrintable(const Value: AnsiString): AnsiString; + +{:Encodes a string to triplet quoted printable form. All @link(NonAsciiChar) and + @link(SpecialChar) are encoded.} +function EncodeSafeQuotedPrintable(const Value: AnsiString): AnsiString; + +{:Encodes a string to URL format. Used for encoding data from a form field in + HTTP, etc. (Encodes all critical characters including characters used as URL + delimiters ('/',':', etc.)} +function EncodeURLElement(const Value: AnsiString): AnsiString; + +{:Encodes a string to URL format. Used to encode critical characters in all + URLs.} +function EncodeURL(const Value: AnsiString): AnsiString; + +{:Decode 4to3 encoding with given table. If some element is not found in table, + first item from table is used. This is good for buggy coded items by Microsoft + Outlook. This software sometimes using wrong table for UUcode, where is used + ' ' instead '`'.} +function Decode4to3(const Value, Table: AnsiString): AnsiString; + +{:Decode 4to3 encoding with given REVERSE table. Using this function with +reverse table is much faster then @link(Decode4to3). This function is used +internally for Base64, UU or XX decoding.} +function Decode4to3Ex(const Value, Table: AnsiString): AnsiString; + +{:Encode by system 3to4 (used by Base64, UU coding, etc) by given table.} +function Encode3to4(const Value, Table: AnsiString): AnsiString; + +{:Decode string from base64 format.} +function DecodeBase64(const Value: AnsiString): AnsiString; + +{:Encodes a string to base64 format.} +function EncodeBase64(const Value: AnsiString): AnsiString; + +{:Decode string from modified base64 format. (used in IMAP, for example.)} +function DecodeBase64mod(const Value: AnsiString): AnsiString; + +{:Encodes a string to modified base64 format. (used in IMAP, for example.)} +function EncodeBase64mod(const Value: AnsiString): AnsiString; + +{:Decodes a string from UUcode format.} +function DecodeUU(const Value: AnsiString): AnsiString; + +{:encode UUcode. it encode only datas, you must also add header and footer for + proper encode.} +function EncodeUU(const Value: AnsiString): AnsiString; + +{:Decodes a string from XXcode format.} +function DecodeXX(const Value: AnsiString): AnsiString; + +{:decode line with Yenc code. This code is sometimes used in newsgroups.} +function DecodeYEnc(const Value: AnsiString): AnsiString; + +{:Returns a new CRC32 value after adding a new byte of data.} +function UpdateCrc32(Value: Byte; Crc32: Integer): Integer; + +{:return CRC32 from a value string.} +function Crc32(const Value: AnsiString): Integer; + +{:Returns a new CRC16 value after adding a new byte of data.} +function UpdateCrc16(Value: Byte; Crc16: Word): Word; + +{:return CRC16 from a value string.} +function Crc16(const Value: AnsiString): Word; + +{:Returns a binary string with a RSA-MD5 hashing of "Value" string.} +function MD5(const Value: AnsiString): AnsiString; + +{:Returns a binary string with HMAC-MD5 hash.} +function HMAC_MD5(Text, Key: AnsiString): AnsiString; + +{:Returns a binary string with a RSA-MD5 hashing of string what is constructed + by repeating "value" until length is "Len".} +function MD5LongHash(const Value: AnsiString; Len: integer): AnsiString; + +{:Returns a binary string with a SHA-1 hashing of "Value" string.} +function SHA1(const Value: AnsiString): AnsiString; + +{:Returns a binary string with HMAC-SHA1 hash.} +function HMAC_SHA1(Text, Key: AnsiString): AnsiString; + +{:Returns a binary string with a SHA-1 hashing of string what is constructed + by repeating "value" until length is "Len".} +function SHA1LongHash(const Value: AnsiString; Len: integer): AnsiString; + +{:Returns a binary string with a RSA-MD4 hashing of "Value" string.} +function MD4(const Value: AnsiString): AnsiString; + +implementation + +const + + Crc32Tab: array[0..255] of Integer = ( + Integer($00000000), Integer($77073096), Integer($EE0E612C), Integer($990951BA), + Integer($076DC419), Integer($706AF48F), Integer($E963A535), Integer($9E6495A3), + Integer($0EDB8832), Integer($79DCB8A4), Integer($E0D5E91E), Integer($97D2D988), + Integer($09B64C2B), Integer($7EB17CBD), Integer($E7B82D07), Integer($90BF1D91), + Integer($1DB71064), Integer($6AB020F2), Integer($F3B97148), Integer($84BE41DE), + Integer($1ADAD47D), Integer($6DDDE4EB), Integer($F4D4B551), Integer($83D385C7), + Integer($136C9856), Integer($646BA8C0), Integer($FD62F97A), Integer($8A65C9EC), + Integer($14015C4F), Integer($63066CD9), Integer($FA0F3D63), Integer($8D080DF5), + Integer($3B6E20C8), Integer($4C69105E), Integer($D56041E4), Integer($A2677172), + Integer($3C03E4D1), Integer($4B04D447), Integer($D20D85FD), Integer($A50AB56B), + Integer($35B5A8FA), Integer($42B2986C), Integer($DBBBC9D6), Integer($ACBCF940), + Integer($32D86CE3), Integer($45DF5C75), Integer($DCD60DCF), Integer($ABD13D59), + Integer($26D930AC), Integer($51DE003A), Integer($C8D75180), Integer($BFD06116), + Integer($21B4F4B5), Integer($56B3C423), Integer($CFBA9599), Integer($B8BDA50F), + Integer($2802B89E), Integer($5F058808), Integer($C60CD9B2), Integer($B10BE924), + Integer($2F6F7C87), Integer($58684C11), Integer($C1611DAB), Integer($B6662D3D), + Integer($76DC4190), Integer($01DB7106), Integer($98D220BC), Integer($EFD5102A), + Integer($71B18589), Integer($06B6B51F), Integer($9FBFE4A5), Integer($E8B8D433), + Integer($7807C9A2), Integer($0F00F934), Integer($9609A88E), Integer($E10E9818), + Integer($7F6A0DBB), Integer($086D3D2D), Integer($91646C97), Integer($E6635C01), + Integer($6B6B51F4), Integer($1C6C6162), Integer($856530D8), Integer($F262004E), + Integer($6C0695ED), Integer($1B01A57B), Integer($8208F4C1), Integer($F50FC457), + Integer($65B0D9C6), Integer($12B7E950), Integer($8BBEB8EA), Integer($FCB9887C), + Integer($62DD1DDF), Integer($15DA2D49), Integer($8CD37CF3), Integer($FBD44C65), + Integer($4DB26158), Integer($3AB551CE), Integer($A3BC0074), Integer($D4BB30E2), + Integer($4ADFA541), Integer($3DD895D7), Integer($A4D1C46D), Integer($D3D6F4FB), + Integer($4369E96A), Integer($346ED9FC), Integer($AD678846), Integer($DA60B8D0), + Integer($44042D73), Integer($33031DE5), Integer($AA0A4C5F), Integer($DD0D7CC9), + Integer($5005713C), Integer($270241AA), Integer($BE0B1010), Integer($C90C2086), + Integer($5768B525), Integer($206F85B3), Integer($B966D409), Integer($CE61E49F), + Integer($5EDEF90E), Integer($29D9C998), Integer($B0D09822), Integer($C7D7A8B4), + Integer($59B33D17), Integer($2EB40D81), Integer($B7BD5C3B), Integer($C0BA6CAD), + Integer($EDB88320), Integer($9ABFB3B6), Integer($03B6E20C), Integer($74B1D29A), + Integer($EAD54739), Integer($9DD277AF), Integer($04DB2615), Integer($73DC1683), + Integer($E3630B12), Integer($94643B84), Integer($0D6D6A3E), Integer($7A6A5AA8), + Integer($E40ECF0B), Integer($9309FF9D), Integer($0A00AE27), Integer($7D079EB1), + Integer($F00F9344), Integer($8708A3D2), Integer($1E01F268), Integer($6906C2FE), + Integer($F762575D), Integer($806567CB), Integer($196C3671), Integer($6E6B06E7), + Integer($FED41B76), Integer($89D32BE0), Integer($10DA7A5A), Integer($67DD4ACC), + Integer($F9B9DF6F), Integer($8EBEEFF9), Integer($17B7BE43), Integer($60B08ED5), + Integer($D6D6A3E8), Integer($A1D1937E), Integer($38D8C2C4), Integer($4FDFF252), + Integer($D1BB67F1), Integer($A6BC5767), Integer($3FB506DD), Integer($48B2364B), + Integer($D80D2BDA), Integer($AF0A1B4C), Integer($36034AF6), Integer($41047A60), + Integer($DF60EFC3), Integer($A867DF55), Integer($316E8EEF), Integer($4669BE79), + Integer($CB61B38C), Integer($BC66831A), Integer($256FD2A0), Integer($5268E236), + Integer($CC0C7795), Integer($BB0B4703), Integer($220216B9), Integer($5505262F), + Integer($C5BA3BBE), Integer($B2BD0B28), Integer($2BB45A92), Integer($5CB36A04), + Integer($C2D7FFA7), Integer($B5D0CF31), Integer($2CD99E8B), Integer($5BDEAE1D), + Integer($9B64C2B0), Integer($EC63F226), Integer($756AA39C), Integer($026D930A), + Integer($9C0906A9), Integer($EB0E363F), Integer($72076785), Integer($05005713), + Integer($95BF4A82), Integer($E2B87A14), Integer($7BB12BAE), Integer($0CB61B38), + Integer($92D28E9B), Integer($E5D5BE0D), Integer($7CDCEFB7), Integer($0BDBDF21), + Integer($86D3D2D4), Integer($F1D4E242), Integer($68DDB3F8), Integer($1FDA836E), + Integer($81BE16CD), Integer($F6B9265B), Integer($6FB077E1), Integer($18B74777), + Integer($88085AE6), Integer($FF0F6A70), Integer($66063BCA), Integer($11010B5C), + Integer($8F659EFF), Integer($F862AE69), Integer($616BFFD3), Integer($166CCF45), + Integer($A00AE278), Integer($D70DD2EE), Integer($4E048354), Integer($3903B3C2), + Integer($A7672661), Integer($D06016F7), Integer($4969474D), Integer($3E6E77DB), + Integer($AED16A4A), Integer($D9D65ADC), Integer($40DF0B66), Integer($37D83BF0), + Integer($A9BCAE53), Integer($DEBB9EC5), Integer($47B2CF7F), Integer($30B5FFE9), + Integer($BDBDF21C), Integer($CABAC28A), Integer($53B39330), Integer($24B4A3A6), + Integer($BAD03605), Integer($CDD70693), Integer($54DE5729), Integer($23D967BF), + Integer($B3667A2E), Integer($C4614AB8), Integer($5D681B02), Integer($2A6F2B94), + Integer($B40BBE37), Integer($C30C8EA1), Integer($5A05DF1B), Integer($2D02EF8D) + ); + + Crc16Tab: array[0..255] of Word = ( + $0000, $1189, $2312, $329B, $4624, $57AD, $6536, $74BF, + $8C48, $9DC1, $AF5A, $BED3, $CA6C, $DBE5, $E97E, $F8F7, + $1081, $0108, $3393, $221A, $56A5, $472C, $75B7, $643E, + $9CC9, $8D40, $BFDB, $AE52, $DAED, $CB64, $F9FF, $E876, + $2102, $308B, $0210, $1399, $6726, $76AF, $4434, $55BD, + $AD4A, $BCC3, $8E58, $9FD1, $EB6E, $FAE7, $C87C, $D9F5, + $3183, $200A, $1291, $0318, $77A7, $662E, $54B5, $453C, + $BDCB, $AC42, $9ED9, $8F50, $FBEF, $EA66, $D8FD, $C974, + $4204, $538D, $6116, $709F, $0420, $15A9, $2732, $36BB, + $CE4C, $DFC5, $ED5E, $FCD7, $8868, $99E1, $AB7A, $BAF3, + $5285, $430C, $7197, $601E, $14A1, $0528, $37B3, $263A, + $DECD, $CF44, $FDDF, $EC56, $98E9, $8960, $BBFB, $AA72, + $6306, $728F, $4014, $519D, $2522, $34AB, $0630, $17B9, + $EF4E, $FEC7, $CC5C, $DDD5, $A96A, $B8E3, $8A78, $9BF1, + $7387, $620E, $5095, $411C, $35A3, $242A, $16B1, $0738, + $FFCF, $EE46, $DCDD, $CD54, $B9EB, $A862, $9AF9, $8B70, + $8408, $9581, $A71A, $B693, $C22C, $D3A5, $E13E, $F0B7, + $0840, $19C9, $2B52, $3ADB, $4E64, $5FED, $6D76, $7CFF, + $9489, $8500, $B79B, $A612, $D2AD, $C324, $F1BF, $E036, + $18C1, $0948, $3BD3, $2A5A, $5EE5, $4F6C, $7DF7, $6C7E, + $A50A, $B483, $8618, $9791, $E32E, $F2A7, $C03C, $D1B5, + $2942, $38CB, $0A50, $1BD9, $6F66, $7EEF, $4C74, $5DFD, + $B58B, $A402, $9699, $8710, $F3AF, $E226, $D0BD, $C134, + $39C3, $284A, $1AD1, $0B58, $7FE7, $6E6E, $5CF5, $4D7C, + $C60C, $D785, $E51E, $F497, $8028, $91A1, $A33A, $B2B3, + $4A44, $5BCD, $6956, $78DF, $0C60, $1DE9, $2F72, $3EFB, + $D68D, $C704, $F59F, $E416, $90A9, $8120, $B3BB, $A232, + $5AC5, $4B4C, $79D7, $685E, $1CE1, $0D68, $3FF3, $2E7A, + $E70E, $F687, $C41C, $D595, $A12A, $B0A3, $8238, $93B1, + $6B46, $7ACF, $4854, $59DD, $2D62, $3CEB, $0E70, $1FF9, + $F78F, $E606, $D49D, $C514, $B1AB, $A022, $92B9, $8330, + $7BC7, $6A4E, $58D5, $495C, $3DE3, $2C6A, $1EF1, $0F78 + ); + +procedure ArrByteToLong(var ArByte: Array of byte; var ArLong: Array of Integer); +{$IFDEF CIL} +var + n: integer; +{$ENDIF} +begin + if (High(ArByte) + 1) > ((High(ArLong) + 1) * 4) then + Exit; + {$IFDEF CIL} + for n := 0 to ((high(ArByte) + 1) div 4) - 1 do + ArLong[n] := ArByte[n * 4 + 0] + + (ArByte[n * 4 + 1] shl 8) + + (ArByte[n * 4 + 2] shl 16) + + (ArByte[n * 4 + 3] shl 24); + {$ELSE} + Move(ArByte[0], ArLong[0], High(ArByte) + 1); + {$ENDIF} +end; + +procedure ArrLongToByte(var ArLong: Array of Integer; var ArByte: Array of byte); +{$IFDEF CIL} +var + n: integer; +{$ENDIF} +begin + if (High(ArByte) + 1) < ((High(ArLong) + 1) * 4) then + Exit; + {$IFDEF CIL} + for n := 0 to high(ArLong) do + begin + ArByte[n * 4 + 0] := ArLong[n] and $000000FF; + ArByte[n * 4 + 1] := (ArLong[n] shr 8) and $000000FF; + ArByte[n * 4 + 2] := (ArLong[n] shr 16) and $000000FF; + ArByte[n * 4 + 3] := (ArLong[n] shr 24) and $000000FF; + end; + {$ELSE} + Move(ArLong[0], ArByte[0], High(ArByte) + 1); + {$ENDIF} +end; + +type + TMDCtx = record + State: array[0..3] of Integer; + Count: array[0..1] of Integer; + BufAnsiChar: array[0..63] of Byte; + BufLong: array[0..15] of Integer; + end; + TSHA1Ctx= record + Hi, Lo: integer; + Buffer: array[0..63] of byte; + Index: integer; + Hash: array[0..4] of Integer; + HashByte: array[0..19] of byte; + end; + + TMDTransform = procedure(var Buf: array of LongInt; const Data: array of LongInt); + +{==============================================================================} + +function DecodeTriplet(const Value: AnsiString; Delimiter: AnsiChar): AnsiString; +var + x, l, lv: Integer; + c: AnsiChar; + b: Byte; + bad: Boolean; +begin + lv := Length(Value); + SetLength(Result, lv); + x := 1; + l := 1; + while x <= lv do + begin + c := Value[x]; + Inc(x); + if c <> Delimiter then + begin + Result[l] := c; + Inc(l); + end + else + if x < lv then + begin + Case Value[x] Of + #13: + if (Value[x + 1] = #10) then + Inc(x, 2) + else + Inc(x); + #10: + if (Value[x + 1] = #13) then + Inc(x, 2) + else + Inc(x); + else + begin + bad := False; + Case Value[x] Of + '0'..'9': b := (Byte(Value[x]) - 48) Shl 4; + 'a'..'f', 'A'..'F': b := ((Byte(Value[x]) And 7) + 9) shl 4; + else + begin + b := 0; + bad := True; + end; + end; + Case Value[x + 1] Of + '0'..'9': b := b Or (Byte(Value[x + 1]) - 48); + 'a'..'f', 'A'..'F': b := b Or ((Byte(Value[x + 1]) And 7) + 9); + else + bad := True; + end; + if bad then + begin + Result[l] := c; + Inc(l); + end + else + begin + Inc(x, 2); + Result[l] := AnsiChar(b); + Inc(l); + end; + end; + end; + end + else + break; + end; + Dec(l); + SetLength(Result, l); +end; + +{==============================================================================} + +function DecodeQuotedPrintable(const Value: AnsiString): AnsiString; +begin + Result := DecodeTriplet(Value, '='); +end; + +{==============================================================================} + +function DecodeURL(const Value: AnsiString): AnsiString; +begin + Result := DecodeTriplet(Value, '%'); +end; + +{==============================================================================} + +function EncodeTriplet(const Value: AnsiString; Delimiter: AnsiChar; + Specials: TSpecials): AnsiString; +var + n, l: Integer; + s: AnsiString; + c: AnsiChar; +begin + SetLength(Result, Length(Value) * 3); + l := 1; + for n := 1 to Length(Value) do + begin + c := Value[n]; + if c in Specials then + begin + Result[l] := Delimiter; + Inc(l); + s := IntToHex(Ord(c), 2); + Result[l] := s[1]; + Inc(l); + Result[l] := s[2]; + Inc(l); + end + else + begin + Result[l] := c; + Inc(l); + end; + end; + Dec(l); + SetLength(Result, l); +end; + +{==============================================================================} + +function EncodeQuotedPrintable(const Value: AnsiString): AnsiString; +begin + Result := EncodeTriplet(Value, '=', ['='] + NonAsciiChar); +end; + +{==============================================================================} + +function EncodeSafeQuotedPrintable(const Value: AnsiString): AnsiString; +begin + Result := EncodeTriplet(Value, '=', SpecialChar + NonAsciiChar); +end; + +{==============================================================================} + +function EncodeURLElement(const Value: AnsiString): AnsiString; +begin + Result := EncodeTriplet(Value, '%', URLSpecialChar + URLFullSpecialChar); +end; + +{==============================================================================} + +function EncodeURL(const Value: AnsiString): AnsiString; +begin + Result := EncodeTriplet(Value, '%', URLSpecialChar); +end; + +{==============================================================================} + +function Decode4to3(const Value, Table: AnsiString): AnsiString; +var + x, y, n, l: Integer; + d: array[0..3] of Byte; +begin + SetLength(Result, Length(Value)); + x := 1; + l := 1; + while x <= Length(Value) do + begin + for n := 0 to 3 do + begin + if x > Length(Value) then + d[n] := 64 + else + begin + y := Pos(Value[x], Table); + if y < 1 then + y := 1; + d[n] := y - 1; + end; + Inc(x); + end; + Result[l] := AnsiChar((D[0] and $3F) shl 2 + (D[1] and $30) shr 4); + Inc(l); + if d[2] <> 64 then + begin + Result[l] := AnsiChar((D[1] and $0F) shl 4 + (D[2] and $3C) shr 2); + Inc(l); + if d[3] <> 64 then + begin + Result[l] := AnsiChar((D[2] and $03) shl 6 + (D[3] and $3F)); + Inc(l); + end; + end; + end; + Dec(l); + SetLength(Result, l); +end; + +{==============================================================================} +function Decode4to3Ex(const Value, Table: AnsiString): AnsiString; +var + x, y, lv: Integer; + d: integer; + dl: integer; + c: byte; + p: integer; +begin + lv := Length(Value); + SetLength(Result, lv); + x := 1; + dl := 4; + d := 0; + p := 1; + while x <= lv do + begin + y := Ord(Value[x]); + if y in [33..127] then + c := Ord(Table[y - 32]) + else + c := 64; + Inc(x); + if c > 63 then + continue; + d := (d shl 6) or c; + dec(dl); + if dl <> 0 then + continue; + Result[p] := AnsiChar((d shr 16) and $ff); + inc(p); + Result[p] := AnsiChar((d shr 8) and $ff); + inc(p); + Result[p] := AnsiChar(d and $ff); + inc(p); + d := 0; + dl := 4; + end; + case dl of + 1: + begin + d := d shr 2; + Result[p] := AnsiChar((d shr 8) and $ff); + inc(p); + Result[p] := AnsiChar(d and $ff); + inc(p); + end; + 2: + begin + d := d shr 4; + Result[p] := AnsiChar(d and $ff); + inc(p); + end; + end; + SetLength(Result, p - 1); +end; + +{==============================================================================} + +function Encode3to4(const Value, Table: AnsiString): AnsiString; +var + c: Byte; + n, l: Integer; + Count: Integer; + DOut: array[0..3] of Byte; +begin + setlength(Result, ((Length(Value) + 2) div 3) * 4); + l := 1; + Count := 1; + while Count <= Length(Value) do + begin + c := Ord(Value[Count]); + Inc(Count); + DOut[0] := (c and $FC) shr 2; + DOut[1] := (c and $03) shl 4; + if Count <= Length(Value) then + begin + c := Ord(Value[Count]); + Inc(Count); + DOut[1] := DOut[1] + (c and $F0) shr 4; + DOut[2] := (c and $0F) shl 2; + if Count <= Length(Value) then + begin + c := Ord(Value[Count]); + Inc(Count); + DOut[2] := DOut[2] + (c and $C0) shr 6; + DOut[3] := (c and $3F); + end + else + begin + DOut[3] := $40; + end; + end + else + begin + DOut[2] := $40; + DOut[3] := $40; + end; + for n := 0 to 3 do + begin + if (DOut[n] + 1) <= Length(Table) then + begin + Result[l] := Table[DOut[n] + 1]; + Inc(l); + end; + end; + end; + SetLength(Result, l - 1); +end; + +{==============================================================================} + +function DecodeBase64(const Value: AnsiString): AnsiString; +begin + Result := Decode4to3Ex(Value, ReTableBase64); +end; + +{==============================================================================} + +function EncodeBase64(const Value: AnsiString): AnsiString; +begin + Result := Encode3to4(Value, TableBase64); +end; + +{==============================================================================} + +function DecodeBase64mod(const Value: AnsiString): AnsiString; +begin + Result := Decode4to3(Value, TableBase64mod); +end; + +{==============================================================================} + +function EncodeBase64mod(const Value: AnsiString): AnsiString; +begin + Result := Encode3to4(Value, TableBase64mod); +end; + +{==============================================================================} + +function DecodeUU(const Value: AnsiString): AnsiString; +var + s: AnsiString; + uut: AnsiString; + x: Integer; +begin + Result := ''; + uut := TableUU; + s := trim(UpperCase(Value)); + if s = '' then Exit; + if Pos('BEGIN', s) = 1 then + Exit; + if Pos('END', s) = 1 then + Exit; + if Pos('TABLE', s) = 1 then + Exit; //ignore Table yet (set custom UUT) + //begin decoding + x := Pos(Value[1], uut) - 1; + case (x mod 3) of + 0: x :=(x div 3)* 4; + 1: x :=((x div 3) * 4) + 2; + 2: x :=((x div 3) * 4) + 3; + end; + //x - lenght UU line + s := Copy(Value, 2, x); + if s = '' then + Exit; + s := s + StringOfChar(' ', x - length(s)); + Result := Decode4to3(s, uut); +end; + +{==============================================================================} + +function EncodeUU(const Value: AnsiString): AnsiString; +begin + Result := ''; + if Length(Value) < Length(TableUU) then + Result := TableUU[Length(Value) + 1] + Encode3to4(Value, TableUU); +end; + +{==============================================================================} + +function DecodeXX(const Value: AnsiString): AnsiString; +var + s: AnsiString; + x: Integer; +begin + Result := ''; + s := trim(UpperCase(Value)); + if s = '' then + Exit; + if Pos('BEGIN', s) = 1 then + Exit; + if Pos('END', s) = 1 then + Exit; + //begin decoding + x := Pos(Value[1], TableXX) - 1; + case (x mod 3) of + 0: x :=(x div 3)* 4; + 1: x :=((x div 3) * 4) + 2; + 2: x :=((x div 3) * 4) + 3; + end; + //x - lenght XX line + s := Copy(Value, 2, x); + if s = '' then + Exit; + s := s + StringOfChar(' ', x - length(s)); + Result := Decode4to3(s, TableXX); +end; + +{==============================================================================} + +function DecodeYEnc(const Value: AnsiString): AnsiString; +var + C : Byte; + i: integer; +begin + Result := ''; + i := 1; + while i <= Length(Value) do + begin + c := Ord(Value[i]); + Inc(i); + if c = Ord('=') then + begin + c := Ord(Value[i]); + Inc(i); + Dec(c, 64); + end; + Dec(C, 42); + Result := Result + AnsiChar(C); + end; +end; + +{==============================================================================} + +function UpdateCrc32(Value: Byte; Crc32: Integer): Integer; +begin + Result := (Crc32 shr 8) + xor crc32tab[Byte(Value xor (Crc32 and Integer($000000FF)))]; +end; + +{==============================================================================} + +function Crc32(const Value: AnsiString): Integer; +var + n: Integer; +begin + Result := Integer($FFFFFFFF); + for n := 1 to Length(Value) do + Result := UpdateCrc32(Ord(Value[n]), Result); + Result := not Result; +end; + +{==============================================================================} + +function UpdateCrc16(Value: Byte; Crc16: Word): Word; +begin + Result := ((Crc16 shr 8) and $00FF) xor + crc16tab[Byte(Crc16 xor (Word(Value)) and $00FF)]; +end; + +{==============================================================================} + +function Crc16(const Value: AnsiString): Word; +var + n: Integer; +begin + Result := $FFFF; + for n := 1 to Length(Value) do + Result := UpdateCrc16(Ord(Value[n]), Result); +end; + +{==============================================================================} + +procedure MDInit(var MDContext: TMDCtx); +var + n: integer; +begin + MDContext.Count[0] := 0; + MDContext.Count[1] := 0; + for n := 0 to high(MDContext.BufAnsiChar) do + MDContext.BufAnsiChar[n] := 0; + for n := 0 to high(MDContext.BufLong) do + MDContext.BufLong[n] := 0; + MDContext.State[0] := Integer($67452301); + MDContext.State[1] := Integer($EFCDAB89); + MDContext.State[2] := Integer($98BADCFE); + MDContext.State[3] := Integer($10325476); +end; + +procedure MD5Transform(var Buf: array of LongInt; const Data: array of LongInt); +var + A, B, C, D: LongInt; + + procedure Round1(var W: LongInt; X, Y, Z, Data: LongInt; S: Byte); + begin + Inc(W, (Z xor (X and (Y xor Z))) + Data); + W := (W shl S) or (W shr (32 - S)); + Inc(W, X); + end; + + procedure Round2(var W: LongInt; X, Y, Z, Data: LongInt; S: Byte); + begin + Inc(W, (Y xor (Z and (X xor Y))) + Data); + W := (W shl S) or (W shr (32 - S)); + Inc(W, X); + end; + + procedure Round3(var W: LongInt; X, Y, Z, Data: LongInt; S: Byte); + begin + Inc(W, (X xor Y xor Z) + Data); + W := (W shl S) or (W shr (32 - S)); + Inc(W, X); + end; + + procedure Round4(var W: LongInt; X, Y, Z, Data: LongInt; S: Byte); + begin + Inc(W, (Y xor (X or not Z)) + Data); + W := (W shl S) or (W shr (32 - S)); + Inc(W, X); + end; +begin + A := Buf[0]; + B := Buf[1]; + C := Buf[2]; + D := Buf[3]; + + Round1(A, B, C, D, Data[0] + Longint($D76AA478), 7); + Round1(D, A, B, C, Data[1] + Longint($E8C7B756), 12); + Round1(C, D, A, B, Data[2] + Longint($242070DB), 17); + Round1(B, C, D, A, Data[3] + Longint($C1BDCEEE), 22); + Round1(A, B, C, D, Data[4] + Longint($F57C0FAF), 7); + Round1(D, A, B, C, Data[5] + Longint($4787C62A), 12); + Round1(C, D, A, B, Data[6] + Longint($A8304613), 17); + Round1(B, C, D, A, Data[7] + Longint($FD469501), 22); + Round1(A, B, C, D, Data[8] + Longint($698098D8), 7); + Round1(D, A, B, C, Data[9] + Longint($8B44F7AF), 12); + Round1(C, D, A, B, Data[10] + Longint($FFFF5BB1), 17); + Round1(B, C, D, A, Data[11] + Longint($895CD7BE), 22); + Round1(A, B, C, D, Data[12] + Longint($6B901122), 7); + Round1(D, A, B, C, Data[13] + Longint($FD987193), 12); + Round1(C, D, A, B, Data[14] + Longint($A679438E), 17); + Round1(B, C, D, A, Data[15] + Longint($49B40821), 22); + + Round2(A, B, C, D, Data[1] + Longint($F61E2562), 5); + Round2(D, A, B, C, Data[6] + Longint($C040B340), 9); + Round2(C, D, A, B, Data[11] + Longint($265E5A51), 14); + Round2(B, C, D, A, Data[0] + Longint($E9B6C7AA), 20); + Round2(A, B, C, D, Data[5] + Longint($D62F105D), 5); + Round2(D, A, B, C, Data[10] + Longint($02441453), 9); + Round2(C, D, A, B, Data[15] + Longint($D8A1E681), 14); + Round2(B, C, D, A, Data[4] + Longint($E7D3FBC8), 20); + Round2(A, B, C, D, Data[9] + Longint($21E1CDE6), 5); + Round2(D, A, B, C, Data[14] + Longint($C33707D6), 9); + Round2(C, D, A, B, Data[3] + Longint($F4D50D87), 14); + Round2(B, C, D, A, Data[8] + Longint($455A14ED), 20); + Round2(A, B, C, D, Data[13] + Longint($A9E3E905), 5); + Round2(D, A, B, C, Data[2] + Longint($FCEFA3F8), 9); + Round2(C, D, A, B, Data[7] + Longint($676F02D9), 14); + Round2(B, C, D, A, Data[12] + Longint($8D2A4C8A), 20); + + Round3(A, B, C, D, Data[5] + Longint($FFFA3942), 4); + Round3(D, A, B, C, Data[8] + Longint($8771F681), 11); + Round3(C, D, A, B, Data[11] + Longint($6D9D6122), 16); + Round3(B, C, D, A, Data[14] + Longint($FDE5380C), 23); + Round3(A, B, C, D, Data[1] + Longint($A4BEEA44), 4); + Round3(D, A, B, C, Data[4] + Longint($4BDECFA9), 11); + Round3(C, D, A, B, Data[7] + Longint($F6BB4B60), 16); + Round3(B, C, D, A, Data[10] + Longint($BEBFBC70), 23); + Round3(A, B, C, D, Data[13] + Longint($289B7EC6), 4); + Round3(D, A, B, C, Data[0] + Longint($EAA127FA), 11); + Round3(C, D, A, B, Data[3] + Longint($D4EF3085), 16); + Round3(B, C, D, A, Data[6] + Longint($04881D05), 23); + Round3(A, B, C, D, Data[9] + Longint($D9D4D039), 4); + Round3(D, A, B, C, Data[12] + Longint($E6DB99E5), 11); + Round3(C, D, A, B, Data[15] + Longint($1FA27CF8), 16); + Round3(B, C, D, A, Data[2] + Longint($C4AC5665), 23); + + Round4(A, B, C, D, Data[0] + Longint($F4292244), 6); + Round4(D, A, B, C, Data[7] + Longint($432AFF97), 10); + Round4(C, D, A, B, Data[14] + Longint($AB9423A7), 15); + Round4(B, C, D, A, Data[5] + Longint($FC93A039), 21); + Round4(A, B, C, D, Data[12] + Longint($655B59C3), 6); + Round4(D, A, B, C, Data[3] + Longint($8F0CCC92), 10); + Round4(C, D, A, B, Data[10] + Longint($FFEFF47D), 15); + Round4(B, C, D, A, Data[1] + Longint($85845DD1), 21); + Round4(A, B, C, D, Data[8] + Longint($6FA87E4F), 6); + Round4(D, A, B, C, Data[15] + Longint($FE2CE6E0), 10); + Round4(C, D, A, B, Data[6] + Longint($A3014314), 15); + Round4(B, C, D, A, Data[13] + Longint($4E0811A1), 21); + Round4(A, B, C, D, Data[4] + Longint($F7537E82), 6); + Round4(D, A, B, C, Data[11] + Longint($BD3AF235), 10); + Round4(C, D, A, B, Data[2] + Longint($2AD7D2BB), 15); + Round4(B, C, D, A, Data[9] + Longint($EB86D391), 21); + + Inc(Buf[0], A); + Inc(Buf[1], B); + Inc(Buf[2], C); + Inc(Buf[3], D); +end; + +//fixed by James McAdams +procedure MDUpdate(var MDContext: TMDCtx; const Data: AnsiString; transform: TMDTransform); +var + Index, partLen, InputLen, I: integer; +{$IFDEF CIL} + n: integer; +{$ENDIF} +begin + InputLen := Length(Data); + with MDContext do + begin + Index := (Count[0] shr 3) and $3F; + Inc(Count[0], InputLen shl 3); + if Count[0] < (InputLen shl 3) then + Inc(Count[1]); + Inc(Count[1], InputLen shr 29); + partLen := 64 - Index; + if InputLen >= partLen then + begin + ArrLongToByte(BufLong, BufAnsiChar); + {$IFDEF CIL} + for n := 1 to partLen do + BufAnsiChar[index - 1 + n] := Ord(Data[n]); + {$ELSE} + Move(Data[1], BufAnsiChar[Index], partLen); + {$ENDIF} + ArrByteToLong(BufAnsiChar, BufLong); + Transform(State, Buflong); + I := partLen; + while I + 63 < InputLen do + begin + ArrLongToByte(BufLong, BufAnsiChar); + {$IFDEF CIL} + for n := 1 to 64 do + BufAnsiChar[n - 1] := Ord(Data[i + n]); + {$ELSE} + Move(Data[I+1], BufAnsiChar, 64); + {$ENDIF} + ArrByteToLong(BufAnsiChar, BufLong); + Transform(State, Buflong); + inc(I, 64); + end; + Index := 0; + end + else + I := 0; + ArrLongToByte(BufLong, BufAnsiChar); + {$IFDEF CIL} + for n := 1 to InputLen-I do + BufAnsiChar[Index + n - 1] := Ord(Data[i + n]); + {$ELSE} + Move(Data[I+1], BufAnsiChar[Index], InputLen-I); + {$ENDIF} + ArrByteToLong(BufAnsiChar, BufLong); + end +end; + +function MDFinal(var MDContext: TMDCtx; transform: TMDTransform): AnsiString; +var + Cnt: Word; + P: Byte; + digest: array[0..15] of Byte; + i: Integer; + n: integer; +begin + for I := 0 to 15 do + Digest[I] := I + 1; + with MDContext do + begin + Cnt := (Count[0] shr 3) and $3F; + P := Cnt; + BufAnsiChar[P] := $80; + Inc(P); + Cnt := 64 - 1 - Cnt; + if Cnt < 8 then + begin + for n := 0 to cnt - 1 do + BufAnsiChar[P + n] := 0; + ArrByteToLong(BufAnsiChar, BufLong); +// FillChar(BufAnsiChar[P], Cnt, #0); + Transform(State, BufLong); + ArrLongToByte(BufLong, BufAnsiChar); + for n := 0 to 55 do + BufAnsiChar[n] := 0; + ArrByteToLong(BufAnsiChar, BufLong); +// FillChar(BufAnsiChar, 56, #0); + end + else + begin + for n := 0 to Cnt - 8 - 1 do + BufAnsiChar[p + n] := 0; + ArrByteToLong(BufAnsiChar, BufLong); +// FillChar(BufAnsiChar[P], Cnt - 8, #0); + end; + BufLong[14] := Count[0]; + BufLong[15] := Count[1]; + Transform(State, BufLong); + ArrLongToByte(State, Digest); +// Move(State, Digest, 16); + Result := ''; + for i := 0 to 15 do + Result := Result + AnsiChar(digest[i]); + end; +// FillChar(MD5Context, SizeOf(TMD5Ctx), #0) +end; + +{==============================================================================} + +function MD5(const Value: AnsiString): AnsiString; +var + MDContext: TMDCtx; +begin + MDInit(MDContext); + MDUpdate(MDContext, Value, @MD5Transform); + Result := MDFinal(MDContext, @MD5Transform); +end; + +{==============================================================================} + +function HMAC_MD5(Text, Key: AnsiString): AnsiString; +var + ipad, opad, s: AnsiString; + n: Integer; + MDContext: TMDCtx; +begin + if Length(Key) > 64 then + Key := md5(Key); + ipad := StringOfChar(#$36, 64); + opad := StringOfChar(#$5C, 64); + for n := 1 to Length(Key) do + begin + ipad[n] := AnsiChar(Byte(ipad[n]) xor Byte(Key[n])); + opad[n] := AnsiChar(Byte(opad[n]) xor Byte(Key[n])); + end; + MDInit(MDContext); + MDUpdate(MDContext, ipad, @MD5Transform); + MDUpdate(MDContext, Text, @MD5Transform); + s := MDFinal(MDContext, @MD5Transform); + MDInit(MDContext); + MDUpdate(MDContext, opad, @MD5Transform); + MDUpdate(MDContext, s, @MD5Transform); + Result := MDFinal(MDContext, @MD5Transform); +end; + +{==============================================================================} + +function MD5LongHash(const Value: AnsiString; Len: integer): AnsiString; +var + cnt, rest: integer; + l: integer; + n: integer; + MDContext: TMDCtx; +begin + l := length(Value); + cnt := Len div l; + rest := Len mod l; + MDInit(MDContext); + for n := 1 to cnt do + MDUpdate(MDContext, Value, @MD5Transform); + if rest > 0 then + MDUpdate(MDContext, Copy(Value, 1, rest), @MD5Transform); + Result := MDFinal(MDContext, @MD5Transform); +end; + +{==============================================================================} +// SHA1 is based on sources by Dave Barton (davebarton@bigfoot.com) + +procedure SHA1init( var SHA1Context: TSHA1Ctx ); +var + n: integer; +begin + SHA1Context.Hi := 0; + SHA1Context.Lo := 0; + SHA1Context.Index := 0; + for n := 0 to High(SHA1Context.Buffer) do + SHA1Context.Buffer[n] := 0; + for n := 0 to High(SHA1Context.HashByte) do + SHA1Context.HashByte[n] := 0; +// FillChar(SHA1Context, SizeOf(TSHA1Ctx), #0); + SHA1Context.Hash[0] := integer($67452301); + SHA1Context.Hash[1] := integer($EFCDAB89); + SHA1Context.Hash[2] := integer($98BADCFE); + SHA1Context.Hash[3] := integer($10325476); + SHA1Context.Hash[4] := integer($C3D2E1F0); +end; + +//****************************************************************************** +function RB(A: integer): integer; +begin + Result := (A shr 24) or ((A shr 8) and $FF00) or ((A shl 8) and $FF0000) or (A shl 24); +end; + +procedure SHA1Compress(var Data: TSHA1Ctx); +var + A, B, C, D, E, T: integer; + W: array[0..79] of integer; + i: integer; + n: integer; + + function F1(x, y, z: integer): integer; + begin + Result := z xor (x and (y xor z)); + end; + function F2(x, y, z: integer): integer; + begin + Result := x xor y xor z; + end; + function F3(x, y, z: integer): integer; + begin + Result := (x and y) or (z and (x or y)); + end; + function LRot32(X: integer; c: integer): integer; + begin + result := (x shl c) or (x shr (32 - c)); + end; +begin + ArrByteToLong(Data.Buffer, W); +// Move(Data.Buffer, W, Sizeof(Data.Buffer)); + for i := 0 to 15 do + W[i] := RB(W[i]); + for i := 16 to 79 do + W[i] := LRot32(W[i-3] xor W[i-8] xor W[i-14] xor W[i-16], 1); + A := Data.Hash[0]; + B := Data.Hash[1]; + C := Data.Hash[2]; + D := Data.Hash[3]; + E := Data.Hash[4]; + for i := 0 to 19 do + begin + T := LRot32(A, 5) + F1(B, C, D) + E + W[i] + integer($5A827999); + E := D; + D := C; + C := LRot32(B, 30); + B := A; + A := T; + end; + for i := 20 to 39 do + begin + T := LRot32(A, 5) + F2(B, C, D) + E + W[i] + integer($6ED9EBA1); + E := D; + D := C; + C := LRot32(B, 30); + B := A; + A := T; + end; + for i := 40 to 59 do + begin + T := LRot32(A, 5) + F3(B, C, D) + E + W[i] + integer($8F1BBCDC); + E := D; + D := C; + C := LRot32(B, 30); + B := A; + A := T; + end; + for i := 60 to 79 do + begin + T := LRot32(A, 5) + F2(B, C, D) + E + W[i] + integer($CA62C1D6); + E := D; + D := C; + C := LRot32(B, 30); + B := A; + A := T; + end; + Data.Hash[0] := Data.Hash[0] + A; + Data.Hash[1] := Data.Hash[1] + B; + Data.Hash[2] := Data.Hash[2] + C; + Data.Hash[3] := Data.Hash[3] + D; + Data.Hash[4] := Data.Hash[4] + E; + for n := 0 to high(w) do + w[n] := 0; +// FillChar(W, Sizeof(W), 0); + for n := 0 to high(Data.Buffer) do + Data.Buffer[n] := 0; +// FillChar(Data.Buffer, Sizeof(Data.Buffer), 0); +end; + +//****************************************************************************** +procedure SHA1Update(var Context: TSHA1Ctx; const Data: AnsiString); +var + Len: integer; + n: integer; + i, k: integer; +begin + Len := Length(data); + for k := 0 to 7 do + begin + i := Context.Lo; + Inc(Context.Lo, Len); + if Context.Lo < i then + Inc(Context.Hi); + end; + for n := 1 to len do + begin + Context.Buffer[Context.Index] := byte(Data[n]); + Inc(Context.Index); + if Context.Index = 64 then + begin + Context.Index := 0; + SHA1Compress(Context); + end; + end; +end; + +//****************************************************************************** +function SHA1Final(var Context: TSHA1Ctx): AnsiString; +type + Pinteger = ^integer; +var + i: integer; + procedure ItoArr(var Ar: Array of byte; I, value: Integer); + begin + Ar[i + 0] := Value and $000000FF; + Ar[i + 1] := (Value shr 8) and $000000FF; + Ar[i + 2] := (Value shr 16) and $000000FF; + Ar[i + 3] := (Value shr 24) and $000000FF; + end; +begin + Context.Buffer[Context.Index] := $80; + if Context.Index >= 56 then + SHA1Compress(Context); + ItoArr(Context.Buffer, 56, RB(Context.Hi)); + ItoArr(Context.Buffer, 60, RB(Context.Lo)); +// Pinteger(@Context.Buffer[56])^ := RB(Context.Hi); +// Pinteger(@Context.Buffer[60])^ := RB(Context.Lo); + SHA1Compress(Context); + Context.Hash[0] := RB(Context.Hash[0]); + Context.Hash[1] := RB(Context.Hash[1]); + Context.Hash[2] := RB(Context.Hash[2]); + Context.Hash[3] := RB(Context.Hash[3]); + Context.Hash[4] := RB(Context.Hash[4]); + ArrLongToByte(Context.Hash, Context.HashByte); + Result := ''; + for i := 0 to 19 do + Result := Result + AnsiChar(Context.HashByte[i]); +end; + +function SHA1(const Value: AnsiString): AnsiString; +var + SHA1Context: TSHA1Ctx; +begin + SHA1Init(SHA1Context); + SHA1Update(SHA1Context, Value); + Result := SHA1Final(SHA1Context); +end; + +{==============================================================================} + +function HMAC_SHA1(Text, Key: AnsiString): AnsiString; +var + ipad, opad, s: AnsiString; + n: Integer; + SHA1Context: TSHA1Ctx; +begin + if Length(Key) > 64 then + Key := SHA1(Key); + ipad := StringOfChar(#$36, 64); + opad := StringOfChar(#$5C, 64); + for n := 1 to Length(Key) do + begin + ipad[n] := AnsiChar(Byte(ipad[n]) xor Byte(Key[n])); + opad[n] := AnsiChar(Byte(opad[n]) xor Byte(Key[n])); + end; + SHA1Init(SHA1Context); + SHA1Update(SHA1Context, ipad); + SHA1Update(SHA1Context, Text); + s := SHA1Final(SHA1Context); + SHA1Init(SHA1Context); + SHA1Update(SHA1Context, opad); + SHA1Update(SHA1Context, s); + Result := SHA1Final(SHA1Context); +end; + +{==============================================================================} + +function SHA1LongHash(const Value: AnsiString; Len: integer): AnsiString; +var + cnt, rest: integer; + l: integer; + n: integer; + SHA1Context: TSHA1Ctx; +begin + l := length(Value); + cnt := Len div l; + rest := Len mod l; + SHA1Init(SHA1Context); + for n := 1 to cnt do + SHA1Update(SHA1Context, Value); + if rest > 0 then + SHA1Update(SHA1Context, Copy(Value, 1, rest)); + Result := SHA1Final(SHA1Context); +end; + +{==============================================================================} + +procedure MD4Transform(var Buf: array of LongInt; const Data: array of LongInt); +var + A, B, C, D: LongInt; + function LRot32(a, b: longint): longint; + begin + Result:= (a shl b) or (a shr (32 - b)); + end; +begin + A := Buf[0]; + B := Buf[1]; + C := Buf[2]; + D := Buf[3]; + + A:= LRot32(A + (D xor (B and (C xor D))) + Data[ 0], 3); + D:= LRot32(D + (C xor (A and (B xor C))) + Data[ 1], 7); + C:= LRot32(C + (B xor (D and (A xor B))) + Data[ 2], 11); + B:= LRot32(B + (A xor (C and (D xor A))) + Data[ 3], 19); + A:= LRot32(A + (D xor (B and (C xor D))) + Data[ 4], 3); + D:= LRot32(D + (C xor (A and (B xor C))) + Data[ 5], 7); + C:= LRot32(C + (B xor (D and (A xor B))) + Data[ 6], 11); + B:= LRot32(B + (A xor (C and (D xor A))) + Data[ 7], 19); + A:= LRot32(A + (D xor (B and (C xor D))) + Data[ 8], 3); + D:= LRot32(D + (C xor (A and (B xor C))) + Data[ 9], 7); + C:= LRot32(C + (B xor (D and (A xor B))) + Data[10], 11); + B:= LRot32(B + (A xor (C and (D xor A))) + Data[11], 19); + A:= LRot32(A + (D xor (B and (C xor D))) + Data[12], 3); + D:= LRot32(D + (C xor (A and (B xor C))) + Data[13], 7); + C:= LRot32(C + (B xor (D and (A xor B))) + Data[14], 11); + B:= LRot32(B + (A xor (C and (D xor A))) + Data[15], 19); + + A:= LRot32(A + ((B and C) or (B and D) or (C and D)) + Data[ 0] + longint($5a827999), 3); + D:= LRot32(D + ((A and B) or (A and C) or (B and C)) + Data[ 4] + longint($5a827999), 5); + C:= LRot32(C + ((D and A) or (D and B) or (A and B)) + Data[ 8] + longint($5a827999), 9); + B:= LRot32(B + ((C and D) or (C and A) or (D and A)) + Data[12] + longint($5a827999), 13); + A:= LRot32(A + ((B and C) or (B and D) or (C and D)) + Data[ 1] + longint($5a827999), 3); + D:= LRot32(D + ((A and B) or (A and C) or (B and C)) + Data[ 5] + longint($5a827999), 5); + C:= LRot32(C + ((D and A) or (D and B) or (A and B)) + Data[ 9] + longint($5a827999), 9); + B:= LRot32(B + ((C and D) or (C and A) or (D and A)) + Data[13] + longint($5a827999), 13); + A:= LRot32(A + ((B and C) or (B and D) or (C and D)) + Data[ 2] + longint($5a827999), 3); + D:= LRot32(D + ((A and B) or (A and C) or (B and C)) + Data[ 6] + longint($5a827999), 5); + C:= LRot32(C + ((D and A) or (D and B) or (A and B)) + Data[10] + longint($5a827999), 9); + B:= LRot32(B + ((C and D) or (C and A) or (D and A)) + Data[14] + longint($5a827999), 13); + A:= LRot32(A + ((B and C) or (B and D) or (C and D)) + Data[ 3] + longint($5a827999), 3); + D:= LRot32(D + ((A and B) or (A and C) or (B and C)) + Data[ 7] + longint($5a827999), 5); + C:= LRot32(C + ((D and A) or (D and B) or (A and B)) + Data[11] + longint($5a827999), 9); + B:= LRot32(B + ((C and D) or (C and A) or (D and A)) + Data[15] + longint($5a827999), 13); + + A:= LRot32(A + (B xor C xor D) + Data[ 0] + longint($6ed9eba1), 3); + D:= LRot32(D + (A xor B xor C) + Data[ 8] + longint($6ed9eba1), 9); + C:= LRot32(C + (D xor A xor B) + Data[ 4] + longint($6ed9eba1), 11); + B:= LRot32(B + (C xor D xor A) + Data[12] + longint($6ed9eba1), 15); + A:= LRot32(A + (B xor C xor D) + Data[ 2] + longint($6ed9eba1), 3); + D:= LRot32(D + (A xor B xor C) + Data[10] + longint($6ed9eba1), 9); + C:= LRot32(C + (D xor A xor B) + Data[ 6] + longint($6ed9eba1), 11); + B:= LRot32(B + (C xor D xor A) + Data[14] + longint($6ed9eba1), 15); + A:= LRot32(A + (B xor C xor D) + Data[ 1] + longint($6ed9eba1), 3); + D:= LRot32(D + (A xor B xor C) + Data[ 9] + longint($6ed9eba1), 9); + C:= LRot32(C + (D xor A xor B) + Data[ 5] + longint($6ed9eba1), 11); + B:= LRot32(B + (C xor D xor A) + Data[13] + longint($6ed9eba1), 15); + A:= LRot32(A + (B xor C xor D) + Data[ 3] + longint($6ed9eba1), 3); + D:= LRot32(D + (A xor B xor C) + Data[11] + longint($6ed9eba1), 9); + C:= LRot32(C + (D xor A xor B) + Data[ 7] + longint($6ed9eba1), 11); + B:= LRot32(B + (C xor D xor A) + Data[15] + longint($6ed9eba1), 15); + + Inc(Buf[0], A); + Inc(Buf[1], B); + Inc(Buf[2], C); + Inc(Buf[3], D); +end; + +{==============================================================================} + +function MD4(const Value: AnsiString): AnsiString; +var + MDContext: TMDCtx; +begin + MDInit(MDContext); + MDUpdate(MDContext, Value, @MD4Transform); + Result := MDFinal(MDContext, @MD4Transform); +end; + +{==============================================================================} + + +end. diff --git a/synapse/synacrypt.pas b/synapse/synacrypt.pas new file mode 100644 index 0000000..f19d256 --- /dev/null +++ b/synapse/synacrypt.pas @@ -0,0 +1,2412 @@ +{==============================================================================| +| Project : Ararat Synapse | 001.001.000 | +|==============================================================================| +| Content: Encryption support | +|==============================================================================| +| Copyright (c)2007-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)2007-2011. | +| All Rights Reserved. | +| Based on work of David Barton and Eric Young | +|==============================================================================| +| Contributor(s): | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +{:@abstract(Encryption support) + +Implemented are DES and 3DES encryption/decryption by ECB, CBC, CFB-8bit, + CFB-block, OFB and CTR methods. +} + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$Q-} +{$R-} +{$H+} + +{$IFDEF UNICODE} + {$WARN IMPLICIT_STRING_CAST OFF} + {$WARN IMPLICIT_STRING_CAST_LOSS OFF} +{$ENDIF} + +unit synacrypt; + +interface + +uses + SysUtils, Classes, synautil, synafpc; + +type + {:@abstract(Implementation of common routines block ciphers (dafault size is 64-bits)) + + Do not use this class directly, use descendants only!} + TSynaBlockCipher= class(TObject) + protected + procedure InitKey(Key: AnsiString); virtual; + function GetSize: byte; virtual; + private + IV, CV: AnsiString; + procedure IncCounter; + public + {:Sets the IV to Value and performs a reset} + procedure SetIV(const Value: AnsiString); virtual; + {:Returns the current chaining information, not the actual IV} + function GetIV: AnsiString; virtual; + {:Reset any stored chaining information} + procedure Reset; virtual; + {:Encrypt a 64-bit block of data using the ECB method of encryption} + function EncryptECB(const InData: AnsiString): AnsiString; virtual; + {:Decrypt a 64-bit block of data using the ECB method of decryption} + function DecryptECB(const InData: AnsiString): AnsiString; virtual; + {:Encrypt data using the CBC method of encryption} + function EncryptCBC(const Indata: AnsiString): AnsiString; virtual; + {:Decrypt data using the CBC method of decryption} + function DecryptCBC(const Indata: AnsiString): AnsiString; virtual; + {:Encrypt data using the CFB (8 bit) method of encryption} + function EncryptCFB8bit(const Indata: AnsiString): AnsiString; virtual; + {:Decrypt data using the CFB (8 bit) method of decryption} + function DecryptCFB8bit(const Indata: AnsiString): AnsiString; virtual; + {:Encrypt data using the CFB (block) method of encryption} + function EncryptCFBblock(const Indata: AnsiString): AnsiString; virtual; + {:Decrypt data using the CFB (block) method of decryption} + function DecryptCFBblock(const Indata: AnsiString): AnsiString; virtual; + {:Encrypt data using the OFB method of encryption} + function EncryptOFB(const Indata: AnsiString): AnsiString; virtual; + {:Decrypt data using the OFB method of decryption} + function DecryptOFB(const Indata: AnsiString): AnsiString; virtual; + {:Encrypt data using the CTR method of encryption} + function EncryptCTR(const Indata: AnsiString): AnsiString; virtual; + {:Decrypt data using the CTR method of decryption} + function DecryptCTR(const Indata: AnsiString): AnsiString; virtual; + {:Create a encryptor/decryptor instance and initialize it by the Key.} + constructor Create(Key: AnsiString); + end; + + {:@abstract(Datatype for holding one DES key data) + + This data type is used internally.} + TDesKeyData = array[0..31] of integer; + + {:@abstract(Implementation of common routines for DES encryption) + + Do not use this class directly, use descendants only!} + TSynaCustomDes = class(TSynaBlockcipher) + protected + procedure DoInit(KeyB: AnsiString; var KeyData: TDesKeyData); + function EncryptBlock(const InData: AnsiString; var KeyData: TDesKeyData): AnsiString; + function DecryptBlock(const InData: AnsiString; var KeyData: TDesKeyData): AnsiString; + end; + + {:@abstract(Implementation of DES encryption)} + TSynaDes= class(TSynaCustomDes) + protected + KeyData: TDesKeyData; + procedure InitKey(Key: AnsiString); override; + public + {:Encrypt a 64-bit block of data using the ECB method of encryption} + function EncryptECB(const InData: AnsiString): AnsiString; override; + {:Decrypt a 64-bit block of data using the ECB method of decryption} + function DecryptECB(const InData: AnsiString): AnsiString; override; + end; + + {:@abstract(Implementation of 3DES encryption)} + TSyna3Des= class(TSynaCustomDes) + protected + KeyData: array[0..2] of TDesKeyData; + procedure InitKey(Key: AnsiString); override; + public + {:Encrypt a 64-bit block of data using the ECB method of encryption} + function EncryptECB(const InData: AnsiString): AnsiString; override; + {:Decrypt a 64-bit block of data using the ECB method of decryption} + function DecryptECB(const InData: AnsiString): AnsiString; override; + end; + +const + BC = 4; + MAXROUNDS = 14; +type + {:@abstract(Implementation of AES encryption)} + TSynaAes= class(TSynaBlockcipher) + protected + numrounds: longword; + rk, drk: array[0..MAXROUNDS,0..7] of longword; + procedure InitKey(Key: AnsiString); override; + function GetSize: byte; override; + public + {:Encrypt a 128-bit block of data using the ECB method of encryption} + function EncryptECB(const InData: AnsiString): AnsiString; override; + {:Decrypt a 128-bit block of data using the ECB method of decryption} + function DecryptECB(const InData: AnsiString): AnsiString; override; + end; + +{:Call internal test of all DES encryptions. Returns @true if all is OK.} +function TestDes: boolean; +{:Call internal test of all 3DES encryptions. Returns @true if all is OK.} +function Test3Des: boolean; +{:Call internal test of all AES encryptions. Returns @true if all is OK.} +function TestAes: boolean; + +{==============================================================================} +implementation + +//DES consts +const + shifts2: array[0..15]of byte= + (0,0,1,1,1,1,1,1,0,1,1,1,1,1,1,0); + + des_skb: array[0..7,0..63]of integer=( + ( + (* for C bits (numbered as per FIPS 46) 1 2 3 4 5 6 *) + integer($00000000),integer($00000010),integer($20000000),integer($20000010), + integer($00010000),integer($00010010),integer($20010000),integer($20010010), + integer($00000800),integer($00000810),integer($20000800),integer($20000810), + integer($00010800),integer($00010810),integer($20010800),integer($20010810), + integer($00000020),integer($00000030),integer($20000020),integer($20000030), + integer($00010020),integer($00010030),integer($20010020),integer($20010030), + integer($00000820),integer($00000830),integer($20000820),integer($20000830), + integer($00010820),integer($00010830),integer($20010820),integer($20010830), + integer($00080000),integer($00080010),integer($20080000),integer($20080010), + integer($00090000),integer($00090010),integer($20090000),integer($20090010), + integer($00080800),integer($00080810),integer($20080800),integer($20080810), + integer($00090800),integer($00090810),integer($20090800),integer($20090810), + integer($00080020),integer($00080030),integer($20080020),integer($20080030), + integer($00090020),integer($00090030),integer($20090020),integer($20090030), + integer($00080820),integer($00080830),integer($20080820),integer($20080830), + integer($00090820),integer($00090830),integer($20090820),integer($20090830) + ),( + (* for C bits (numbered as per FIPS 46) 7 8 10 11 12 13 *) + integer($00000000),integer($02000000),integer($00002000),integer($02002000), + integer($00200000),integer($02200000),integer($00202000),integer($02202000), + integer($00000004),integer($02000004),integer($00002004),integer($02002004), + integer($00200004),integer($02200004),integer($00202004),integer($02202004), + integer($00000400),integer($02000400),integer($00002400),integer($02002400), + integer($00200400),integer($02200400),integer($00202400),integer($02202400), + integer($00000404),integer($02000404),integer($00002404),integer($02002404), + integer($00200404),integer($02200404),integer($00202404),integer($02202404), + integer($10000000),integer($12000000),integer($10002000),integer($12002000), + integer($10200000),integer($12200000),integer($10202000),integer($12202000), + integer($10000004),integer($12000004),integer($10002004),integer($12002004), + integer($10200004),integer($12200004),integer($10202004),integer($12202004), + integer($10000400),integer($12000400),integer($10002400),integer($12002400), + integer($10200400),integer($12200400),integer($10202400),integer($12202400), + integer($10000404),integer($12000404),integer($10002404),integer($12002404), + integer($10200404),integer($12200404),integer($10202404),integer($12202404) + ),( + (* for C bits (numbered as per FIPS 46) 14 15 16 17 19 20 *) + integer($00000000),integer($00000001),integer($00040000),integer($00040001), + integer($01000000),integer($01000001),integer($01040000),integer($01040001), + integer($00000002),integer($00000003),integer($00040002),integer($00040003), + integer($01000002),integer($01000003),integer($01040002),integer($01040003), + integer($00000200),integer($00000201),integer($00040200),integer($00040201), + integer($01000200),integer($01000201),integer($01040200),integer($01040201), + integer($00000202),integer($00000203),integer($00040202),integer($00040203), + integer($01000202),integer($01000203),integer($01040202),integer($01040203), + integer($08000000),integer($08000001),integer($08040000),integer($08040001), + integer($09000000),integer($09000001),integer($09040000),integer($09040001), + integer($08000002),integer($08000003),integer($08040002),integer($08040003), + integer($09000002),integer($09000003),integer($09040002),integer($09040003), + integer($08000200),integer($08000201),integer($08040200),integer($08040201), + integer($09000200),integer($09000201),integer($09040200),integer($09040201), + integer($08000202),integer($08000203),integer($08040202),integer($08040203), + integer($09000202),integer($09000203),integer($09040202),integer($09040203) + ),( + (* for C bits (numbered as per FIPS 46) 21 23 24 26 27 28 *) + integer($00000000),integer($00100000),integer($00000100),integer($00100100), + integer($00000008),integer($00100008),integer($00000108),integer($00100108), + integer($00001000),integer($00101000),integer($00001100),integer($00101100), + integer($00001008),integer($00101008),integer($00001108),integer($00101108), + integer($04000000),integer($04100000),integer($04000100),integer($04100100), + integer($04000008),integer($04100008),integer($04000108),integer($04100108), + integer($04001000),integer($04101000),integer($04001100),integer($04101100), + integer($04001008),integer($04101008),integer($04001108),integer($04101108), + integer($00020000),integer($00120000),integer($00020100),integer($00120100), + integer($00020008),integer($00120008),integer($00020108),integer($00120108), + integer($00021000),integer($00121000),integer($00021100),integer($00121100), + integer($00021008),integer($00121008),integer($00021108),integer($00121108), + integer($04020000),integer($04120000),integer($04020100),integer($04120100), + integer($04020008),integer($04120008),integer($04020108),integer($04120108), + integer($04021000),integer($04121000),integer($04021100),integer($04121100), + integer($04021008),integer($04121008),integer($04021108),integer($04121108) + ),( + (* for D bits (numbered as per FIPS 46) 1 2 3 4 5 6 *) + integer($00000000),integer($10000000),integer($00010000),integer($10010000), + integer($00000004),integer($10000004),integer($00010004),integer($10010004), + integer($20000000),integer($30000000),integer($20010000),integer($30010000), + integer($20000004),integer($30000004),integer($20010004),integer($30010004), + integer($00100000),integer($10100000),integer($00110000),integer($10110000), + integer($00100004),integer($10100004),integer($00110004),integer($10110004), + integer($20100000),integer($30100000),integer($20110000),integer($30110000), + integer($20100004),integer($30100004),integer($20110004),integer($30110004), + integer($00001000),integer($10001000),integer($00011000),integer($10011000), + integer($00001004),integer($10001004),integer($00011004),integer($10011004), + integer($20001000),integer($30001000),integer($20011000),integer($30011000), + integer($20001004),integer($30001004),integer($20011004),integer($30011004), + integer($00101000),integer($10101000),integer($00111000),integer($10111000), + integer($00101004),integer($10101004),integer($00111004),integer($10111004), + integer($20101000),integer($30101000),integer($20111000),integer($30111000), + integer($20101004),integer($30101004),integer($20111004),integer($30111004) + ),( + (* for D bits (numbered as per FIPS 46) 8 9 11 12 13 14 *) + integer($00000000),integer($08000000),integer($00000008),integer($08000008), + integer($00000400),integer($08000400),integer($00000408),integer($08000408), + integer($00020000),integer($08020000),integer($00020008),integer($08020008), + integer($00020400),integer($08020400),integer($00020408),integer($08020408), + integer($00000001),integer($08000001),integer($00000009),integer($08000009), + integer($00000401),integer($08000401),integer($00000409),integer($08000409), + integer($00020001),integer($08020001),integer($00020009),integer($08020009), + integer($00020401),integer($08020401),integer($00020409),integer($08020409), + integer($02000000),integer($0A000000),integer($02000008),integer($0A000008), + integer($02000400),integer($0A000400),integer($02000408),integer($0A000408), + integer($02020000),integer($0A020000),integer($02020008),integer($0A020008), + integer($02020400),integer($0A020400),integer($02020408),integer($0A020408), + integer($02000001),integer($0A000001),integer($02000009),integer($0A000009), + integer($02000401),integer($0A000401),integer($02000409),integer($0A000409), + integer($02020001),integer($0A020001),integer($02020009),integer($0A020009), + integer($02020401),integer($0A020401),integer($02020409),integer($0A020409) + ),( + (* for D bits (numbered as per FIPS 46) 16 17 18 19 20 21 *) + integer($00000000),integer($00000100),integer($00080000),integer($00080100), + integer($01000000),integer($01000100),integer($01080000),integer($01080100), + integer($00000010),integer($00000110),integer($00080010),integer($00080110), + integer($01000010),integer($01000110),integer($01080010),integer($01080110), + integer($00200000),integer($00200100),integer($00280000),integer($00280100), + integer($01200000),integer($01200100),integer($01280000),integer($01280100), + integer($00200010),integer($00200110),integer($00280010),integer($00280110), + integer($01200010),integer($01200110),integer($01280010),integer($01280110), + integer($00000200),integer($00000300),integer($00080200),integer($00080300), + integer($01000200),integer($01000300),integer($01080200),integer($01080300), + integer($00000210),integer($00000310),integer($00080210),integer($00080310), + integer($01000210),integer($01000310),integer($01080210),integer($01080310), + integer($00200200),integer($00200300),integer($00280200),integer($00280300), + integer($01200200),integer($01200300),integer($01280200),integer($01280300), + integer($00200210),integer($00200310),integer($00280210),integer($00280310), + integer($01200210),integer($01200310),integer($01280210),integer($01280310) + ),( + (* for D bits (numbered as per FIPS 46) 22 23 24 25 27 28 *) + integer($00000000),integer($04000000),integer($00040000),integer($04040000), + integer($00000002),integer($04000002),integer($00040002),integer($04040002), + integer($00002000),integer($04002000),integer($00042000),integer($04042000), + integer($00002002),integer($04002002),integer($00042002),integer($04042002), + integer($00000020),integer($04000020),integer($00040020),integer($04040020), + integer($00000022),integer($04000022),integer($00040022),integer($04040022), + integer($00002020),integer($04002020),integer($00042020),integer($04042020), + integer($00002022),integer($04002022),integer($00042022),integer($04042022), + integer($00000800),integer($04000800),integer($00040800),integer($04040800), + integer($00000802),integer($04000802),integer($00040802),integer($04040802), + integer($00002800),integer($04002800),integer($00042800),integer($04042800), + integer($00002802),integer($04002802),integer($00042802),integer($04042802), + integer($00000820),integer($04000820),integer($00040820),integer($04040820), + integer($00000822),integer($04000822),integer($00040822),integer($04040822), + integer($00002820),integer($04002820),integer($00042820),integer($04042820), + integer($00002822),integer($04002822),integer($00042822),integer($04042822) + )); + + des_sptrans: array[0..7,0..63] of integer=( + ( + (* nibble 0 *) + integer($02080800), integer($00080000), integer($02000002), integer($02080802), + integer($02000000), integer($00080802), integer($00080002), integer($02000002), + integer($00080802), integer($02080800), integer($02080000), integer($00000802), + integer($02000802), integer($02000000), integer($00000000), integer($00080002), + integer($00080000), integer($00000002), integer($02000800), integer($00080800), + integer($02080802), integer($02080000), integer($00000802), integer($02000800), + integer($00000002), integer($00000800), integer($00080800), integer($02080002), + integer($00000800), integer($02000802), integer($02080002), integer($00000000), + integer($00000000), integer($02080802), integer($02000800), integer($00080002), + integer($02080800), integer($00080000), integer($00000802), integer($02000800), + integer($02080002), integer($00000800), integer($00080800), integer($02000002), + integer($00080802), integer($00000002), integer($02000002), integer($02080000), + integer($02080802), integer($00080800), integer($02080000), integer($02000802), + integer($02000000), integer($00000802), integer($00080002), integer($00000000), + integer($00080000), integer($02000000), integer($02000802), integer($02080800), + integer($00000002), integer($02080002), integer($00000800), integer($00080802) + ),( + (* nibble 1 *) + integer($40108010), integer($00000000), integer($00108000), integer($40100000), + integer($40000010), integer($00008010), integer($40008000), integer($00108000), + integer($00008000), integer($40100010), integer($00000010), integer($40008000), + integer($00100010), integer($40108000), integer($40100000), integer($00000010), + integer($00100000), integer($40008010), integer($40100010), integer($00008000), + integer($00108010), integer($40000000), integer($00000000), integer($00100010), + integer($40008010), integer($00108010), integer($40108000), integer($40000010), + integer($40000000), integer($00100000), integer($00008010), integer($40108010), + integer($00100010), integer($40108000), integer($40008000), integer($00108010), + integer($40108010), integer($00100010), integer($40000010), integer($00000000), + integer($40000000), integer($00008010), integer($00100000), integer($40100010), + integer($00008000), integer($40000000), integer($00108010), integer($40008010), + integer($40108000), integer($00008000), integer($00000000), integer($40000010), + integer($00000010), integer($40108010), integer($00108000), integer($40100000), + integer($40100010), integer($00100000), integer($00008010), integer($40008000), + integer($40008010), integer($00000010), integer($40100000), integer($00108000) + ),( + (* nibble 2 *) + integer($04000001), integer($04040100), integer($00000100), integer($04000101), + integer($00040001), integer($04000000), integer($04000101), integer($00040100), + integer($04000100), integer($00040000), integer($04040000), integer($00000001), + integer($04040101), integer($00000101), integer($00000001), integer($04040001), + integer($00000000), integer($00040001), integer($04040100), integer($00000100), + integer($00000101), integer($04040101), integer($00040000), integer($04000001), + integer($04040001), integer($04000100), integer($00040101), integer($04040000), + integer($00040100), integer($00000000), integer($04000000), integer($00040101), + integer($04040100), integer($00000100), integer($00000001), integer($00040000), + integer($00000101), integer($00040001), integer($04040000), integer($04000101), + integer($00000000), integer($04040100), integer($00040100), integer($04040001), + integer($00040001), integer($04000000), integer($04040101), integer($00000001), + integer($00040101), integer($04000001), integer($04000000), integer($04040101), + integer($00040000), integer($04000100), integer($04000101), integer($00040100), + integer($04000100), integer($00000000), integer($04040001), integer($00000101), + integer($04000001), integer($00040101), integer($00000100), integer($04040000) + ),( + (* nibble 3 *) + integer($00401008), integer($10001000), integer($00000008), integer($10401008), + integer($00000000), integer($10400000), integer($10001008), integer($00400008), + integer($10401000), integer($10000008), integer($10000000), integer($00001008), + integer($10000008), integer($00401008), integer($00400000), integer($10000000), + integer($10400008), integer($00401000), integer($00001000), integer($00000008), + integer($00401000), integer($10001008), integer($10400000), integer($00001000), + integer($00001008), integer($00000000), integer($00400008), integer($10401000), + integer($10001000), integer($10400008), integer($10401008), integer($00400000), + integer($10400008), integer($00001008), integer($00400000), integer($10000008), + integer($00401000), integer($10001000), integer($00000008), integer($10400000), + integer($10001008), integer($00000000), integer($00001000), integer($00400008), + integer($00000000), integer($10400008), integer($10401000), integer($00001000), + integer($10000000), integer($10401008), integer($00401008), integer($00400000), + integer($10401008), integer($00000008), integer($10001000), integer($00401008), + integer($00400008), integer($00401000), integer($10400000), integer($10001008), + integer($00001008), integer($10000000), integer($10000008), integer($10401000) + ),( + (* nibble 4 *) + integer($08000000), integer($00010000), integer($00000400), integer($08010420), + integer($08010020), integer($08000400), integer($00010420), integer($08010000), + integer($00010000), integer($00000020), integer($08000020), integer($00010400), + integer($08000420), integer($08010020), integer($08010400), integer($00000000), + integer($00010400), integer($08000000), integer($00010020), integer($00000420), + integer($08000400), integer($00010420), integer($00000000), integer($08000020), + integer($00000020), integer($08000420), integer($08010420), integer($00010020), + integer($08010000), integer($00000400), integer($00000420), integer($08010400), + integer($08010400), integer($08000420), integer($00010020), integer($08010000), + integer($00010000), integer($00000020), integer($08000020), integer($08000400), + integer($08000000), integer($00010400), integer($08010420), integer($00000000), + integer($00010420), integer($08000000), integer($00000400), integer($00010020), + integer($08000420), integer($00000400), integer($00000000), integer($08010420), + integer($08010020), integer($08010400), integer($00000420), integer($00010000), + integer($00010400), integer($08010020), integer($08000400), integer($00000420), + integer($00000020), integer($00010420), integer($08010000), integer($08000020) + ),( + (* nibble 5 *) + integer($80000040), integer($00200040), integer($00000000), integer($80202000), + integer($00200040), integer($00002000), integer($80002040), integer($00200000), + integer($00002040), integer($80202040), integer($00202000), integer($80000000), + integer($80002000), integer($80000040), integer($80200000), integer($00202040), + integer($00200000), integer($80002040), integer($80200040), integer($00000000), + integer($00002000), integer($00000040), integer($80202000), integer($80200040), + integer($80202040), integer($80200000), integer($80000000), integer($00002040), + integer($00000040), integer($00202000), integer($00202040), integer($80002000), + integer($00002040), integer($80000000), integer($80002000), integer($00202040), + integer($80202000), integer($00200040), integer($00000000), integer($80002000), + integer($80000000), integer($00002000), integer($80200040), integer($00200000), + integer($00200040), integer($80202040), integer($00202000), integer($00000040), + integer($80202040), integer($00202000), integer($00200000), integer($80002040), + integer($80000040), integer($80200000), integer($00202040), integer($00000000), + integer($00002000), integer($80000040), integer($80002040), integer($80202000), + integer($80200000), integer($00002040), integer($00000040), integer($80200040) + ),( + (* nibble 6 *) + integer($00004000), integer($00000200), integer($01000200), integer($01000004), + integer($01004204), integer($00004004), integer($00004200), integer($00000000), + integer($01000000), integer($01000204), integer($00000204), integer($01004000), + integer($00000004), integer($01004200), integer($01004000), integer($00000204), + integer($01000204), integer($00004000), integer($00004004), integer($01004204), + integer($00000000), integer($01000200), integer($01000004), integer($00004200), + integer($01004004), integer($00004204), integer($01004200), integer($00000004), + integer($00004204), integer($01004004), integer($00000200), integer($01000000), + integer($00004204), integer($01004000), integer($01004004), integer($00000204), + integer($00004000), integer($00000200), integer($01000000), integer($01004004), + integer($01000204), integer($00004204), integer($00004200), integer($00000000), + integer($00000200), integer($01000004), integer($00000004), integer($01000200), + integer($00000000), integer($01000204), integer($01000200), integer($00004200), + integer($00000204), integer($00004000), integer($01004204), integer($01000000), + integer($01004200), integer($00000004), integer($00004004), integer($01004204), + integer($01000004), integer($01004200), integer($01004000), integer($00004004) + ),( + (* nibble 7 *) + integer($20800080), integer($20820000), integer($00020080), integer($00000000), + integer($20020000), integer($00800080), integer($20800000), integer($20820080), + integer($00000080), integer($20000000), integer($00820000), integer($00020080), + integer($00820080), integer($20020080), integer($20000080), integer($20800000), + integer($00020000), integer($00820080), integer($00800080), integer($20020000), + integer($20820080), integer($20000080), integer($00000000), integer($00820000), + integer($20000000), integer($00800000), integer($20020080), integer($20800080), + integer($00800000), integer($00020000), integer($20820000), integer($00000080), + integer($00800000), integer($00020000), integer($20000080), integer($20820080), + integer($00020080), integer($20000000), integer($00000000), integer($00820000), + integer($20800080), integer($20020080), integer($20020000), integer($00800080), + integer($20820000), integer($00000080), integer($00800080), integer($20020000), + integer($20820080), integer($00800000), integer($20800000), integer($20000080), + integer($00820000), integer($00020080), integer($20020080), integer($20800000), + integer($00000080), integer($20820000), integer($00820080), integer($00000000), + integer($20000000), integer($20800080), integer($00020000), integer($00820080) + )); + +//AES consts +const + MAXBC= 8; + MAXKC= 8; + + S: array[0..255] of byte= ( + 99, 124, 119, 123, 242, 107, 111, 197, 48, 1, 103, 43, 254, 215, 171, 118, + 202, 130, 201, 125, 250, 89, 71, 240, 173, 212, 162, 175, 156, 164, 114, 192, + 183, 253, 147, 38, 54, 63, 247, 204, 52, 165, 229, 241, 113, 216, 49, 21, + 4, 199, 35, 195, 24, 150, 5, 154, 7, 18, 128, 226, 235, 39, 178, 117, + 9, 131, 44, 26, 27, 110, 90, 160, 82, 59, 214, 179, 41, 227, 47, 132, + 83, 209, 0, 237, 32, 252, 177, 91, 106, 203, 190, 57, 74, 76, 88, 207, + 208, 239, 170, 251, 67, 77, 51, 133, 69, 249, 2, 127, 80, 60, 159, 168, + 81, 163, 64, 143, 146, 157, 56, 245, 188, 182, 218, 33, 16, 255, 243, 210, + 205, 12, 19, 236, 95, 151, 68, 23, 196, 167, 126, 61, 100, 93, 25, 115, + 96, 129, 79, 220, 34, 42, 144, 136, 70, 238, 184, 20, 222, 94, 11, 219, + 224, 50, 58, 10, 73, 6, 36, 92, 194, 211, 172, 98, 145, 149, 228, 121, + 231, 200, 55, 109, 141, 213, 78, 169, 108, 86, 244, 234, 101, 122, 174, 8, + 186, 120, 37, 46, 28, 166, 180, 198, 232, 221, 116, 31, 75, 189, 139, 138, + 112, 62, 181, 102, 72, 3, 246, 14, 97, 53, 87, 185, 134, 193, 29, 158, + 225, 248, 152, 17, 105, 217, 142, 148, 155, 30, 135, 233, 206, 85, 40, 223, + 140, 161, 137, 13, 191, 230, 66, 104, 65, 153, 45, 15, 176, 84, 187, 22); + T1: array[0..255,0..3] of byte= ( + ($c6,$63,$63,$a5), ($f8,$7c,$7c,$84), ($ee,$77,$77,$99), ($f6,$7b,$7b,$8d), + ($ff,$f2,$f2,$0d), ($d6,$6b,$6b,$bd), ($de,$6f,$6f,$b1), ($91,$c5,$c5,$54), + ($60,$30,$30,$50), ($02,$01,$01,$03), ($ce,$67,$67,$a9), ($56,$2b,$2b,$7d), + ($e7,$fe,$fe,$19), ($b5,$d7,$d7,$62), ($4d,$ab,$ab,$e6), ($ec,$76,$76,$9a), + ($8f,$ca,$ca,$45), ($1f,$82,$82,$9d), ($89,$c9,$c9,$40), ($fa,$7d,$7d,$87), + ($ef,$fa,$fa,$15), ($b2,$59,$59,$eb), ($8e,$47,$47,$c9), ($fb,$f0,$f0,$0b), + ($41,$ad,$ad,$ec), ($b3,$d4,$d4,$67), ($5f,$a2,$a2,$fd), ($45,$af,$af,$ea), + ($23,$9c,$9c,$bf), ($53,$a4,$a4,$f7), ($e4,$72,$72,$96), ($9b,$c0,$c0,$5b), + ($75,$b7,$b7,$c2), ($e1,$fd,$fd,$1c), ($3d,$93,$93,$ae), ($4c,$26,$26,$6a), + ($6c,$36,$36,$5a), ($7e,$3f,$3f,$41), ($f5,$f7,$f7,$02), ($83,$cc,$cc,$4f), + ($68,$34,$34,$5c), ($51,$a5,$a5,$f4), ($d1,$e5,$e5,$34), ($f9,$f1,$f1,$08), + ($e2,$71,$71,$93), ($ab,$d8,$d8,$73), ($62,$31,$31,$53), ($2a,$15,$15,$3f), + ($08,$04,$04,$0c), ($95,$c7,$c7,$52), ($46,$23,$23,$65), ($9d,$c3,$c3,$5e), + ($30,$18,$18,$28), ($37,$96,$96,$a1), ($0a,$05,$05,$0f), ($2f,$9a,$9a,$b5), + ($0e,$07,$07,$09), ($24,$12,$12,$36), ($1b,$80,$80,$9b), ($df,$e2,$e2,$3d), + ($cd,$eb,$eb,$26), ($4e,$27,$27,$69), ($7f,$b2,$b2,$cd), ($ea,$75,$75,$9f), + ($12,$09,$09,$1b), ($1d,$83,$83,$9e), ($58,$2c,$2c,$74), ($34,$1a,$1a,$2e), + ($36,$1b,$1b,$2d), ($dc,$6e,$6e,$b2), ($b4,$5a,$5a,$ee), ($5b,$a0,$a0,$fb), + ($a4,$52,$52,$f6), ($76,$3b,$3b,$4d), ($b7,$d6,$d6,$61), ($7d,$b3,$b3,$ce), + ($52,$29,$29,$7b), ($dd,$e3,$e3,$3e), ($5e,$2f,$2f,$71), ($13,$84,$84,$97), + ($a6,$53,$53,$f5), ($b9,$d1,$d1,$68), ($00,$00,$00,$00), ($c1,$ed,$ed,$2c), + ($40,$20,$20,$60), ($e3,$fc,$fc,$1f), ($79,$b1,$b1,$c8), ($b6,$5b,$5b,$ed), + ($d4,$6a,$6a,$be), ($8d,$cb,$cb,$46), ($67,$be,$be,$d9), ($72,$39,$39,$4b), + ($94,$4a,$4a,$de), ($98,$4c,$4c,$d4), ($b0,$58,$58,$e8), ($85,$cf,$cf,$4a), + ($bb,$d0,$d0,$6b), ($c5,$ef,$ef,$2a), ($4f,$aa,$aa,$e5), ($ed,$fb,$fb,$16), + ($86,$43,$43,$c5), ($9a,$4d,$4d,$d7), ($66,$33,$33,$55), ($11,$85,$85,$94), + ($8a,$45,$45,$cf), ($e9,$f9,$f9,$10), ($04,$02,$02,$06), ($fe,$7f,$7f,$81), + ($a0,$50,$50,$f0), ($78,$3c,$3c,$44), ($25,$9f,$9f,$ba), ($4b,$a8,$a8,$e3), + ($a2,$51,$51,$f3), ($5d,$a3,$a3,$fe), ($80,$40,$40,$c0), ($05,$8f,$8f,$8a), + ($3f,$92,$92,$ad), ($21,$9d,$9d,$bc), ($70,$38,$38,$48), ($f1,$f5,$f5,$04), + ($63,$bc,$bc,$df), ($77,$b6,$b6,$c1), ($af,$da,$da,$75), ($42,$21,$21,$63), + ($20,$10,$10,$30), ($e5,$ff,$ff,$1a), ($fd,$f3,$f3,$0e), ($bf,$d2,$d2,$6d), + ($81,$cd,$cd,$4c), ($18,$0c,$0c,$14), ($26,$13,$13,$35), ($c3,$ec,$ec,$2f), + ($be,$5f,$5f,$e1), ($35,$97,$97,$a2), ($88,$44,$44,$cc), ($2e,$17,$17,$39), + ($93,$c4,$c4,$57), ($55,$a7,$a7,$f2), ($fc,$7e,$7e,$82), ($7a,$3d,$3d,$47), + ($c8,$64,$64,$ac), ($ba,$5d,$5d,$e7), ($32,$19,$19,$2b), ($e6,$73,$73,$95), + ($c0,$60,$60,$a0), ($19,$81,$81,$98), ($9e,$4f,$4f,$d1), ($a3,$dc,$dc,$7f), + ($44,$22,$22,$66), ($54,$2a,$2a,$7e), ($3b,$90,$90,$ab), ($0b,$88,$88,$83), + ($8c,$46,$46,$ca), ($c7,$ee,$ee,$29), ($6b,$b8,$b8,$d3), ($28,$14,$14,$3c), + ($a7,$de,$de,$79), ($bc,$5e,$5e,$e2), ($16,$0b,$0b,$1d), ($ad,$db,$db,$76), + ($db,$e0,$e0,$3b), ($64,$32,$32,$56), ($74,$3a,$3a,$4e), ($14,$0a,$0a,$1e), + ($92,$49,$49,$db), ($0c,$06,$06,$0a), ($48,$24,$24,$6c), ($b8,$5c,$5c,$e4), + ($9f,$c2,$c2,$5d), ($bd,$d3,$d3,$6e), ($43,$ac,$ac,$ef), ($c4,$62,$62,$a6), + ($39,$91,$91,$a8), ($31,$95,$95,$a4), ($d3,$e4,$e4,$37), ($f2,$79,$79,$8b), + ($d5,$e7,$e7,$32), ($8b,$c8,$c8,$43), ($6e,$37,$37,$59), ($da,$6d,$6d,$b7), + ($01,$8d,$8d,$8c), ($b1,$d5,$d5,$64), ($9c,$4e,$4e,$d2), ($49,$a9,$a9,$e0), + ($d8,$6c,$6c,$b4), ($ac,$56,$56,$fa), ($f3,$f4,$f4,$07), ($cf,$ea,$ea,$25), + ($ca,$65,$65,$af), ($f4,$7a,$7a,$8e), ($47,$ae,$ae,$e9), ($10,$08,$08,$18), + ($6f,$ba,$ba,$d5), ($f0,$78,$78,$88), ($4a,$25,$25,$6f), ($5c,$2e,$2e,$72), + ($38,$1c,$1c,$24), ($57,$a6,$a6,$f1), ($73,$b4,$b4,$c7), ($97,$c6,$c6,$51), + ($cb,$e8,$e8,$23), ($a1,$dd,$dd,$7c), ($e8,$74,$74,$9c), ($3e,$1f,$1f,$21), + ($96,$4b,$4b,$dd), ($61,$bd,$bd,$dc), ($0d,$8b,$8b,$86), ($0f,$8a,$8a,$85), + ($e0,$70,$70,$90), ($7c,$3e,$3e,$42), ($71,$b5,$b5,$c4), ($cc,$66,$66,$aa), + ($90,$48,$48,$d8), ($06,$03,$03,$05), ($f7,$f6,$f6,$01), ($1c,$0e,$0e,$12), + ($c2,$61,$61,$a3), ($6a,$35,$35,$5f), ($ae,$57,$57,$f9), ($69,$b9,$b9,$d0), + ($17,$86,$86,$91), ($99,$c1,$c1,$58), ($3a,$1d,$1d,$27), ($27,$9e,$9e,$b9), + ($d9,$e1,$e1,$38), ($eb,$f8,$f8,$13), ($2b,$98,$98,$b3), ($22,$11,$11,$33), + ($d2,$69,$69,$bb), ($a9,$d9,$d9,$70), ($07,$8e,$8e,$89), ($33,$94,$94,$a7), + ($2d,$9b,$9b,$b6), ($3c,$1e,$1e,$22), ($15,$87,$87,$92), ($c9,$e9,$e9,$20), + ($87,$ce,$ce,$49), ($aa,$55,$55,$ff), ($50,$28,$28,$78), ($a5,$df,$df,$7a), + ($03,$8c,$8c,$8f), ($59,$a1,$a1,$f8), ($09,$89,$89,$80), ($1a,$0d,$0d,$17), + ($65,$bf,$bf,$da), ($d7,$e6,$e6,$31), ($84,$42,$42,$c6), ($d0,$68,$68,$b8), + ($82,$41,$41,$c3), ($29,$99,$99,$b0), ($5a,$2d,$2d,$77), ($1e,$0f,$0f,$11), + ($7b,$b0,$b0,$cb), ($a8,$54,$54,$fc), ($6d,$bb,$bb,$d6), ($2c,$16,$16,$3a)); + T2: array[0..255,0..3] of byte= ( + ($a5,$c6,$63,$63), ($84,$f8,$7c,$7c), ($99,$ee,$77,$77), ($8d,$f6,$7b,$7b), + ($0d,$ff,$f2,$f2), ($bd,$d6,$6b,$6b), ($b1,$de,$6f,$6f), ($54,$91,$c5,$c5), + ($50,$60,$30,$30), ($03,$02,$01,$01), ($a9,$ce,$67,$67), ($7d,$56,$2b,$2b), + ($19,$e7,$fe,$fe), ($62,$b5,$d7,$d7), ($e6,$4d,$ab,$ab), ($9a,$ec,$76,$76), + ($45,$8f,$ca,$ca), ($9d,$1f,$82,$82), ($40,$89,$c9,$c9), ($87,$fa,$7d,$7d), + ($15,$ef,$fa,$fa), ($eb,$b2,$59,$59), ($c9,$8e,$47,$47), ($0b,$fb,$f0,$f0), + ($ec,$41,$ad,$ad), ($67,$b3,$d4,$d4), ($fd,$5f,$a2,$a2), ($ea,$45,$af,$af), + ($bf,$23,$9c,$9c), ($f7,$53,$a4,$a4), ($96,$e4,$72,$72), ($5b,$9b,$c0,$c0), + ($c2,$75,$b7,$b7), ($1c,$e1,$fd,$fd), ($ae,$3d,$93,$93), ($6a,$4c,$26,$26), + ($5a,$6c,$36,$36), ($41,$7e,$3f,$3f), ($02,$f5,$f7,$f7), ($4f,$83,$cc,$cc), + ($5c,$68,$34,$34), ($f4,$51,$a5,$a5), ($34,$d1,$e5,$e5), ($08,$f9,$f1,$f1), + ($93,$e2,$71,$71), ($73,$ab,$d8,$d8), ($53,$62,$31,$31), ($3f,$2a,$15,$15), + ($0c,$08,$04,$04), ($52,$95,$c7,$c7), ($65,$46,$23,$23), ($5e,$9d,$c3,$c3), + ($28,$30,$18,$18), ($a1,$37,$96,$96), ($0f,$0a,$05,$05), ($b5,$2f,$9a,$9a), + ($09,$0e,$07,$07), ($36,$24,$12,$12), ($9b,$1b,$80,$80), ($3d,$df,$e2,$e2), + ($26,$cd,$eb,$eb), ($69,$4e,$27,$27), ($cd,$7f,$b2,$b2), ($9f,$ea,$75,$75), + ($1b,$12,$09,$09), ($9e,$1d,$83,$83), ($74,$58,$2c,$2c), ($2e,$34,$1a,$1a), + ($2d,$36,$1b,$1b), ($b2,$dc,$6e,$6e), ($ee,$b4,$5a,$5a), ($fb,$5b,$a0,$a0), + ($f6,$a4,$52,$52), ($4d,$76,$3b,$3b), ($61,$b7,$d6,$d6), ($ce,$7d,$b3,$b3), + ($7b,$52,$29,$29), ($3e,$dd,$e3,$e3), ($71,$5e,$2f,$2f), ($97,$13,$84,$84), + ($f5,$a6,$53,$53), ($68,$b9,$d1,$d1), ($00,$00,$00,$00), ($2c,$c1,$ed,$ed), + ($60,$40,$20,$20), ($1f,$e3,$fc,$fc), ($c8,$79,$b1,$b1), ($ed,$b6,$5b,$5b), + ($be,$d4,$6a,$6a), ($46,$8d,$cb,$cb), ($d9,$67,$be,$be), ($4b,$72,$39,$39), + ($de,$94,$4a,$4a), ($d4,$98,$4c,$4c), ($e8,$b0,$58,$58), ($4a,$85,$cf,$cf), + ($6b,$bb,$d0,$d0), ($2a,$c5,$ef,$ef), ($e5,$4f,$aa,$aa), ($16,$ed,$fb,$fb), + ($c5,$86,$43,$43), ($d7,$9a,$4d,$4d), ($55,$66,$33,$33), ($94,$11,$85,$85), + ($cf,$8a,$45,$45), ($10,$e9,$f9,$f9), ($06,$04,$02,$02), ($81,$fe,$7f,$7f), + ($f0,$a0,$50,$50), ($44,$78,$3c,$3c), ($ba,$25,$9f,$9f), ($e3,$4b,$a8,$a8), + ($f3,$a2,$51,$51), ($fe,$5d,$a3,$a3), ($c0,$80,$40,$40), ($8a,$05,$8f,$8f), + ($ad,$3f,$92,$92), ($bc,$21,$9d,$9d), ($48,$70,$38,$38), ($04,$f1,$f5,$f5), + ($df,$63,$bc,$bc), ($c1,$77,$b6,$b6), ($75,$af,$da,$da), ($63,$42,$21,$21), + ($30,$20,$10,$10), ($1a,$e5,$ff,$ff), ($0e,$fd,$f3,$f3), ($6d,$bf,$d2,$d2), + ($4c,$81,$cd,$cd), ($14,$18,$0c,$0c), ($35,$26,$13,$13), ($2f,$c3,$ec,$ec), + ($e1,$be,$5f,$5f), ($a2,$35,$97,$97), ($cc,$88,$44,$44), ($39,$2e,$17,$17), + ($57,$93,$c4,$c4), ($f2,$55,$a7,$a7), ($82,$fc,$7e,$7e), ($47,$7a,$3d,$3d), + ($ac,$c8,$64,$64), ($e7,$ba,$5d,$5d), ($2b,$32,$19,$19), ($95,$e6,$73,$73), + ($a0,$c0,$60,$60), ($98,$19,$81,$81), ($d1,$9e,$4f,$4f), ($7f,$a3,$dc,$dc), + ($66,$44,$22,$22), ($7e,$54,$2a,$2a), ($ab,$3b,$90,$90), ($83,$0b,$88,$88), + ($ca,$8c,$46,$46), ($29,$c7,$ee,$ee), ($d3,$6b,$b8,$b8), ($3c,$28,$14,$14), + ($79,$a7,$de,$de), ($e2,$bc,$5e,$5e), ($1d,$16,$0b,$0b), ($76,$ad,$db,$db), + ($3b,$db,$e0,$e0), ($56,$64,$32,$32), ($4e,$74,$3a,$3a), ($1e,$14,$0a,$0a), + ($db,$92,$49,$49), ($0a,$0c,$06,$06), ($6c,$48,$24,$24), ($e4,$b8,$5c,$5c), + ($5d,$9f,$c2,$c2), ($6e,$bd,$d3,$d3), ($ef,$43,$ac,$ac), ($a6,$c4,$62,$62), + ($a8,$39,$91,$91), ($a4,$31,$95,$95), ($37,$d3,$e4,$e4), ($8b,$f2,$79,$79), + ($32,$d5,$e7,$e7), ($43,$8b,$c8,$c8), ($59,$6e,$37,$37), ($b7,$da,$6d,$6d), + ($8c,$01,$8d,$8d), ($64,$b1,$d5,$d5), ($d2,$9c,$4e,$4e), ($e0,$49,$a9,$a9), + ($b4,$d8,$6c,$6c), ($fa,$ac,$56,$56), ($07,$f3,$f4,$f4), ($25,$cf,$ea,$ea), + ($af,$ca,$65,$65), ($8e,$f4,$7a,$7a), ($e9,$47,$ae,$ae), ($18,$10,$08,$08), + ($d5,$6f,$ba,$ba), ($88,$f0,$78,$78), ($6f,$4a,$25,$25), ($72,$5c,$2e,$2e), + ($24,$38,$1c,$1c), ($f1,$57,$a6,$a6), ($c7,$73,$b4,$b4), ($51,$97,$c6,$c6), + ($23,$cb,$e8,$e8), ($7c,$a1,$dd,$dd), ($9c,$e8,$74,$74), ($21,$3e,$1f,$1f), + ($dd,$96,$4b,$4b), ($dc,$61,$bd,$bd), ($86,$0d,$8b,$8b), ($85,$0f,$8a,$8a), + ($90,$e0,$70,$70), ($42,$7c,$3e,$3e), ($c4,$71,$b5,$b5), ($aa,$cc,$66,$66), + ($d8,$90,$48,$48), ($05,$06,$03,$03), ($01,$f7,$f6,$f6), ($12,$1c,$0e,$0e), + ($a3,$c2,$61,$61), ($5f,$6a,$35,$35), ($f9,$ae,$57,$57), ($d0,$69,$b9,$b9), + ($91,$17,$86,$86), ($58,$99,$c1,$c1), ($27,$3a,$1d,$1d), ($b9,$27,$9e,$9e), + ($38,$d9,$e1,$e1), ($13,$eb,$f8,$f8), ($b3,$2b,$98,$98), ($33,$22,$11,$11), + ($bb,$d2,$69,$69), ($70,$a9,$d9,$d9), ($89,$07,$8e,$8e), ($a7,$33,$94,$94), + ($b6,$2d,$9b,$9b), ($22,$3c,$1e,$1e), ($92,$15,$87,$87), ($20,$c9,$e9,$e9), + ($49,$87,$ce,$ce), ($ff,$aa,$55,$55), ($78,$50,$28,$28), ($7a,$a5,$df,$df), + ($8f,$03,$8c,$8c), ($f8,$59,$a1,$a1), ($80,$09,$89,$89), ($17,$1a,$0d,$0d), + ($da,$65,$bf,$bf), ($31,$d7,$e6,$e6), ($c6,$84,$42,$42), ($b8,$d0,$68,$68), + ($c3,$82,$41,$41), ($b0,$29,$99,$99), ($77,$5a,$2d,$2d), ($11,$1e,$0f,$0f), + ($cb,$7b,$b0,$b0), ($fc,$a8,$54,$54), ($d6,$6d,$bb,$bb), ($3a,$2c,$16,$16)); + T3: array[0..255,0..3] of byte= ( + ($63,$a5,$c6,$63), ($7c,$84,$f8,$7c), ($77,$99,$ee,$77), ($7b,$8d,$f6,$7b), + ($f2,$0d,$ff,$f2), ($6b,$bd,$d6,$6b), ($6f,$b1,$de,$6f), ($c5,$54,$91,$c5), + ($30,$50,$60,$30), ($01,$03,$02,$01), ($67,$a9,$ce,$67), ($2b,$7d,$56,$2b), + ($fe,$19,$e7,$fe), ($d7,$62,$b5,$d7), ($ab,$e6,$4d,$ab), ($76,$9a,$ec,$76), + ($ca,$45,$8f,$ca), ($82,$9d,$1f,$82), ($c9,$40,$89,$c9), ($7d,$87,$fa,$7d), + ($fa,$15,$ef,$fa), ($59,$eb,$b2,$59), ($47,$c9,$8e,$47), ($f0,$0b,$fb,$f0), + ($ad,$ec,$41,$ad), ($d4,$67,$b3,$d4), ($a2,$fd,$5f,$a2), ($af,$ea,$45,$af), + ($9c,$bf,$23,$9c), ($a4,$f7,$53,$a4), ($72,$96,$e4,$72), ($c0,$5b,$9b,$c0), + ($b7,$c2,$75,$b7), ($fd,$1c,$e1,$fd), ($93,$ae,$3d,$93), ($26,$6a,$4c,$26), + ($36,$5a,$6c,$36), ($3f,$41,$7e,$3f), ($f7,$02,$f5,$f7), ($cc,$4f,$83,$cc), + ($34,$5c,$68,$34), ($a5,$f4,$51,$a5), ($e5,$34,$d1,$e5), ($f1,$08,$f9,$f1), + ($71,$93,$e2,$71), ($d8,$73,$ab,$d8), ($31,$53,$62,$31), ($15,$3f,$2a,$15), + ($04,$0c,$08,$04), ($c7,$52,$95,$c7), ($23,$65,$46,$23), ($c3,$5e,$9d,$c3), + ($18,$28,$30,$18), ($96,$a1,$37,$96), ($05,$0f,$0a,$05), ($9a,$b5,$2f,$9a), + ($07,$09,$0e,$07), ($12,$36,$24,$12), ($80,$9b,$1b,$80), ($e2,$3d,$df,$e2), + ($eb,$26,$cd,$eb), ($27,$69,$4e,$27), ($b2,$cd,$7f,$b2), ($75,$9f,$ea,$75), + ($09,$1b,$12,$09), ($83,$9e,$1d,$83), ($2c,$74,$58,$2c), ($1a,$2e,$34,$1a), + ($1b,$2d,$36,$1b), ($6e,$b2,$dc,$6e), ($5a,$ee,$b4,$5a), ($a0,$fb,$5b,$a0), + ($52,$f6,$a4,$52), ($3b,$4d,$76,$3b), ($d6,$61,$b7,$d6), ($b3,$ce,$7d,$b3), + ($29,$7b,$52,$29), ($e3,$3e,$dd,$e3), ($2f,$71,$5e,$2f), ($84,$97,$13,$84), + ($53,$f5,$a6,$53), ($d1,$68,$b9,$d1), ($00,$00,$00,$00), ($ed,$2c,$c1,$ed), + ($20,$60,$40,$20), ($fc,$1f,$e3,$fc), ($b1,$c8,$79,$b1), ($5b,$ed,$b6,$5b), + ($6a,$be,$d4,$6a), ($cb,$46,$8d,$cb), ($be,$d9,$67,$be), ($39,$4b,$72,$39), + ($4a,$de,$94,$4a), ($4c,$d4,$98,$4c), ($58,$e8,$b0,$58), ($cf,$4a,$85,$cf), + ($d0,$6b,$bb,$d0), ($ef,$2a,$c5,$ef), ($aa,$e5,$4f,$aa), ($fb,$16,$ed,$fb), + ($43,$c5,$86,$43), ($4d,$d7,$9a,$4d), ($33,$55,$66,$33), ($85,$94,$11,$85), + ($45,$cf,$8a,$45), ($f9,$10,$e9,$f9), ($02,$06,$04,$02), ($7f,$81,$fe,$7f), + ($50,$f0,$a0,$50), ($3c,$44,$78,$3c), ($9f,$ba,$25,$9f), ($a8,$e3,$4b,$a8), + ($51,$f3,$a2,$51), ($a3,$fe,$5d,$a3), ($40,$c0,$80,$40), ($8f,$8a,$05,$8f), + ($92,$ad,$3f,$92), ($9d,$bc,$21,$9d), ($38,$48,$70,$38), ($f5,$04,$f1,$f5), + ($bc,$df,$63,$bc), ($b6,$c1,$77,$b6), ($da,$75,$af,$da), ($21,$63,$42,$21), + ($10,$30,$20,$10), ($ff,$1a,$e5,$ff), ($f3,$0e,$fd,$f3), ($d2,$6d,$bf,$d2), + ($cd,$4c,$81,$cd), ($0c,$14,$18,$0c), ($13,$35,$26,$13), ($ec,$2f,$c3,$ec), + ($5f,$e1,$be,$5f), ($97,$a2,$35,$97), ($44,$cc,$88,$44), ($17,$39,$2e,$17), + ($c4,$57,$93,$c4), ($a7,$f2,$55,$a7), ($7e,$82,$fc,$7e), ($3d,$47,$7a,$3d), + ($64,$ac,$c8,$64), ($5d,$e7,$ba,$5d), ($19,$2b,$32,$19), ($73,$95,$e6,$73), + ($60,$a0,$c0,$60), ($81,$98,$19,$81), ($4f,$d1,$9e,$4f), ($dc,$7f,$a3,$dc), + ($22,$66,$44,$22), ($2a,$7e,$54,$2a), ($90,$ab,$3b,$90), ($88,$83,$0b,$88), + ($46,$ca,$8c,$46), ($ee,$29,$c7,$ee), ($b8,$d3,$6b,$b8), ($14,$3c,$28,$14), + ($de,$79,$a7,$de), ($5e,$e2,$bc,$5e), ($0b,$1d,$16,$0b), ($db,$76,$ad,$db), + ($e0,$3b,$db,$e0), ($32,$56,$64,$32), ($3a,$4e,$74,$3a), ($0a,$1e,$14,$0a), + ($49,$db,$92,$49), ($06,$0a,$0c,$06), ($24,$6c,$48,$24), ($5c,$e4,$b8,$5c), + ($c2,$5d,$9f,$c2), ($d3,$6e,$bd,$d3), ($ac,$ef,$43,$ac), ($62,$a6,$c4,$62), + ($91,$a8,$39,$91), ($95,$a4,$31,$95), ($e4,$37,$d3,$e4), ($79,$8b,$f2,$79), + ($e7,$32,$d5,$e7), ($c8,$43,$8b,$c8), ($37,$59,$6e,$37), ($6d,$b7,$da,$6d), + ($8d,$8c,$01,$8d), ($d5,$64,$b1,$d5), ($4e,$d2,$9c,$4e), ($a9,$e0,$49,$a9), + ($6c,$b4,$d8,$6c), ($56,$fa,$ac,$56), ($f4,$07,$f3,$f4), ($ea,$25,$cf,$ea), + ($65,$af,$ca,$65), ($7a,$8e,$f4,$7a), ($ae,$e9,$47,$ae), ($08,$18,$10,$08), + ($ba,$d5,$6f,$ba), ($78,$88,$f0,$78), ($25,$6f,$4a,$25), ($2e,$72,$5c,$2e), + ($1c,$24,$38,$1c), ($a6,$f1,$57,$a6), ($b4,$c7,$73,$b4), ($c6,$51,$97,$c6), + ($e8,$23,$cb,$e8), ($dd,$7c,$a1,$dd), ($74,$9c,$e8,$74), ($1f,$21,$3e,$1f), + ($4b,$dd,$96,$4b), ($bd,$dc,$61,$bd), ($8b,$86,$0d,$8b), ($8a,$85,$0f,$8a), + ($70,$90,$e0,$70), ($3e,$42,$7c,$3e), ($b5,$c4,$71,$b5), ($66,$aa,$cc,$66), + ($48,$d8,$90,$48), ($03,$05,$06,$03), ($f6,$01,$f7,$f6), ($0e,$12,$1c,$0e), + ($61,$a3,$c2,$61), ($35,$5f,$6a,$35), ($57,$f9,$ae,$57), ($b9,$d0,$69,$b9), + ($86,$91,$17,$86), ($c1,$58,$99,$c1), ($1d,$27,$3a,$1d), ($9e,$b9,$27,$9e), + ($e1,$38,$d9,$e1), ($f8,$13,$eb,$f8), ($98,$b3,$2b,$98), ($11,$33,$22,$11), + ($69,$bb,$d2,$69), ($d9,$70,$a9,$d9), ($8e,$89,$07,$8e), ($94,$a7,$33,$94), + ($9b,$b6,$2d,$9b), ($1e,$22,$3c,$1e), ($87,$92,$15,$87), ($e9,$20,$c9,$e9), + ($ce,$49,$87,$ce), ($55,$ff,$aa,$55), ($28,$78,$50,$28), ($df,$7a,$a5,$df), + ($8c,$8f,$03,$8c), ($a1,$f8,$59,$a1), ($89,$80,$09,$89), ($0d,$17,$1a,$0d), + ($bf,$da,$65,$bf), ($e6,$31,$d7,$e6), ($42,$c6,$84,$42), ($68,$b8,$d0,$68), + ($41,$c3,$82,$41), ($99,$b0,$29,$99), ($2d,$77,$5a,$2d), ($0f,$11,$1e,$0f), + ($b0,$cb,$7b,$b0), ($54,$fc,$a8,$54), ($bb,$d6,$6d,$bb), ($16,$3a,$2c,$16)); + T4: array[0..255,0..3] of byte= ( + ($63,$63,$a5,$c6), ($7c,$7c,$84,$f8), ($77,$77,$99,$ee), ($7b,$7b,$8d,$f6), + ($f2,$f2,$0d,$ff), ($6b,$6b,$bd,$d6), ($6f,$6f,$b1,$de), ($c5,$c5,$54,$91), + ($30,$30,$50,$60), ($01,$01,$03,$02), ($67,$67,$a9,$ce), ($2b,$2b,$7d,$56), + ($fe,$fe,$19,$e7), ($d7,$d7,$62,$b5), ($ab,$ab,$e6,$4d), ($76,$76,$9a,$ec), + ($ca,$ca,$45,$8f), ($82,$82,$9d,$1f), ($c9,$c9,$40,$89), ($7d,$7d,$87,$fa), + ($fa,$fa,$15,$ef), ($59,$59,$eb,$b2), ($47,$47,$c9,$8e), ($f0,$f0,$0b,$fb), + ($ad,$ad,$ec,$41), ($d4,$d4,$67,$b3), ($a2,$a2,$fd,$5f), ($af,$af,$ea,$45), + ($9c,$9c,$bf,$23), ($a4,$a4,$f7,$53), ($72,$72,$96,$e4), ($c0,$c0,$5b,$9b), + ($b7,$b7,$c2,$75), ($fd,$fd,$1c,$e1), ($93,$93,$ae,$3d), ($26,$26,$6a,$4c), + ($36,$36,$5a,$6c), ($3f,$3f,$41,$7e), ($f7,$f7,$02,$f5), ($cc,$cc,$4f,$83), + ($34,$34,$5c,$68), ($a5,$a5,$f4,$51), ($e5,$e5,$34,$d1), ($f1,$f1,$08,$f9), + ($71,$71,$93,$e2), ($d8,$d8,$73,$ab), ($31,$31,$53,$62), ($15,$15,$3f,$2a), + ($04,$04,$0c,$08), ($c7,$c7,$52,$95), ($23,$23,$65,$46), ($c3,$c3,$5e,$9d), + ($18,$18,$28,$30), ($96,$96,$a1,$37), ($05,$05,$0f,$0a), ($9a,$9a,$b5,$2f), + ($07,$07,$09,$0e), ($12,$12,$36,$24), ($80,$80,$9b,$1b), ($e2,$e2,$3d,$df), + ($eb,$eb,$26,$cd), ($27,$27,$69,$4e), ($b2,$b2,$cd,$7f), ($75,$75,$9f,$ea), + ($09,$09,$1b,$12), ($83,$83,$9e,$1d), ($2c,$2c,$74,$58), ($1a,$1a,$2e,$34), + ($1b,$1b,$2d,$36), ($6e,$6e,$b2,$dc), ($5a,$5a,$ee,$b4), ($a0,$a0,$fb,$5b), + ($52,$52,$f6,$a4), ($3b,$3b,$4d,$76), ($d6,$d6,$61,$b7), ($b3,$b3,$ce,$7d), + ($29,$29,$7b,$52), ($e3,$e3,$3e,$dd), ($2f,$2f,$71,$5e), ($84,$84,$97,$13), + ($53,$53,$f5,$a6), ($d1,$d1,$68,$b9), ($00,$00,$00,$00), ($ed,$ed,$2c,$c1), + ($20,$20,$60,$40), ($fc,$fc,$1f,$e3), ($b1,$b1,$c8,$79), ($5b,$5b,$ed,$b6), + ($6a,$6a,$be,$d4), ($cb,$cb,$46,$8d), ($be,$be,$d9,$67), ($39,$39,$4b,$72), + ($4a,$4a,$de,$94), ($4c,$4c,$d4,$98), ($58,$58,$e8,$b0), ($cf,$cf,$4a,$85), + ($d0,$d0,$6b,$bb), ($ef,$ef,$2a,$c5), ($aa,$aa,$e5,$4f), ($fb,$fb,$16,$ed), + ($43,$43,$c5,$86), ($4d,$4d,$d7,$9a), ($33,$33,$55,$66), ($85,$85,$94,$11), + ($45,$45,$cf,$8a), ($f9,$f9,$10,$e9), ($02,$02,$06,$04), ($7f,$7f,$81,$fe), + ($50,$50,$f0,$a0), ($3c,$3c,$44,$78), ($9f,$9f,$ba,$25), ($a8,$a8,$e3,$4b), + ($51,$51,$f3,$a2), ($a3,$a3,$fe,$5d), ($40,$40,$c0,$80), ($8f,$8f,$8a,$05), + ($92,$92,$ad,$3f), ($9d,$9d,$bc,$21), ($38,$38,$48,$70), ($f5,$f5,$04,$f1), + ($bc,$bc,$df,$63), ($b6,$b6,$c1,$77), ($da,$da,$75,$af), ($21,$21,$63,$42), + ($10,$10,$30,$20), ($ff,$ff,$1a,$e5), ($f3,$f3,$0e,$fd), ($d2,$d2,$6d,$bf), + ($cd,$cd,$4c,$81), ($0c,$0c,$14,$18), ($13,$13,$35,$26), ($ec,$ec,$2f,$c3), + ($5f,$5f,$e1,$be), ($97,$97,$a2,$35), ($44,$44,$cc,$88), ($17,$17,$39,$2e), + ($c4,$c4,$57,$93), ($a7,$a7,$f2,$55), ($7e,$7e,$82,$fc), ($3d,$3d,$47,$7a), + ($64,$64,$ac,$c8), ($5d,$5d,$e7,$ba), ($19,$19,$2b,$32), ($73,$73,$95,$e6), + ($60,$60,$a0,$c0), ($81,$81,$98,$19), ($4f,$4f,$d1,$9e), ($dc,$dc,$7f,$a3), + ($22,$22,$66,$44), ($2a,$2a,$7e,$54), ($90,$90,$ab,$3b), ($88,$88,$83,$0b), + ($46,$46,$ca,$8c), ($ee,$ee,$29,$c7), ($b8,$b8,$d3,$6b), ($14,$14,$3c,$28), + ($de,$de,$79,$a7), ($5e,$5e,$e2,$bc), ($0b,$0b,$1d,$16), ($db,$db,$76,$ad), + ($e0,$e0,$3b,$db), ($32,$32,$56,$64), ($3a,$3a,$4e,$74), ($0a,$0a,$1e,$14), + ($49,$49,$db,$92), ($06,$06,$0a,$0c), ($24,$24,$6c,$48), ($5c,$5c,$e4,$b8), + ($c2,$c2,$5d,$9f), ($d3,$d3,$6e,$bd), ($ac,$ac,$ef,$43), ($62,$62,$a6,$c4), + ($91,$91,$a8,$39), ($95,$95,$a4,$31), ($e4,$e4,$37,$d3), ($79,$79,$8b,$f2), + ($e7,$e7,$32,$d5), ($c8,$c8,$43,$8b), ($37,$37,$59,$6e), ($6d,$6d,$b7,$da), + ($8d,$8d,$8c,$01), ($d5,$d5,$64,$b1), ($4e,$4e,$d2,$9c), ($a9,$a9,$e0,$49), + ($6c,$6c,$b4,$d8), ($56,$56,$fa,$ac), ($f4,$f4,$07,$f3), ($ea,$ea,$25,$cf), + ($65,$65,$af,$ca), ($7a,$7a,$8e,$f4), ($ae,$ae,$e9,$47), ($08,$08,$18,$10), + ($ba,$ba,$d5,$6f), ($78,$78,$88,$f0), ($25,$25,$6f,$4a), ($2e,$2e,$72,$5c), + ($1c,$1c,$24,$38), ($a6,$a6,$f1,$57), ($b4,$b4,$c7,$73), ($c6,$c6,$51,$97), + ($e8,$e8,$23,$cb), ($dd,$dd,$7c,$a1), ($74,$74,$9c,$e8), ($1f,$1f,$21,$3e), + ($4b,$4b,$dd,$96), ($bd,$bd,$dc,$61), ($8b,$8b,$86,$0d), ($8a,$8a,$85,$0f), + ($70,$70,$90,$e0), ($3e,$3e,$42,$7c), ($b5,$b5,$c4,$71), ($66,$66,$aa,$cc), + ($48,$48,$d8,$90), ($03,$03,$05,$06), ($f6,$f6,$01,$f7), ($0e,$0e,$12,$1c), + ($61,$61,$a3,$c2), ($35,$35,$5f,$6a), ($57,$57,$f9,$ae), ($b9,$b9,$d0,$69), + ($86,$86,$91,$17), ($c1,$c1,$58,$99), ($1d,$1d,$27,$3a), ($9e,$9e,$b9,$27), + ($e1,$e1,$38,$d9), ($f8,$f8,$13,$eb), ($98,$98,$b3,$2b), ($11,$11,$33,$22), + ($69,$69,$bb,$d2), ($d9,$d9,$70,$a9), ($8e,$8e,$89,$07), ($94,$94,$a7,$33), + ($9b,$9b,$b6,$2d), ($1e,$1e,$22,$3c), ($87,$87,$92,$15), ($e9,$e9,$20,$c9), + ($ce,$ce,$49,$87), ($55,$55,$ff,$aa), ($28,$28,$78,$50), ($df,$df,$7a,$a5), + ($8c,$8c,$8f,$03), ($a1,$a1,$f8,$59), ($89,$89,$80,$09), ($0d,$0d,$17,$1a), + ($bf,$bf,$da,$65), ($e6,$e6,$31,$d7), ($42,$42,$c6,$84), ($68,$68,$b8,$d0), + ($41,$41,$c3,$82), ($99,$99,$b0,$29), ($2d,$2d,$77,$5a), ($0f,$0f,$11,$1e), + ($b0,$b0,$cb,$7b), ($54,$54,$fc,$a8), ($bb,$bb,$d6,$6d), ($16,$16,$3a,$2c)); + T5: array[0..255,0..3] of byte= ( + ($51,$f4,$a7,$50), ($7e,$41,$65,$53), ($1a,$17,$a4,$c3), ($3a,$27,$5e,$96), + ($3b,$ab,$6b,$cb), ($1f,$9d,$45,$f1), ($ac,$fa,$58,$ab), ($4b,$e3,$03,$93), + ($20,$30,$fa,$55), ($ad,$76,$6d,$f6), ($88,$cc,$76,$91), ($f5,$02,$4c,$25), + ($4f,$e5,$d7,$fc), ($c5,$2a,$cb,$d7), ($26,$35,$44,$80), ($b5,$62,$a3,$8f), + ($de,$b1,$5a,$49), ($25,$ba,$1b,$67), ($45,$ea,$0e,$98), ($5d,$fe,$c0,$e1), + ($c3,$2f,$75,$02), ($81,$4c,$f0,$12), ($8d,$46,$97,$a3), ($6b,$d3,$f9,$c6), + ($03,$8f,$5f,$e7), ($15,$92,$9c,$95), ($bf,$6d,$7a,$eb), ($95,$52,$59,$da), + ($d4,$be,$83,$2d), ($58,$74,$21,$d3), ($49,$e0,$69,$29), ($8e,$c9,$c8,$44), + ($75,$c2,$89,$6a), ($f4,$8e,$79,$78), ($99,$58,$3e,$6b), ($27,$b9,$71,$dd), + ($be,$e1,$4f,$b6), ($f0,$88,$ad,$17), ($c9,$20,$ac,$66), ($7d,$ce,$3a,$b4), + ($63,$df,$4a,$18), ($e5,$1a,$31,$82), ($97,$51,$33,$60), ($62,$53,$7f,$45), + ($b1,$64,$77,$e0), ($bb,$6b,$ae,$84), ($fe,$81,$a0,$1c), ($f9,$08,$2b,$94), + ($70,$48,$68,$58), ($8f,$45,$fd,$19), ($94,$de,$6c,$87), ($52,$7b,$f8,$b7), + ($ab,$73,$d3,$23), ($72,$4b,$02,$e2), ($e3,$1f,$8f,$57), ($66,$55,$ab,$2a), + ($b2,$eb,$28,$07), ($2f,$b5,$c2,$03), ($86,$c5,$7b,$9a), ($d3,$37,$08,$a5), + ($30,$28,$87,$f2), ($23,$bf,$a5,$b2), ($02,$03,$6a,$ba), ($ed,$16,$82,$5c), + ($8a,$cf,$1c,$2b), ($a7,$79,$b4,$92), ($f3,$07,$f2,$f0), ($4e,$69,$e2,$a1), + ($65,$da,$f4,$cd), ($06,$05,$be,$d5), ($d1,$34,$62,$1f), ($c4,$a6,$fe,$8a), + ($34,$2e,$53,$9d), ($a2,$f3,$55,$a0), ($05,$8a,$e1,$32), ($a4,$f6,$eb,$75), + ($0b,$83,$ec,$39), ($40,$60,$ef,$aa), ($5e,$71,$9f,$06), ($bd,$6e,$10,$51), + ($3e,$21,$8a,$f9), ($96,$dd,$06,$3d), ($dd,$3e,$05,$ae), ($4d,$e6,$bd,$46), + ($91,$54,$8d,$b5), ($71,$c4,$5d,$05), ($04,$06,$d4,$6f), ($60,$50,$15,$ff), + ($19,$98,$fb,$24), ($d6,$bd,$e9,$97), ($89,$40,$43,$cc), ($67,$d9,$9e,$77), + ($b0,$e8,$42,$bd), ($07,$89,$8b,$88), ($e7,$19,$5b,$38), ($79,$c8,$ee,$db), + ($a1,$7c,$0a,$47), ($7c,$42,$0f,$e9), ($f8,$84,$1e,$c9), ($00,$00,$00,$00), + ($09,$80,$86,$83), ($32,$2b,$ed,$48), ($1e,$11,$70,$ac), ($6c,$5a,$72,$4e), + ($fd,$0e,$ff,$fb), ($0f,$85,$38,$56), ($3d,$ae,$d5,$1e), ($36,$2d,$39,$27), + ($0a,$0f,$d9,$64), ($68,$5c,$a6,$21), ($9b,$5b,$54,$d1), ($24,$36,$2e,$3a), + ($0c,$0a,$67,$b1), ($93,$57,$e7,$0f), ($b4,$ee,$96,$d2), ($1b,$9b,$91,$9e), + ($80,$c0,$c5,$4f), ($61,$dc,$20,$a2), ($5a,$77,$4b,$69), ($1c,$12,$1a,$16), + ($e2,$93,$ba,$0a), ($c0,$a0,$2a,$e5), ($3c,$22,$e0,$43), ($12,$1b,$17,$1d), + ($0e,$09,$0d,$0b), ($f2,$8b,$c7,$ad), ($2d,$b6,$a8,$b9), ($14,$1e,$a9,$c8), + ($57,$f1,$19,$85), ($af,$75,$07,$4c), ($ee,$99,$dd,$bb), ($a3,$7f,$60,$fd), + ($f7,$01,$26,$9f), ($5c,$72,$f5,$bc), ($44,$66,$3b,$c5), ($5b,$fb,$7e,$34), + ($8b,$43,$29,$76), ($cb,$23,$c6,$dc), ($b6,$ed,$fc,$68), ($b8,$e4,$f1,$63), + ($d7,$31,$dc,$ca), ($42,$63,$85,$10), ($13,$97,$22,$40), ($84,$c6,$11,$20), + ($85,$4a,$24,$7d), ($d2,$bb,$3d,$f8), ($ae,$f9,$32,$11), ($c7,$29,$a1,$6d), + ($1d,$9e,$2f,$4b), ($dc,$b2,$30,$f3), ($0d,$86,$52,$ec), ($77,$c1,$e3,$d0), + ($2b,$b3,$16,$6c), ($a9,$70,$b9,$99), ($11,$94,$48,$fa), ($47,$e9,$64,$22), + ($a8,$fc,$8c,$c4), ($a0,$f0,$3f,$1a), ($56,$7d,$2c,$d8), ($22,$33,$90,$ef), + ($87,$49,$4e,$c7), ($d9,$38,$d1,$c1), ($8c,$ca,$a2,$fe), ($98,$d4,$0b,$36), + ($a6,$f5,$81,$cf), ($a5,$7a,$de,$28), ($da,$b7,$8e,$26), ($3f,$ad,$bf,$a4), + ($2c,$3a,$9d,$e4), ($50,$78,$92,$0d), ($6a,$5f,$cc,$9b), ($54,$7e,$46,$62), + ($f6,$8d,$13,$c2), ($90,$d8,$b8,$e8), ($2e,$39,$f7,$5e), ($82,$c3,$af,$f5), + ($9f,$5d,$80,$be), ($69,$d0,$93,$7c), ($6f,$d5,$2d,$a9), ($cf,$25,$12,$b3), + ($c8,$ac,$99,$3b), ($10,$18,$7d,$a7), ($e8,$9c,$63,$6e), ($db,$3b,$bb,$7b), + ($cd,$26,$78,$09), ($6e,$59,$18,$f4), ($ec,$9a,$b7,$01), ($83,$4f,$9a,$a8), + ($e6,$95,$6e,$65), ($aa,$ff,$e6,$7e), ($21,$bc,$cf,$08), ($ef,$15,$e8,$e6), + ($ba,$e7,$9b,$d9), ($4a,$6f,$36,$ce), ($ea,$9f,$09,$d4), ($29,$b0,$7c,$d6), + ($31,$a4,$b2,$af), ($2a,$3f,$23,$31), ($c6,$a5,$94,$30), ($35,$a2,$66,$c0), + ($74,$4e,$bc,$37), ($fc,$82,$ca,$a6), ($e0,$90,$d0,$b0), ($33,$a7,$d8,$15), + ($f1,$04,$98,$4a), ($41,$ec,$da,$f7), ($7f,$cd,$50,$0e), ($17,$91,$f6,$2f), + ($76,$4d,$d6,$8d), ($43,$ef,$b0,$4d), ($cc,$aa,$4d,$54), ($e4,$96,$04,$df), + ($9e,$d1,$b5,$e3), ($4c,$6a,$88,$1b), ($c1,$2c,$1f,$b8), ($46,$65,$51,$7f), + ($9d,$5e,$ea,$04), ($01,$8c,$35,$5d), ($fa,$87,$74,$73), ($fb,$0b,$41,$2e), + ($b3,$67,$1d,$5a), ($92,$db,$d2,$52), ($e9,$10,$56,$33), ($6d,$d6,$47,$13), + ($9a,$d7,$61,$8c), ($37,$a1,$0c,$7a), ($59,$f8,$14,$8e), ($eb,$13,$3c,$89), + ($ce,$a9,$27,$ee), ($b7,$61,$c9,$35), ($e1,$1c,$e5,$ed), ($7a,$47,$b1,$3c), + ($9c,$d2,$df,$59), ($55,$f2,$73,$3f), ($18,$14,$ce,$79), ($73,$c7,$37,$bf), + ($53,$f7,$cd,$ea), ($5f,$fd,$aa,$5b), ($df,$3d,$6f,$14), ($78,$44,$db,$86), + ($ca,$af,$f3,$81), ($b9,$68,$c4,$3e), ($38,$24,$34,$2c), ($c2,$a3,$40,$5f), + ($16,$1d,$c3,$72), ($bc,$e2,$25,$0c), ($28,$3c,$49,$8b), ($ff,$0d,$95,$41), + ($39,$a8,$01,$71), ($08,$0c,$b3,$de), ($d8,$b4,$e4,$9c), ($64,$56,$c1,$90), + ($7b,$cb,$84,$61), ($d5,$32,$b6,$70), ($48,$6c,$5c,$74), ($d0,$b8,$57,$42)); + T6: array[0..255,0..3] of byte= ( + ($50,$51,$f4,$a7), ($53,$7e,$41,$65), ($c3,$1a,$17,$a4), ($96,$3a,$27,$5e), + ($cb,$3b,$ab,$6b), ($f1,$1f,$9d,$45), ($ab,$ac,$fa,$58), ($93,$4b,$e3,$03), + ($55,$20,$30,$fa), ($f6,$ad,$76,$6d), ($91,$88,$cc,$76), ($25,$f5,$02,$4c), + ($fc,$4f,$e5,$d7), ($d7,$c5,$2a,$cb), ($80,$26,$35,$44), ($8f,$b5,$62,$a3), + ($49,$de,$b1,$5a), ($67,$25,$ba,$1b), ($98,$45,$ea,$0e), ($e1,$5d,$fe,$c0), + ($02,$c3,$2f,$75), ($12,$81,$4c,$f0), ($a3,$8d,$46,$97), ($c6,$6b,$d3,$f9), + ($e7,$03,$8f,$5f), ($95,$15,$92,$9c), ($eb,$bf,$6d,$7a), ($da,$95,$52,$59), + ($2d,$d4,$be,$83), ($d3,$58,$74,$21), ($29,$49,$e0,$69), ($44,$8e,$c9,$c8), + ($6a,$75,$c2,$89), ($78,$f4,$8e,$79), ($6b,$99,$58,$3e), ($dd,$27,$b9,$71), + ($b6,$be,$e1,$4f), ($17,$f0,$88,$ad), ($66,$c9,$20,$ac), ($b4,$7d,$ce,$3a), + ($18,$63,$df,$4a), ($82,$e5,$1a,$31), ($60,$97,$51,$33), ($45,$62,$53,$7f), + ($e0,$b1,$64,$77), ($84,$bb,$6b,$ae), ($1c,$fe,$81,$a0), ($94,$f9,$08,$2b), + ($58,$70,$48,$68), ($19,$8f,$45,$fd), ($87,$94,$de,$6c), ($b7,$52,$7b,$f8), + ($23,$ab,$73,$d3), ($e2,$72,$4b,$02), ($57,$e3,$1f,$8f), ($2a,$66,$55,$ab), + ($07,$b2,$eb,$28), ($03,$2f,$b5,$c2), ($9a,$86,$c5,$7b), ($a5,$d3,$37,$08), + ($f2,$30,$28,$87), ($b2,$23,$bf,$a5), ($ba,$02,$03,$6a), ($5c,$ed,$16,$82), + ($2b,$8a,$cf,$1c), ($92,$a7,$79,$b4), ($f0,$f3,$07,$f2), ($a1,$4e,$69,$e2), + ($cd,$65,$da,$f4), ($d5,$06,$05,$be), ($1f,$d1,$34,$62), ($8a,$c4,$a6,$fe), + ($9d,$34,$2e,$53), ($a0,$a2,$f3,$55), ($32,$05,$8a,$e1), ($75,$a4,$f6,$eb), + ($39,$0b,$83,$ec), ($aa,$40,$60,$ef), ($06,$5e,$71,$9f), ($51,$bd,$6e,$10), + ($f9,$3e,$21,$8a), ($3d,$96,$dd,$06), ($ae,$dd,$3e,$05), ($46,$4d,$e6,$bd), + ($b5,$91,$54,$8d), ($05,$71,$c4,$5d), ($6f,$04,$06,$d4), ($ff,$60,$50,$15), + ($24,$19,$98,$fb), ($97,$d6,$bd,$e9), ($cc,$89,$40,$43), ($77,$67,$d9,$9e), + ($bd,$b0,$e8,$42), ($88,$07,$89,$8b), ($38,$e7,$19,$5b), ($db,$79,$c8,$ee), + ($47,$a1,$7c,$0a), ($e9,$7c,$42,$0f), ($c9,$f8,$84,$1e), ($00,$00,$00,$00), + ($83,$09,$80,$86), ($48,$32,$2b,$ed), ($ac,$1e,$11,$70), ($4e,$6c,$5a,$72), + ($fb,$fd,$0e,$ff), ($56,$0f,$85,$38), ($1e,$3d,$ae,$d5), ($27,$36,$2d,$39), + ($64,$0a,$0f,$d9), ($21,$68,$5c,$a6), ($d1,$9b,$5b,$54), ($3a,$24,$36,$2e), + ($b1,$0c,$0a,$67), ($0f,$93,$57,$e7), ($d2,$b4,$ee,$96), ($9e,$1b,$9b,$91), + ($4f,$80,$c0,$c5), ($a2,$61,$dc,$20), ($69,$5a,$77,$4b), ($16,$1c,$12,$1a), + ($0a,$e2,$93,$ba), ($e5,$c0,$a0,$2a), ($43,$3c,$22,$e0), ($1d,$12,$1b,$17), + ($0b,$0e,$09,$0d), ($ad,$f2,$8b,$c7), ($b9,$2d,$b6,$a8), ($c8,$14,$1e,$a9), + ($85,$57,$f1,$19), ($4c,$af,$75,$07), ($bb,$ee,$99,$dd), ($fd,$a3,$7f,$60), + ($9f,$f7,$01,$26), ($bc,$5c,$72,$f5), ($c5,$44,$66,$3b), ($34,$5b,$fb,$7e), + ($76,$8b,$43,$29), ($dc,$cb,$23,$c6), ($68,$b6,$ed,$fc), ($63,$b8,$e4,$f1), + ($ca,$d7,$31,$dc), ($10,$42,$63,$85), ($40,$13,$97,$22), ($20,$84,$c6,$11), + ($7d,$85,$4a,$24), ($f8,$d2,$bb,$3d), ($11,$ae,$f9,$32), ($6d,$c7,$29,$a1), + ($4b,$1d,$9e,$2f), ($f3,$dc,$b2,$30), ($ec,$0d,$86,$52), ($d0,$77,$c1,$e3), + ($6c,$2b,$b3,$16), ($99,$a9,$70,$b9), ($fa,$11,$94,$48), ($22,$47,$e9,$64), + ($c4,$a8,$fc,$8c), ($1a,$a0,$f0,$3f), ($d8,$56,$7d,$2c), ($ef,$22,$33,$90), + ($c7,$87,$49,$4e), ($c1,$d9,$38,$d1), ($fe,$8c,$ca,$a2), ($36,$98,$d4,$0b), + ($cf,$a6,$f5,$81), ($28,$a5,$7a,$de), ($26,$da,$b7,$8e), ($a4,$3f,$ad,$bf), + ($e4,$2c,$3a,$9d), ($0d,$50,$78,$92), ($9b,$6a,$5f,$cc), ($62,$54,$7e,$46), + ($c2,$f6,$8d,$13), ($e8,$90,$d8,$b8), ($5e,$2e,$39,$f7), ($f5,$82,$c3,$af), + ($be,$9f,$5d,$80), ($7c,$69,$d0,$93), ($a9,$6f,$d5,$2d), ($b3,$cf,$25,$12), + ($3b,$c8,$ac,$99), ($a7,$10,$18,$7d), ($6e,$e8,$9c,$63), ($7b,$db,$3b,$bb), + ($09,$cd,$26,$78), ($f4,$6e,$59,$18), ($01,$ec,$9a,$b7), ($a8,$83,$4f,$9a), + ($65,$e6,$95,$6e), ($7e,$aa,$ff,$e6), ($08,$21,$bc,$cf), ($e6,$ef,$15,$e8), + ($d9,$ba,$e7,$9b), ($ce,$4a,$6f,$36), ($d4,$ea,$9f,$09), ($d6,$29,$b0,$7c), + ($af,$31,$a4,$b2), ($31,$2a,$3f,$23), ($30,$c6,$a5,$94), ($c0,$35,$a2,$66), + ($37,$74,$4e,$bc), ($a6,$fc,$82,$ca), ($b0,$e0,$90,$d0), ($15,$33,$a7,$d8), + ($4a,$f1,$04,$98), ($f7,$41,$ec,$da), ($0e,$7f,$cd,$50), ($2f,$17,$91,$f6), + ($8d,$76,$4d,$d6), ($4d,$43,$ef,$b0), ($54,$cc,$aa,$4d), ($df,$e4,$96,$04), + ($e3,$9e,$d1,$b5), ($1b,$4c,$6a,$88), ($b8,$c1,$2c,$1f), ($7f,$46,$65,$51), + ($04,$9d,$5e,$ea), ($5d,$01,$8c,$35), ($73,$fa,$87,$74), ($2e,$fb,$0b,$41), + ($5a,$b3,$67,$1d), ($52,$92,$db,$d2), ($33,$e9,$10,$56), ($13,$6d,$d6,$47), + ($8c,$9a,$d7,$61), ($7a,$37,$a1,$0c), ($8e,$59,$f8,$14), ($89,$eb,$13,$3c), + ($ee,$ce,$a9,$27), ($35,$b7,$61,$c9), ($ed,$e1,$1c,$e5), ($3c,$7a,$47,$b1), + ($59,$9c,$d2,$df), ($3f,$55,$f2,$73), ($79,$18,$14,$ce), ($bf,$73,$c7,$37), + ($ea,$53,$f7,$cd), ($5b,$5f,$fd,$aa), ($14,$df,$3d,$6f), ($86,$78,$44,$db), + ($81,$ca,$af,$f3), ($3e,$b9,$68,$c4), ($2c,$38,$24,$34), ($5f,$c2,$a3,$40), + ($72,$16,$1d,$c3), ($0c,$bc,$e2,$25), ($8b,$28,$3c,$49), ($41,$ff,$0d,$95), + ($71,$39,$a8,$01), ($de,$08,$0c,$b3), ($9c,$d8,$b4,$e4), ($90,$64,$56,$c1), + ($61,$7b,$cb,$84), ($70,$d5,$32,$b6), ($74,$48,$6c,$5c), ($42,$d0,$b8,$57)); + T7: array[0..255,0..3] of byte= ( + ($a7,$50,$51,$f4), ($65,$53,$7e,$41), ($a4,$c3,$1a,$17), ($5e,$96,$3a,$27), + ($6b,$cb,$3b,$ab), ($45,$f1,$1f,$9d), ($58,$ab,$ac,$fa), ($03,$93,$4b,$e3), + ($fa,$55,$20,$30), ($6d,$f6,$ad,$76), ($76,$91,$88,$cc), ($4c,$25,$f5,$02), + ($d7,$fc,$4f,$e5), ($cb,$d7,$c5,$2a), ($44,$80,$26,$35), ($a3,$8f,$b5,$62), + ($5a,$49,$de,$b1), ($1b,$67,$25,$ba), ($0e,$98,$45,$ea), ($c0,$e1,$5d,$fe), + ($75,$02,$c3,$2f), ($f0,$12,$81,$4c), ($97,$a3,$8d,$46), ($f9,$c6,$6b,$d3), + ($5f,$e7,$03,$8f), ($9c,$95,$15,$92), ($7a,$eb,$bf,$6d), ($59,$da,$95,$52), + ($83,$2d,$d4,$be), ($21,$d3,$58,$74), ($69,$29,$49,$e0), ($c8,$44,$8e,$c9), + ($89,$6a,$75,$c2), ($79,$78,$f4,$8e), ($3e,$6b,$99,$58), ($71,$dd,$27,$b9), + ($4f,$b6,$be,$e1), ($ad,$17,$f0,$88), ($ac,$66,$c9,$20), ($3a,$b4,$7d,$ce), + ($4a,$18,$63,$df), ($31,$82,$e5,$1a), ($33,$60,$97,$51), ($7f,$45,$62,$53), + ($77,$e0,$b1,$64), ($ae,$84,$bb,$6b), ($a0,$1c,$fe,$81), ($2b,$94,$f9,$08), + ($68,$58,$70,$48), ($fd,$19,$8f,$45), ($6c,$87,$94,$de), ($f8,$b7,$52,$7b), + ($d3,$23,$ab,$73), ($02,$e2,$72,$4b), ($8f,$57,$e3,$1f), ($ab,$2a,$66,$55), + ($28,$07,$b2,$eb), ($c2,$03,$2f,$b5), ($7b,$9a,$86,$c5), ($08,$a5,$d3,$37), + ($87,$f2,$30,$28), ($a5,$b2,$23,$bf), ($6a,$ba,$02,$03), ($82,$5c,$ed,$16), + ($1c,$2b,$8a,$cf), ($b4,$92,$a7,$79), ($f2,$f0,$f3,$07), ($e2,$a1,$4e,$69), + ($f4,$cd,$65,$da), ($be,$d5,$06,$05), ($62,$1f,$d1,$34), ($fe,$8a,$c4,$a6), + ($53,$9d,$34,$2e), ($55,$a0,$a2,$f3), ($e1,$32,$05,$8a), ($eb,$75,$a4,$f6), + ($ec,$39,$0b,$83), ($ef,$aa,$40,$60), ($9f,$06,$5e,$71), ($10,$51,$bd,$6e), + ($8a,$f9,$3e,$21), ($06,$3d,$96,$dd), ($05,$ae,$dd,$3e), ($bd,$46,$4d,$e6), + ($8d,$b5,$91,$54), ($5d,$05,$71,$c4), ($d4,$6f,$04,$06), ($15,$ff,$60,$50), + ($fb,$24,$19,$98), ($e9,$97,$d6,$bd), ($43,$cc,$89,$40), ($9e,$77,$67,$d9), + ($42,$bd,$b0,$e8), ($8b,$88,$07,$89), ($5b,$38,$e7,$19), ($ee,$db,$79,$c8), + ($0a,$47,$a1,$7c), ($0f,$e9,$7c,$42), ($1e,$c9,$f8,$84), ($00,$00,$00,$00), + ($86,$83,$09,$80), ($ed,$48,$32,$2b), ($70,$ac,$1e,$11), ($72,$4e,$6c,$5a), + ($ff,$fb,$fd,$0e), ($38,$56,$0f,$85), ($d5,$1e,$3d,$ae), ($39,$27,$36,$2d), + ($d9,$64,$0a,$0f), ($a6,$21,$68,$5c), ($54,$d1,$9b,$5b), ($2e,$3a,$24,$36), + ($67,$b1,$0c,$0a), ($e7,$0f,$93,$57), ($96,$d2,$b4,$ee), ($91,$9e,$1b,$9b), + ($c5,$4f,$80,$c0), ($20,$a2,$61,$dc), ($4b,$69,$5a,$77), ($1a,$16,$1c,$12), + ($ba,$0a,$e2,$93), ($2a,$e5,$c0,$a0), ($e0,$43,$3c,$22), ($17,$1d,$12,$1b), + ($0d,$0b,$0e,$09), ($c7,$ad,$f2,$8b), ($a8,$b9,$2d,$b6), ($a9,$c8,$14,$1e), + ($19,$85,$57,$f1), ($07,$4c,$af,$75), ($dd,$bb,$ee,$99), ($60,$fd,$a3,$7f), + ($26,$9f,$f7,$01), ($f5,$bc,$5c,$72), ($3b,$c5,$44,$66), ($7e,$34,$5b,$fb), + ($29,$76,$8b,$43), ($c6,$dc,$cb,$23), ($fc,$68,$b6,$ed), ($f1,$63,$b8,$e4), + ($dc,$ca,$d7,$31), ($85,$10,$42,$63), ($22,$40,$13,$97), ($11,$20,$84,$c6), + ($24,$7d,$85,$4a), ($3d,$f8,$d2,$bb), ($32,$11,$ae,$f9), ($a1,$6d,$c7,$29), + ($2f,$4b,$1d,$9e), ($30,$f3,$dc,$b2), ($52,$ec,$0d,$86), ($e3,$d0,$77,$c1), + ($16,$6c,$2b,$b3), ($b9,$99,$a9,$70), ($48,$fa,$11,$94), ($64,$22,$47,$e9), + ($8c,$c4,$a8,$fc), ($3f,$1a,$a0,$f0), ($2c,$d8,$56,$7d), ($90,$ef,$22,$33), + ($4e,$c7,$87,$49), ($d1,$c1,$d9,$38), ($a2,$fe,$8c,$ca), ($0b,$36,$98,$d4), + ($81,$cf,$a6,$f5), ($de,$28,$a5,$7a), ($8e,$26,$da,$b7), ($bf,$a4,$3f,$ad), + ($9d,$e4,$2c,$3a), ($92,$0d,$50,$78), ($cc,$9b,$6a,$5f), ($46,$62,$54,$7e), + ($13,$c2,$f6,$8d), ($b8,$e8,$90,$d8), ($f7,$5e,$2e,$39), ($af,$f5,$82,$c3), + ($80,$be,$9f,$5d), ($93,$7c,$69,$d0), ($2d,$a9,$6f,$d5), ($12,$b3,$cf,$25), + ($99,$3b,$c8,$ac), ($7d,$a7,$10,$18), ($63,$6e,$e8,$9c), ($bb,$7b,$db,$3b), + ($78,$09,$cd,$26), ($18,$f4,$6e,$59), ($b7,$01,$ec,$9a), ($9a,$a8,$83,$4f), + ($6e,$65,$e6,$95), ($e6,$7e,$aa,$ff), ($cf,$08,$21,$bc), ($e8,$e6,$ef,$15), + ($9b,$d9,$ba,$e7), ($36,$ce,$4a,$6f), ($09,$d4,$ea,$9f), ($7c,$d6,$29,$b0), + ($b2,$af,$31,$a4), ($23,$31,$2a,$3f), ($94,$30,$c6,$a5), ($66,$c0,$35,$a2), + ($bc,$37,$74,$4e), ($ca,$a6,$fc,$82), ($d0,$b0,$e0,$90), ($d8,$15,$33,$a7), + ($98,$4a,$f1,$04), ($da,$f7,$41,$ec), ($50,$0e,$7f,$cd), ($f6,$2f,$17,$91), + ($d6,$8d,$76,$4d), ($b0,$4d,$43,$ef), ($4d,$54,$cc,$aa), ($04,$df,$e4,$96), + ($b5,$e3,$9e,$d1), ($88,$1b,$4c,$6a), ($1f,$b8,$c1,$2c), ($51,$7f,$46,$65), + ($ea,$04,$9d,$5e), ($35,$5d,$01,$8c), ($74,$73,$fa,$87), ($41,$2e,$fb,$0b), + ($1d,$5a,$b3,$67), ($d2,$52,$92,$db), ($56,$33,$e9,$10), ($47,$13,$6d,$d6), + ($61,$8c,$9a,$d7), ($0c,$7a,$37,$a1), ($14,$8e,$59,$f8), ($3c,$89,$eb,$13), + ($27,$ee,$ce,$a9), ($c9,$35,$b7,$61), ($e5,$ed,$e1,$1c), ($b1,$3c,$7a,$47), + ($df,$59,$9c,$d2), ($73,$3f,$55,$f2), ($ce,$79,$18,$14), ($37,$bf,$73,$c7), + ($cd,$ea,$53,$f7), ($aa,$5b,$5f,$fd), ($6f,$14,$df,$3d), ($db,$86,$78,$44), + ($f3,$81,$ca,$af), ($c4,$3e,$b9,$68), ($34,$2c,$38,$24), ($40,$5f,$c2,$a3), + ($c3,$72,$16,$1d), ($25,$0c,$bc,$e2), ($49,$8b,$28,$3c), ($95,$41,$ff,$0d), + ($01,$71,$39,$a8), ($b3,$de,$08,$0c), ($e4,$9c,$d8,$b4), ($c1,$90,$64,$56), + ($84,$61,$7b,$cb), ($b6,$70,$d5,$32), ($5c,$74,$48,$6c), ($57,$42,$d0,$b8)); + T8: array[0..255,0..3] of byte= ( + ($f4,$a7,$50,$51), ($41,$65,$53,$7e), ($17,$a4,$c3,$1a), ($27,$5e,$96,$3a), + ($ab,$6b,$cb,$3b), ($9d,$45,$f1,$1f), ($fa,$58,$ab,$ac), ($e3,$03,$93,$4b), + ($30,$fa,$55,$20), ($76,$6d,$f6,$ad), ($cc,$76,$91,$88), ($02,$4c,$25,$f5), + ($e5,$d7,$fc,$4f), ($2a,$cb,$d7,$c5), ($35,$44,$80,$26), ($62,$a3,$8f,$b5), + ($b1,$5a,$49,$de), ($ba,$1b,$67,$25), ($ea,$0e,$98,$45), ($fe,$c0,$e1,$5d), + ($2f,$75,$02,$c3), ($4c,$f0,$12,$81), ($46,$97,$a3,$8d), ($d3,$f9,$c6,$6b), + ($8f,$5f,$e7,$03), ($92,$9c,$95,$15), ($6d,$7a,$eb,$bf), ($52,$59,$da,$95), + ($be,$83,$2d,$d4), ($74,$21,$d3,$58), ($e0,$69,$29,$49), ($c9,$c8,$44,$8e), + ($c2,$89,$6a,$75), ($8e,$79,$78,$f4), ($58,$3e,$6b,$99), ($b9,$71,$dd,$27), + ($e1,$4f,$b6,$be), ($88,$ad,$17,$f0), ($20,$ac,$66,$c9), ($ce,$3a,$b4,$7d), + ($df,$4a,$18,$63), ($1a,$31,$82,$e5), ($51,$33,$60,$97), ($53,$7f,$45,$62), + ($64,$77,$e0,$b1), ($6b,$ae,$84,$bb), ($81,$a0,$1c,$fe), ($08,$2b,$94,$f9), + ($48,$68,$58,$70), ($45,$fd,$19,$8f), ($de,$6c,$87,$94), ($7b,$f8,$b7,$52), + ($73,$d3,$23,$ab), ($4b,$02,$e2,$72), ($1f,$8f,$57,$e3), ($55,$ab,$2a,$66), + ($eb,$28,$07,$b2), ($b5,$c2,$03,$2f), ($c5,$7b,$9a,$86), ($37,$08,$a5,$d3), + ($28,$87,$f2,$30), ($bf,$a5,$b2,$23), ($03,$6a,$ba,$02), ($16,$82,$5c,$ed), + ($cf,$1c,$2b,$8a), ($79,$b4,$92,$a7), ($07,$f2,$f0,$f3), ($69,$e2,$a1,$4e), + ($da,$f4,$cd,$65), ($05,$be,$d5,$06), ($34,$62,$1f,$d1), ($a6,$fe,$8a,$c4), + ($2e,$53,$9d,$34), ($f3,$55,$a0,$a2), ($8a,$e1,$32,$05), ($f6,$eb,$75,$a4), + ($83,$ec,$39,$0b), ($60,$ef,$aa,$40), ($71,$9f,$06,$5e), ($6e,$10,$51,$bd), + ($21,$8a,$f9,$3e), ($dd,$06,$3d,$96), ($3e,$05,$ae,$dd), ($e6,$bd,$46,$4d), + ($54,$8d,$b5,$91), ($c4,$5d,$05,$71), ($06,$d4,$6f,$04), ($50,$15,$ff,$60), + ($98,$fb,$24,$19), ($bd,$e9,$97,$d6), ($40,$43,$cc,$89), ($d9,$9e,$77,$67), + ($e8,$42,$bd,$b0), ($89,$8b,$88,$07), ($19,$5b,$38,$e7), ($c8,$ee,$db,$79), + ($7c,$0a,$47,$a1), ($42,$0f,$e9,$7c), ($84,$1e,$c9,$f8), ($00,$00,$00,$00), + ($80,$86,$83,$09), ($2b,$ed,$48,$32), ($11,$70,$ac,$1e), ($5a,$72,$4e,$6c), + ($0e,$ff,$fb,$fd), ($85,$38,$56,$0f), ($ae,$d5,$1e,$3d), ($2d,$39,$27,$36), + ($0f,$d9,$64,$0a), ($5c,$a6,$21,$68), ($5b,$54,$d1,$9b), ($36,$2e,$3a,$24), + ($0a,$67,$b1,$0c), ($57,$e7,$0f,$93), ($ee,$96,$d2,$b4), ($9b,$91,$9e,$1b), + ($c0,$c5,$4f,$80), ($dc,$20,$a2,$61), ($77,$4b,$69,$5a), ($12,$1a,$16,$1c), + ($93,$ba,$0a,$e2), ($a0,$2a,$e5,$c0), ($22,$e0,$43,$3c), ($1b,$17,$1d,$12), + ($09,$0d,$0b,$0e), ($8b,$c7,$ad,$f2), ($b6,$a8,$b9,$2d), ($1e,$a9,$c8,$14), + ($f1,$19,$85,$57), ($75,$07,$4c,$af), ($99,$dd,$bb,$ee), ($7f,$60,$fd,$a3), + ($01,$26,$9f,$f7), ($72,$f5,$bc,$5c), ($66,$3b,$c5,$44), ($fb,$7e,$34,$5b), + ($43,$29,$76,$8b), ($23,$c6,$dc,$cb), ($ed,$fc,$68,$b6), ($e4,$f1,$63,$b8), + ($31,$dc,$ca,$d7), ($63,$85,$10,$42), ($97,$22,$40,$13), ($c6,$11,$20,$84), + ($4a,$24,$7d,$85), ($bb,$3d,$f8,$d2), ($f9,$32,$11,$ae), ($29,$a1,$6d,$c7), + ($9e,$2f,$4b,$1d), ($b2,$30,$f3,$dc), ($86,$52,$ec,$0d), ($c1,$e3,$d0,$77), + ($b3,$16,$6c,$2b), ($70,$b9,$99,$a9), ($94,$48,$fa,$11), ($e9,$64,$22,$47), + ($fc,$8c,$c4,$a8), ($f0,$3f,$1a,$a0), ($7d,$2c,$d8,$56), ($33,$90,$ef,$22), + ($49,$4e,$c7,$87), ($38,$d1,$c1,$d9), ($ca,$a2,$fe,$8c), ($d4,$0b,$36,$98), + ($f5,$81,$cf,$a6), ($7a,$de,$28,$a5), ($b7,$8e,$26,$da), ($ad,$bf,$a4,$3f), + ($3a,$9d,$e4,$2c), ($78,$92,$0d,$50), ($5f,$cc,$9b,$6a), ($7e,$46,$62,$54), + ($8d,$13,$c2,$f6), ($d8,$b8,$e8,$90), ($39,$f7,$5e,$2e), ($c3,$af,$f5,$82), + ($5d,$80,$be,$9f), ($d0,$93,$7c,$69), ($d5,$2d,$a9,$6f), ($25,$12,$b3,$cf), + ($ac,$99,$3b,$c8), ($18,$7d,$a7,$10), ($9c,$63,$6e,$e8), ($3b,$bb,$7b,$db), + ($26,$78,$09,$cd), ($59,$18,$f4,$6e), ($9a,$b7,$01,$ec), ($4f,$9a,$a8,$83), + ($95,$6e,$65,$e6), ($ff,$e6,$7e,$aa), ($bc,$cf,$08,$21), ($15,$e8,$e6,$ef), + ($e7,$9b,$d9,$ba), ($6f,$36,$ce,$4a), ($9f,$09,$d4,$ea), ($b0,$7c,$d6,$29), + ($a4,$b2,$af,$31), ($3f,$23,$31,$2a), ($a5,$94,$30,$c6), ($a2,$66,$c0,$35), + ($4e,$bc,$37,$74), ($82,$ca,$a6,$fc), ($90,$d0,$b0,$e0), ($a7,$d8,$15,$33), + ($04,$98,$4a,$f1), ($ec,$da,$f7,$41), ($cd,$50,$0e,$7f), ($91,$f6,$2f,$17), + ($4d,$d6,$8d,$76), ($ef,$b0,$4d,$43), ($aa,$4d,$54,$cc), ($96,$04,$df,$e4), + ($d1,$b5,$e3,$9e), ($6a,$88,$1b,$4c), ($2c,$1f,$b8,$c1), ($65,$51,$7f,$46), + ($5e,$ea,$04,$9d), ($8c,$35,$5d,$01), ($87,$74,$73,$fa), ($0b,$41,$2e,$fb), + ($67,$1d,$5a,$b3), ($db,$d2,$52,$92), ($10,$56,$33,$e9), ($d6,$47,$13,$6d), + ($d7,$61,$8c,$9a), ($a1,$0c,$7a,$37), ($f8,$14,$8e,$59), ($13,$3c,$89,$eb), + ($a9,$27,$ee,$ce), ($61,$c9,$35,$b7), ($1c,$e5,$ed,$e1), ($47,$b1,$3c,$7a), + ($d2,$df,$59,$9c), ($f2,$73,$3f,$55), ($14,$ce,$79,$18), ($c7,$37,$bf,$73), + ($f7,$cd,$ea,$53), ($fd,$aa,$5b,$5f), ($3d,$6f,$14,$df), ($44,$db,$86,$78), + ($af,$f3,$81,$ca), ($68,$c4,$3e,$b9), ($24,$34,$2c,$38), ($a3,$40,$5f,$c2), + ($1d,$c3,$72,$16), ($e2,$25,$0c,$bc), ($3c,$49,$8b,$28), ($0d,$95,$41,$ff), + ($a8,$01,$71,$39), ($0c,$b3,$de,$08), ($b4,$e4,$9c,$d8), ($56,$c1,$90,$64), + ($cb,$84,$61,$7b), ($32,$b6,$70,$d5), ($6c,$5c,$74,$48), ($b8,$57,$42,$d0)); + S5: array[0..255] of byte= ( + $52,$09,$6a,$d5, + $30,$36,$a5,$38, + $bf,$40,$a3,$9e, + $81,$f3,$d7,$fb, + $7c,$e3,$39,$82, + $9b,$2f,$ff,$87, + $34,$8e,$43,$44, + $c4,$de,$e9,$cb, + $54,$7b,$94,$32, + $a6,$c2,$23,$3d, + $ee,$4c,$95,$0b, + $42,$fa,$c3,$4e, + $08,$2e,$a1,$66, + $28,$d9,$24,$b2, + $76,$5b,$a2,$49, + $6d,$8b,$d1,$25, + $72,$f8,$f6,$64, + $86,$68,$98,$16, + $d4,$a4,$5c,$cc, + $5d,$65,$b6,$92, + $6c,$70,$48,$50, + $fd,$ed,$b9,$da, + $5e,$15,$46,$57, + $a7,$8d,$9d,$84, + $90,$d8,$ab,$00, + $8c,$bc,$d3,$0a, + $f7,$e4,$58,$05, + $b8,$b3,$45,$06, + $d0,$2c,$1e,$8f, + $ca,$3f,$0f,$02, + $c1,$af,$bd,$03, + $01,$13,$8a,$6b, + $3a,$91,$11,$41, + $4f,$67,$dc,$ea, + $97,$f2,$cf,$ce, + $f0,$b4,$e6,$73, + $96,$ac,$74,$22, + $e7,$ad,$35,$85, + $e2,$f9,$37,$e8, + $1c,$75,$df,$6e, + $47,$f1,$1a,$71, + $1d,$29,$c5,$89, + $6f,$b7,$62,$0e, + $aa,$18,$be,$1b, + $fc,$56,$3e,$4b, + $c6,$d2,$79,$20, + $9a,$db,$c0,$fe, + $78,$cd,$5a,$f4, + $1f,$dd,$a8,$33, + $88,$07,$c7,$31, + $b1,$12,$10,$59, + $27,$80,$ec,$5f, + $60,$51,$7f,$a9, + $19,$b5,$4a,$0d, + $2d,$e5,$7a,$9f, + $93,$c9,$9c,$ef, + $a0,$e0,$3b,$4d, + $ae,$2a,$f5,$b0, + $c8,$eb,$bb,$3c, + $83,$53,$99,$61, + $17,$2b,$04,$7e, + $ba,$77,$d6,$26, + $e1,$69,$14,$63, + $55,$21,$0c,$7d); + U1: array[0..255,0..3] of byte= ( + ($00,$00,$00,$00), ($0e,$09,$0d,$0b), ($1c,$12,$1a,$16), ($12,$1b,$17,$1d), + ($38,$24,$34,$2c), ($36,$2d,$39,$27), ($24,$36,$2e,$3a), ($2a,$3f,$23,$31), + ($70,$48,$68,$58), ($7e,$41,$65,$53), ($6c,$5a,$72,$4e), ($62,$53,$7f,$45), + ($48,$6c,$5c,$74), ($46,$65,$51,$7f), ($54,$7e,$46,$62), ($5a,$77,$4b,$69), + ($e0,$90,$d0,$b0), ($ee,$99,$dd,$bb), ($fc,$82,$ca,$a6), ($f2,$8b,$c7,$ad), + ($d8,$b4,$e4,$9c), ($d6,$bd,$e9,$97), ($c4,$a6,$fe,$8a), ($ca,$af,$f3,$81), + ($90,$d8,$b8,$e8), ($9e,$d1,$b5,$e3), ($8c,$ca,$a2,$fe), ($82,$c3,$af,$f5), + ($a8,$fc,$8c,$c4), ($a6,$f5,$81,$cf), ($b4,$ee,$96,$d2), ($ba,$e7,$9b,$d9), + ($db,$3b,$bb,$7b), ($d5,$32,$b6,$70), ($c7,$29,$a1,$6d), ($c9,$20,$ac,$66), + ($e3,$1f,$8f,$57), ($ed,$16,$82,$5c), ($ff,$0d,$95,$41), ($f1,$04,$98,$4a), + ($ab,$73,$d3,$23), ($a5,$7a,$de,$28), ($b7,$61,$c9,$35), ($b9,$68,$c4,$3e), + ($93,$57,$e7,$0f), ($9d,$5e,$ea,$04), ($8f,$45,$fd,$19), ($81,$4c,$f0,$12), + ($3b,$ab,$6b,$cb), ($35,$a2,$66,$c0), ($27,$b9,$71,$dd), ($29,$b0,$7c,$d6), + ($03,$8f,$5f,$e7), ($0d,$86,$52,$ec), ($1f,$9d,$45,$f1), ($11,$94,$48,$fa), + ($4b,$e3,$03,$93), ($45,$ea,$0e,$98), ($57,$f1,$19,$85), ($59,$f8,$14,$8e), + ($73,$c7,$37,$bf), ($7d,$ce,$3a,$b4), ($6f,$d5,$2d,$a9), ($61,$dc,$20,$a2), + ($ad,$76,$6d,$f6), ($a3,$7f,$60,$fd), ($b1,$64,$77,$e0), ($bf,$6d,$7a,$eb), + ($95,$52,$59,$da), ($9b,$5b,$54,$d1), ($89,$40,$43,$cc), ($87,$49,$4e,$c7), + ($dd,$3e,$05,$ae), ($d3,$37,$08,$a5), ($c1,$2c,$1f,$b8), ($cf,$25,$12,$b3), + ($e5,$1a,$31,$82), ($eb,$13,$3c,$89), ($f9,$08,$2b,$94), ($f7,$01,$26,$9f), + ($4d,$e6,$bd,$46), ($43,$ef,$b0,$4d), ($51,$f4,$a7,$50), ($5f,$fd,$aa,$5b), + ($75,$c2,$89,$6a), ($7b,$cb,$84,$61), ($69,$d0,$93,$7c), ($67,$d9,$9e,$77), + ($3d,$ae,$d5,$1e), ($33,$a7,$d8,$15), ($21,$bc,$cf,$08), ($2f,$b5,$c2,$03), + ($05,$8a,$e1,$32), ($0b,$83,$ec,$39), ($19,$98,$fb,$24), ($17,$91,$f6,$2f), + ($76,$4d,$d6,$8d), ($78,$44,$db,$86), ($6a,$5f,$cc,$9b), ($64,$56,$c1,$90), + ($4e,$69,$e2,$a1), ($40,$60,$ef,$aa), ($52,$7b,$f8,$b7), ($5c,$72,$f5,$bc), + ($06,$05,$be,$d5), ($08,$0c,$b3,$de), ($1a,$17,$a4,$c3), ($14,$1e,$a9,$c8), + ($3e,$21,$8a,$f9), ($30,$28,$87,$f2), ($22,$33,$90,$ef), ($2c,$3a,$9d,$e4), + ($96,$dd,$06,$3d), ($98,$d4,$0b,$36), ($8a,$cf,$1c,$2b), ($84,$c6,$11,$20), + ($ae,$f9,$32,$11), ($a0,$f0,$3f,$1a), ($b2,$eb,$28,$07), ($bc,$e2,$25,$0c), + ($e6,$95,$6e,$65), ($e8,$9c,$63,$6e), ($fa,$87,$74,$73), ($f4,$8e,$79,$78), + ($de,$b1,$5a,$49), ($d0,$b8,$57,$42), ($c2,$a3,$40,$5f), ($cc,$aa,$4d,$54), + ($41,$ec,$da,$f7), ($4f,$e5,$d7,$fc), ($5d,$fe,$c0,$e1), ($53,$f7,$cd,$ea), + ($79,$c8,$ee,$db), ($77,$c1,$e3,$d0), ($65,$da,$f4,$cd), ($6b,$d3,$f9,$c6), + ($31,$a4,$b2,$af), ($3f,$ad,$bf,$a4), ($2d,$b6,$a8,$b9), ($23,$bf,$a5,$b2), + ($09,$80,$86,$83), ($07,$89,$8b,$88), ($15,$92,$9c,$95), ($1b,$9b,$91,$9e), + ($a1,$7c,$0a,$47), ($af,$75,$07,$4c), ($bd,$6e,$10,$51), ($b3,$67,$1d,$5a), + ($99,$58,$3e,$6b), ($97,$51,$33,$60), ($85,$4a,$24,$7d), ($8b,$43,$29,$76), + ($d1,$34,$62,$1f), ($df,$3d,$6f,$14), ($cd,$26,$78,$09), ($c3,$2f,$75,$02), + ($e9,$10,$56,$33), ($e7,$19,$5b,$38), ($f5,$02,$4c,$25), ($fb,$0b,$41,$2e), + ($9a,$d7,$61,$8c), ($94,$de,$6c,$87), ($86,$c5,$7b,$9a), ($88,$cc,$76,$91), + ($a2,$f3,$55,$a0), ($ac,$fa,$58,$ab), ($be,$e1,$4f,$b6), ($b0,$e8,$42,$bd), + ($ea,$9f,$09,$d4), ($e4,$96,$04,$df), ($f6,$8d,$13,$c2), ($f8,$84,$1e,$c9), + ($d2,$bb,$3d,$f8), ($dc,$b2,$30,$f3), ($ce,$a9,$27,$ee), ($c0,$a0,$2a,$e5), + ($7a,$47,$b1,$3c), ($74,$4e,$bc,$37), ($66,$55,$ab,$2a), ($68,$5c,$a6,$21), + ($42,$63,$85,$10), ($4c,$6a,$88,$1b), ($5e,$71,$9f,$06), ($50,$78,$92,$0d), + ($0a,$0f,$d9,$64), ($04,$06,$d4,$6f), ($16,$1d,$c3,$72), ($18,$14,$ce,$79), + ($32,$2b,$ed,$48), ($3c,$22,$e0,$43), ($2e,$39,$f7,$5e), ($20,$30,$fa,$55), + ($ec,$9a,$b7,$01), ($e2,$93,$ba,$0a), ($f0,$88,$ad,$17), ($fe,$81,$a0,$1c), + ($d4,$be,$83,$2d), ($da,$b7,$8e,$26), ($c8,$ac,$99,$3b), ($c6,$a5,$94,$30), + ($9c,$d2,$df,$59), ($92,$db,$d2,$52), ($80,$c0,$c5,$4f), ($8e,$c9,$c8,$44), + ($a4,$f6,$eb,$75), ($aa,$ff,$e6,$7e), ($b8,$e4,$f1,$63), ($b6,$ed,$fc,$68), + ($0c,$0a,$67,$b1), ($02,$03,$6a,$ba), ($10,$18,$7d,$a7), ($1e,$11,$70,$ac), + ($34,$2e,$53,$9d), ($3a,$27,$5e,$96), ($28,$3c,$49,$8b), ($26,$35,$44,$80), + ($7c,$42,$0f,$e9), ($72,$4b,$02,$e2), ($60,$50,$15,$ff), ($6e,$59,$18,$f4), + ($44,$66,$3b,$c5), ($4a,$6f,$36,$ce), ($58,$74,$21,$d3), ($56,$7d,$2c,$d8), + ($37,$a1,$0c,$7a), ($39,$a8,$01,$71), ($2b,$b3,$16,$6c), ($25,$ba,$1b,$67), + ($0f,$85,$38,$56), ($01,$8c,$35,$5d), ($13,$97,$22,$40), ($1d,$9e,$2f,$4b), + ($47,$e9,$64,$22), ($49,$e0,$69,$29), ($5b,$fb,$7e,$34), ($55,$f2,$73,$3f), + ($7f,$cd,$50,$0e), ($71,$c4,$5d,$05), ($63,$df,$4a,$18), ($6d,$d6,$47,$13), + ($d7,$31,$dc,$ca), ($d9,$38,$d1,$c1), ($cb,$23,$c6,$dc), ($c5,$2a,$cb,$d7), + ($ef,$15,$e8,$e6), ($e1,$1c,$e5,$ed), ($f3,$07,$f2,$f0), ($fd,$0e,$ff,$fb), + ($a7,$79,$b4,$92), ($a9,$70,$b9,$99), ($bb,$6b,$ae,$84), ($b5,$62,$a3,$8f), + ($9f,$5d,$80,$be), ($91,$54,$8d,$b5), ($83,$4f,$9a,$a8), ($8d,$46,$97,$a3)); + U2: array[0..255,0..3] of byte= ( + ($00,$00,$00,$00), ($0b,$0e,$09,$0d), ($16,$1c,$12,$1a), ($1d,$12,$1b,$17), + ($2c,$38,$24,$34), ($27,$36,$2d,$39), ($3a,$24,$36,$2e), ($31,$2a,$3f,$23), + ($58,$70,$48,$68), ($53,$7e,$41,$65), ($4e,$6c,$5a,$72), ($45,$62,$53,$7f), + ($74,$48,$6c,$5c), ($7f,$46,$65,$51), ($62,$54,$7e,$46), ($69,$5a,$77,$4b), + ($b0,$e0,$90,$d0), ($bb,$ee,$99,$dd), ($a6,$fc,$82,$ca), ($ad,$f2,$8b,$c7), + ($9c,$d8,$b4,$e4), ($97,$d6,$bd,$e9), ($8a,$c4,$a6,$fe), ($81,$ca,$af,$f3), + ($e8,$90,$d8,$b8), ($e3,$9e,$d1,$b5), ($fe,$8c,$ca,$a2), ($f5,$82,$c3,$af), + ($c4,$a8,$fc,$8c), ($cf,$a6,$f5,$81), ($d2,$b4,$ee,$96), ($d9,$ba,$e7,$9b), + ($7b,$db,$3b,$bb), ($70,$d5,$32,$b6), ($6d,$c7,$29,$a1), ($66,$c9,$20,$ac), + ($57,$e3,$1f,$8f), ($5c,$ed,$16,$82), ($41,$ff,$0d,$95), ($4a,$f1,$04,$98), + ($23,$ab,$73,$d3), ($28,$a5,$7a,$de), ($35,$b7,$61,$c9), ($3e,$b9,$68,$c4), + ($0f,$93,$57,$e7), ($04,$9d,$5e,$ea), ($19,$8f,$45,$fd), ($12,$81,$4c,$f0), + ($cb,$3b,$ab,$6b), ($c0,$35,$a2,$66), ($dd,$27,$b9,$71), ($d6,$29,$b0,$7c), + ($e7,$03,$8f,$5f), ($ec,$0d,$86,$52), ($f1,$1f,$9d,$45), ($fa,$11,$94,$48), + ($93,$4b,$e3,$03), ($98,$45,$ea,$0e), ($85,$57,$f1,$19), ($8e,$59,$f8,$14), + ($bf,$73,$c7,$37), ($b4,$7d,$ce,$3a), ($a9,$6f,$d5,$2d), ($a2,$61,$dc,$20), + ($f6,$ad,$76,$6d), ($fd,$a3,$7f,$60), ($e0,$b1,$64,$77), ($eb,$bf,$6d,$7a), + ($da,$95,$52,$59), ($d1,$9b,$5b,$54), ($cc,$89,$40,$43), ($c7,$87,$49,$4e), + ($ae,$dd,$3e,$05), ($a5,$d3,$37,$08), ($b8,$c1,$2c,$1f), ($b3,$cf,$25,$12), + ($82,$e5,$1a,$31), ($89,$eb,$13,$3c), ($94,$f9,$08,$2b), ($9f,$f7,$01,$26), + ($46,$4d,$e6,$bd), ($4d,$43,$ef,$b0), ($50,$51,$f4,$a7), ($5b,$5f,$fd,$aa), + ($6a,$75,$c2,$89), ($61,$7b,$cb,$84), ($7c,$69,$d0,$93), ($77,$67,$d9,$9e), + ($1e,$3d,$ae,$d5), ($15,$33,$a7,$d8), ($08,$21,$bc,$cf), ($03,$2f,$b5,$c2), + ($32,$05,$8a,$e1), ($39,$0b,$83,$ec), ($24,$19,$98,$fb), ($2f,$17,$91,$f6), + ($8d,$76,$4d,$d6), ($86,$78,$44,$db), ($9b,$6a,$5f,$cc), ($90,$64,$56,$c1), + ($a1,$4e,$69,$e2), ($aa,$40,$60,$ef), ($b7,$52,$7b,$f8), ($bc,$5c,$72,$f5), + ($d5,$06,$05,$be), ($de,$08,$0c,$b3), ($c3,$1a,$17,$a4), ($c8,$14,$1e,$a9), + ($f9,$3e,$21,$8a), ($f2,$30,$28,$87), ($ef,$22,$33,$90), ($e4,$2c,$3a,$9d), + ($3d,$96,$dd,$06), ($36,$98,$d4,$0b), ($2b,$8a,$cf,$1c), ($20,$84,$c6,$11), + ($11,$ae,$f9,$32), ($1a,$a0,$f0,$3f), ($07,$b2,$eb,$28), ($0c,$bc,$e2,$25), + ($65,$e6,$95,$6e), ($6e,$e8,$9c,$63), ($73,$fa,$87,$74), ($78,$f4,$8e,$79), + ($49,$de,$b1,$5a), ($42,$d0,$b8,$57), ($5f,$c2,$a3,$40), ($54,$cc,$aa,$4d), + ($f7,$41,$ec,$da), ($fc,$4f,$e5,$d7), ($e1,$5d,$fe,$c0), ($ea,$53,$f7,$cd), + ($db,$79,$c8,$ee), ($d0,$77,$c1,$e3), ($cd,$65,$da,$f4), ($c6,$6b,$d3,$f9), + ($af,$31,$a4,$b2), ($a4,$3f,$ad,$bf), ($b9,$2d,$b6,$a8), ($b2,$23,$bf,$a5), + ($83,$09,$80,$86), ($88,$07,$89,$8b), ($95,$15,$92,$9c), ($9e,$1b,$9b,$91), + ($47,$a1,$7c,$0a), ($4c,$af,$75,$07), ($51,$bd,$6e,$10), ($5a,$b3,$67,$1d), + ($6b,$99,$58,$3e), ($60,$97,$51,$33), ($7d,$85,$4a,$24), ($76,$8b,$43,$29), + ($1f,$d1,$34,$62), ($14,$df,$3d,$6f), ($09,$cd,$26,$78), ($02,$c3,$2f,$75), + ($33,$e9,$10,$56), ($38,$e7,$19,$5b), ($25,$f5,$02,$4c), ($2e,$fb,$0b,$41), + ($8c,$9a,$d7,$61), ($87,$94,$de,$6c), ($9a,$86,$c5,$7b), ($91,$88,$cc,$76), + ($a0,$a2,$f3,$55), ($ab,$ac,$fa,$58), ($b6,$be,$e1,$4f), ($bd,$b0,$e8,$42), + ($d4,$ea,$9f,$09), ($df,$e4,$96,$04), ($c2,$f6,$8d,$13), ($c9,$f8,$84,$1e), + ($f8,$d2,$bb,$3d), ($f3,$dc,$b2,$30), ($ee,$ce,$a9,$27), ($e5,$c0,$a0,$2a), + ($3c,$7a,$47,$b1), ($37,$74,$4e,$bc), ($2a,$66,$55,$ab), ($21,$68,$5c,$a6), + ($10,$42,$63,$85), ($1b,$4c,$6a,$88), ($06,$5e,$71,$9f), ($0d,$50,$78,$92), + ($64,$0a,$0f,$d9), ($6f,$04,$06,$d4), ($72,$16,$1d,$c3), ($79,$18,$14,$ce), + ($48,$32,$2b,$ed), ($43,$3c,$22,$e0), ($5e,$2e,$39,$f7), ($55,$20,$30,$fa), + ($01,$ec,$9a,$b7), ($0a,$e2,$93,$ba), ($17,$f0,$88,$ad), ($1c,$fe,$81,$a0), + ($2d,$d4,$be,$83), ($26,$da,$b7,$8e), ($3b,$c8,$ac,$99), ($30,$c6,$a5,$94), + ($59,$9c,$d2,$df), ($52,$92,$db,$d2), ($4f,$80,$c0,$c5), ($44,$8e,$c9,$c8), + ($75,$a4,$f6,$eb), ($7e,$aa,$ff,$e6), ($63,$b8,$e4,$f1), ($68,$b6,$ed,$fc), + ($b1,$0c,$0a,$67), ($ba,$02,$03,$6a), ($a7,$10,$18,$7d), ($ac,$1e,$11,$70), + ($9d,$34,$2e,$53), ($96,$3a,$27,$5e), ($8b,$28,$3c,$49), ($80,$26,$35,$44), + ($e9,$7c,$42,$0f), ($e2,$72,$4b,$02), ($ff,$60,$50,$15), ($f4,$6e,$59,$18), + ($c5,$44,$66,$3b), ($ce,$4a,$6f,$36), ($d3,$58,$74,$21), ($d8,$56,$7d,$2c), + ($7a,$37,$a1,$0c), ($71,$39,$a8,$01), ($6c,$2b,$b3,$16), ($67,$25,$ba,$1b), + ($56,$0f,$85,$38), ($5d,$01,$8c,$35), ($40,$13,$97,$22), ($4b,$1d,$9e,$2f), + ($22,$47,$e9,$64), ($29,$49,$e0,$69), ($34,$5b,$fb,$7e), ($3f,$55,$f2,$73), + ($0e,$7f,$cd,$50), ($05,$71,$c4,$5d), ($18,$63,$df,$4a), ($13,$6d,$d6,$47), + ($ca,$d7,$31,$dc), ($c1,$d9,$38,$d1), ($dc,$cb,$23,$c6), ($d7,$c5,$2a,$cb), + ($e6,$ef,$15,$e8), ($ed,$e1,$1c,$e5), ($f0,$f3,$07,$f2), ($fb,$fd,$0e,$ff), + ($92,$a7,$79,$b4), ($99,$a9,$70,$b9), ($84,$bb,$6b,$ae), ($8f,$b5,$62,$a3), + ($be,$9f,$5d,$80), ($b5,$91,$54,$8d), ($a8,$83,$4f,$9a), ($a3,$8d,$46,$97)); + U3: array[0..255,0..3] of byte= ( + ($00,$00,$00,$00), ($0d,$0b,$0e,$09), ($1a,$16,$1c,$12), ($17,$1d,$12,$1b), + ($34,$2c,$38,$24), ($39,$27,$36,$2d), ($2e,$3a,$24,$36), ($23,$31,$2a,$3f), + ($68,$58,$70,$48), ($65,$53,$7e,$41), ($72,$4e,$6c,$5a), ($7f,$45,$62,$53), + ($5c,$74,$48,$6c), ($51,$7f,$46,$65), ($46,$62,$54,$7e), ($4b,$69,$5a,$77), + ($d0,$b0,$e0,$90), ($dd,$bb,$ee,$99), ($ca,$a6,$fc,$82), ($c7,$ad,$f2,$8b), + ($e4,$9c,$d8,$b4), ($e9,$97,$d6,$bd), ($fe,$8a,$c4,$a6), ($f3,$81,$ca,$af), + ($b8,$e8,$90,$d8), ($b5,$e3,$9e,$d1), ($a2,$fe,$8c,$ca), ($af,$f5,$82,$c3), + ($8c,$c4,$a8,$fc), ($81,$cf,$a6,$f5), ($96,$d2,$b4,$ee), ($9b,$d9,$ba,$e7), + ($bb,$7b,$db,$3b), ($b6,$70,$d5,$32), ($a1,$6d,$c7,$29), ($ac,$66,$c9,$20), + ($8f,$57,$e3,$1f), ($82,$5c,$ed,$16), ($95,$41,$ff,$0d), ($98,$4a,$f1,$04), + ($d3,$23,$ab,$73), ($de,$28,$a5,$7a), ($c9,$35,$b7,$61), ($c4,$3e,$b9,$68), + ($e7,$0f,$93,$57), ($ea,$04,$9d,$5e), ($fd,$19,$8f,$45), ($f0,$12,$81,$4c), + ($6b,$cb,$3b,$ab), ($66,$c0,$35,$a2), ($71,$dd,$27,$b9), ($7c,$d6,$29,$b0), + ($5f,$e7,$03,$8f), ($52,$ec,$0d,$86), ($45,$f1,$1f,$9d), ($48,$fa,$11,$94), + ($03,$93,$4b,$e3), ($0e,$98,$45,$ea), ($19,$85,$57,$f1), ($14,$8e,$59,$f8), + ($37,$bf,$73,$c7), ($3a,$b4,$7d,$ce), ($2d,$a9,$6f,$d5), ($20,$a2,$61,$dc), + ($6d,$f6,$ad,$76), ($60,$fd,$a3,$7f), ($77,$e0,$b1,$64), ($7a,$eb,$bf,$6d), + ($59,$da,$95,$52), ($54,$d1,$9b,$5b), ($43,$cc,$89,$40), ($4e,$c7,$87,$49), + ($05,$ae,$dd,$3e), ($08,$a5,$d3,$37), ($1f,$b8,$c1,$2c), ($12,$b3,$cf,$25), + ($31,$82,$e5,$1a), ($3c,$89,$eb,$13), ($2b,$94,$f9,$08), ($26,$9f,$f7,$01), + ($bd,$46,$4d,$e6), ($b0,$4d,$43,$ef), ($a7,$50,$51,$f4), ($aa,$5b,$5f,$fd), + ($89,$6a,$75,$c2), ($84,$61,$7b,$cb), ($93,$7c,$69,$d0), ($9e,$77,$67,$d9), + ($d5,$1e,$3d,$ae), ($d8,$15,$33,$a7), ($cf,$08,$21,$bc), ($c2,$03,$2f,$b5), + ($e1,$32,$05,$8a), ($ec,$39,$0b,$83), ($fb,$24,$19,$98), ($f6,$2f,$17,$91), + ($d6,$8d,$76,$4d), ($db,$86,$78,$44), ($cc,$9b,$6a,$5f), ($c1,$90,$64,$56), + ($e2,$a1,$4e,$69), ($ef,$aa,$40,$60), ($f8,$b7,$52,$7b), ($f5,$bc,$5c,$72), + ($be,$d5,$06,$05), ($b3,$de,$08,$0c), ($a4,$c3,$1a,$17), ($a9,$c8,$14,$1e), + ($8a,$f9,$3e,$21), ($87,$f2,$30,$28), ($90,$ef,$22,$33), ($9d,$e4,$2c,$3a), + ($06,$3d,$96,$dd), ($0b,$36,$98,$d4), ($1c,$2b,$8a,$cf), ($11,$20,$84,$c6), + ($32,$11,$ae,$f9), ($3f,$1a,$a0,$f0), ($28,$07,$b2,$eb), ($25,$0c,$bc,$e2), + ($6e,$65,$e6,$95), ($63,$6e,$e8,$9c), ($74,$73,$fa,$87), ($79,$78,$f4,$8e), + ($5a,$49,$de,$b1), ($57,$42,$d0,$b8), ($40,$5f,$c2,$a3), ($4d,$54,$cc,$aa), + ($da,$f7,$41,$ec), ($d7,$fc,$4f,$e5), ($c0,$e1,$5d,$fe), ($cd,$ea,$53,$f7), + ($ee,$db,$79,$c8), ($e3,$d0,$77,$c1), ($f4,$cd,$65,$da), ($f9,$c6,$6b,$d3), + ($b2,$af,$31,$a4), ($bf,$a4,$3f,$ad), ($a8,$b9,$2d,$b6), ($a5,$b2,$23,$bf), + ($86,$83,$09,$80), ($8b,$88,$07,$89), ($9c,$95,$15,$92), ($91,$9e,$1b,$9b), + ($0a,$47,$a1,$7c), ($07,$4c,$af,$75), ($10,$51,$bd,$6e), ($1d,$5a,$b3,$67), + ($3e,$6b,$99,$58), ($33,$60,$97,$51), ($24,$7d,$85,$4a), ($29,$76,$8b,$43), + ($62,$1f,$d1,$34), ($6f,$14,$df,$3d), ($78,$09,$cd,$26), ($75,$02,$c3,$2f), + ($56,$33,$e9,$10), ($5b,$38,$e7,$19), ($4c,$25,$f5,$02), ($41,$2e,$fb,$0b), + ($61,$8c,$9a,$d7), ($6c,$87,$94,$de), ($7b,$9a,$86,$c5), ($76,$91,$88,$cc), + ($55,$a0,$a2,$f3), ($58,$ab,$ac,$fa), ($4f,$b6,$be,$e1), ($42,$bd,$b0,$e8), + ($09,$d4,$ea,$9f), ($04,$df,$e4,$96), ($13,$c2,$f6,$8d), ($1e,$c9,$f8,$84), + ($3d,$f8,$d2,$bb), ($30,$f3,$dc,$b2), ($27,$ee,$ce,$a9), ($2a,$e5,$c0,$a0), + ($b1,$3c,$7a,$47), ($bc,$37,$74,$4e), ($ab,$2a,$66,$55), ($a6,$21,$68,$5c), + ($85,$10,$42,$63), ($88,$1b,$4c,$6a), ($9f,$06,$5e,$71), ($92,$0d,$50,$78), + ($d9,$64,$0a,$0f), ($d4,$6f,$04,$06), ($c3,$72,$16,$1d), ($ce,$79,$18,$14), + ($ed,$48,$32,$2b), ($e0,$43,$3c,$22), ($f7,$5e,$2e,$39), ($fa,$55,$20,$30), + ($b7,$01,$ec,$9a), ($ba,$0a,$e2,$93), ($ad,$17,$f0,$88), ($a0,$1c,$fe,$81), + ($83,$2d,$d4,$be), ($8e,$26,$da,$b7), ($99,$3b,$c8,$ac), ($94,$30,$c6,$a5), + ($df,$59,$9c,$d2), ($d2,$52,$92,$db), ($c5,$4f,$80,$c0), ($c8,$44,$8e,$c9), + ($eb,$75,$a4,$f6), ($e6,$7e,$aa,$ff), ($f1,$63,$b8,$e4), ($fc,$68,$b6,$ed), + ($67,$b1,$0c,$0a), ($6a,$ba,$02,$03), ($7d,$a7,$10,$18), ($70,$ac,$1e,$11), + ($53,$9d,$34,$2e), ($5e,$96,$3a,$27), ($49,$8b,$28,$3c), ($44,$80,$26,$35), + ($0f,$e9,$7c,$42), ($02,$e2,$72,$4b), ($15,$ff,$60,$50), ($18,$f4,$6e,$59), + ($3b,$c5,$44,$66), ($36,$ce,$4a,$6f), ($21,$d3,$58,$74), ($2c,$d8,$56,$7d), + ($0c,$7a,$37,$a1), ($01,$71,$39,$a8), ($16,$6c,$2b,$b3), ($1b,$67,$25,$ba), + ($38,$56,$0f,$85), ($35,$5d,$01,$8c), ($22,$40,$13,$97), ($2f,$4b,$1d,$9e), + ($64,$22,$47,$e9), ($69,$29,$49,$e0), ($7e,$34,$5b,$fb), ($73,$3f,$55,$f2), + ($50,$0e,$7f,$cd), ($5d,$05,$71,$c4), ($4a,$18,$63,$df), ($47,$13,$6d,$d6), + ($dc,$ca,$d7,$31), ($d1,$c1,$d9,$38), ($c6,$dc,$cb,$23), ($cb,$d7,$c5,$2a), + ($e8,$e6,$ef,$15), ($e5,$ed,$e1,$1c), ($f2,$f0,$f3,$07), ($ff,$fb,$fd,$0e), + ($b4,$92,$a7,$79), ($b9,$99,$a9,$70), ($ae,$84,$bb,$6b), ($a3,$8f,$b5,$62), + ($80,$be,$9f,$5d), ($8d,$b5,$91,$54), ($9a,$a8,$83,$4f), ($97,$a3,$8d,$46)); + U4: array[0..255,0..3] of byte= ( + ($00,$00,$00,$00), ($09,$0d,$0b,$0e), ($12,$1a,$16,$1c), ($1b,$17,$1d,$12), + ($24,$34,$2c,$38), ($2d,$39,$27,$36), ($36,$2e,$3a,$24), ($3f,$23,$31,$2a), + ($48,$68,$58,$70), ($41,$65,$53,$7e), ($5a,$72,$4e,$6c), ($53,$7f,$45,$62), + ($6c,$5c,$74,$48), ($65,$51,$7f,$46), ($7e,$46,$62,$54), ($77,$4b,$69,$5a), + ($90,$d0,$b0,$e0), ($99,$dd,$bb,$ee), ($82,$ca,$a6,$fc), ($8b,$c7,$ad,$f2), + ($b4,$e4,$9c,$d8), ($bd,$e9,$97,$d6), ($a6,$fe,$8a,$c4), ($af,$f3,$81,$ca), + ($d8,$b8,$e8,$90), ($d1,$b5,$e3,$9e), ($ca,$a2,$fe,$8c), ($c3,$af,$f5,$82), + ($fc,$8c,$c4,$a8), ($f5,$81,$cf,$a6), ($ee,$96,$d2,$b4), ($e7,$9b,$d9,$ba), + ($3b,$bb,$7b,$db), ($32,$b6,$70,$d5), ($29,$a1,$6d,$c7), ($20,$ac,$66,$c9), + ($1f,$8f,$57,$e3), ($16,$82,$5c,$ed), ($0d,$95,$41,$ff), ($04,$98,$4a,$f1), + ($73,$d3,$23,$ab), ($7a,$de,$28,$a5), ($61,$c9,$35,$b7), ($68,$c4,$3e,$b9), + ($57,$e7,$0f,$93), ($5e,$ea,$04,$9d), ($45,$fd,$19,$8f), ($4c,$f0,$12,$81), + ($ab,$6b,$cb,$3b), ($a2,$66,$c0,$35), ($b9,$71,$dd,$27), ($b0,$7c,$d6,$29), + ($8f,$5f,$e7,$03), ($86,$52,$ec,$0d), ($9d,$45,$f1,$1f), ($94,$48,$fa,$11), + ($e3,$03,$93,$4b), ($ea,$0e,$98,$45), ($f1,$19,$85,$57), ($f8,$14,$8e,$59), + ($c7,$37,$bf,$73), ($ce,$3a,$b4,$7d), ($d5,$2d,$a9,$6f), ($dc,$20,$a2,$61), + ($76,$6d,$f6,$ad), ($7f,$60,$fd,$a3), ($64,$77,$e0,$b1), ($6d,$7a,$eb,$bf), + ($52,$59,$da,$95), ($5b,$54,$d1,$9b), ($40,$43,$cc,$89), ($49,$4e,$c7,$87), + ($3e,$05,$ae,$dd), ($37,$08,$a5,$d3), ($2c,$1f,$b8,$c1), ($25,$12,$b3,$cf), + ($1a,$31,$82,$e5), ($13,$3c,$89,$eb), ($08,$2b,$94,$f9), ($01,$26,$9f,$f7), + ($e6,$bd,$46,$4d), ($ef,$b0,$4d,$43), ($f4,$a7,$50,$51), ($fd,$aa,$5b,$5f), + ($c2,$89,$6a,$75), ($cb,$84,$61,$7b), ($d0,$93,$7c,$69), ($d9,$9e,$77,$67), + ($ae,$d5,$1e,$3d), ($a7,$d8,$15,$33), ($bc,$cf,$08,$21), ($b5,$c2,$03,$2f), + ($8a,$e1,$32,$05), ($83,$ec,$39,$0b), ($98,$fb,$24,$19), ($91,$f6,$2f,$17), + ($4d,$d6,$8d,$76), ($44,$db,$86,$78), ($5f,$cc,$9b,$6a), ($56,$c1,$90,$64), + ($69,$e2,$a1,$4e), ($60,$ef,$aa,$40), ($7b,$f8,$b7,$52), ($72,$f5,$bc,$5c), + ($05,$be,$d5,$06), ($0c,$b3,$de,$08), ($17,$a4,$c3,$1a), ($1e,$a9,$c8,$14), + ($21,$8a,$f9,$3e), ($28,$87,$f2,$30), ($33,$90,$ef,$22), ($3a,$9d,$e4,$2c), + ($dd,$06,$3d,$96), ($d4,$0b,$36,$98), ($cf,$1c,$2b,$8a), ($c6,$11,$20,$84), + ($f9,$32,$11,$ae), ($f0,$3f,$1a,$a0), ($eb,$28,$07,$b2), ($e2,$25,$0c,$bc), + ($95,$6e,$65,$e6), ($9c,$63,$6e,$e8), ($87,$74,$73,$fa), ($8e,$79,$78,$f4), + ($b1,$5a,$49,$de), ($b8,$57,$42,$d0), ($a3,$40,$5f,$c2), ($aa,$4d,$54,$cc), + ($ec,$da,$f7,$41), ($e5,$d7,$fc,$4f), ($fe,$c0,$e1,$5d), ($f7,$cd,$ea,$53), + ($c8,$ee,$db,$79), ($c1,$e3,$d0,$77), ($da,$f4,$cd,$65), ($d3,$f9,$c6,$6b), + ($a4,$b2,$af,$31), ($ad,$bf,$a4,$3f), ($b6,$a8,$b9,$2d), ($bf,$a5,$b2,$23), + ($80,$86,$83,$09), ($89,$8b,$88,$07), ($92,$9c,$95,$15), ($9b,$91,$9e,$1b), + ($7c,$0a,$47,$a1), ($75,$07,$4c,$af), ($6e,$10,$51,$bd), ($67,$1d,$5a,$b3), + ($58,$3e,$6b,$99), ($51,$33,$60,$97), ($4a,$24,$7d,$85), ($43,$29,$76,$8b), + ($34,$62,$1f,$d1), ($3d,$6f,$14,$df), ($26,$78,$09,$cd), ($2f,$75,$02,$c3), + ($10,$56,$33,$e9), ($19,$5b,$38,$e7), ($02,$4c,$25,$f5), ($0b,$41,$2e,$fb), + ($d7,$61,$8c,$9a), ($de,$6c,$87,$94), ($c5,$7b,$9a,$86), ($cc,$76,$91,$88), + ($f3,$55,$a0,$a2), ($fa,$58,$ab,$ac), ($e1,$4f,$b6,$be), ($e8,$42,$bd,$b0), + ($9f,$09,$d4,$ea), ($96,$04,$df,$e4), ($8d,$13,$c2,$f6), ($84,$1e,$c9,$f8), + ($bb,$3d,$f8,$d2), ($b2,$30,$f3,$dc), ($a9,$27,$ee,$ce), ($a0,$2a,$e5,$c0), + ($47,$b1,$3c,$7a), ($4e,$bc,$37,$74), ($55,$ab,$2a,$66), ($5c,$a6,$21,$68), + ($63,$85,$10,$42), ($6a,$88,$1b,$4c), ($71,$9f,$06,$5e), ($78,$92,$0d,$50), + ($0f,$d9,$64,$0a), ($06,$d4,$6f,$04), ($1d,$c3,$72,$16), ($14,$ce,$79,$18), + ($2b,$ed,$48,$32), ($22,$e0,$43,$3c), ($39,$f7,$5e,$2e), ($30,$fa,$55,$20), + ($9a,$b7,$01,$ec), ($93,$ba,$0a,$e2), ($88,$ad,$17,$f0), ($81,$a0,$1c,$fe), + ($be,$83,$2d,$d4), ($b7,$8e,$26,$da), ($ac,$99,$3b,$c8), ($a5,$94,$30,$c6), + ($d2,$df,$59,$9c), ($db,$d2,$52,$92), ($c0,$c5,$4f,$80), ($c9,$c8,$44,$8e), + ($f6,$eb,$75,$a4), ($ff,$e6,$7e,$aa), ($e4,$f1,$63,$b8), ($ed,$fc,$68,$b6), + ($0a,$67,$b1,$0c), ($03,$6a,$ba,$02), ($18,$7d,$a7,$10), ($11,$70,$ac,$1e), + ($2e,$53,$9d,$34), ($27,$5e,$96,$3a), ($3c,$49,$8b,$28), ($35,$44,$80,$26), + ($42,$0f,$e9,$7c), ($4b,$02,$e2,$72), ($50,$15,$ff,$60), ($59,$18,$f4,$6e), + ($66,$3b,$c5,$44), ($6f,$36,$ce,$4a), ($74,$21,$d3,$58), ($7d,$2c,$d8,$56), + ($a1,$0c,$7a,$37), ($a8,$01,$71,$39), ($b3,$16,$6c,$2b), ($ba,$1b,$67,$25), + ($85,$38,$56,$0f), ($8c,$35,$5d,$01), ($97,$22,$40,$13), ($9e,$2f,$4b,$1d), + ($e9,$64,$22,$47), ($e0,$69,$29,$49), ($fb,$7e,$34,$5b), ($f2,$73,$3f,$55), + ($cd,$50,$0e,$7f), ($c4,$5d,$05,$71), ($df,$4a,$18,$63), ($d6,$47,$13,$6d), + ($31,$dc,$ca,$d7), ($38,$d1,$c1,$d9), ($23,$c6,$dc,$cb), ($2a,$cb,$d7,$c5), + ($15,$e8,$e6,$ef), ($1c,$e5,$ed,$e1), ($07,$f2,$f0,$f3), ($0e,$ff,$fb,$fd), + ($79,$b4,$92,$a7), ($70,$b9,$99,$a9), ($6b,$ae,$84,$bb), ($62,$a3,$8f,$b5), + ($5d,$80,$be,$9f), ($54,$8d,$b5,$91), ($4f,$9a,$a8,$83), ($46,$97,$a3,$8d)); + + rcon: array[0..29] of cardinal= ( + $01, $02, $04, $08, $10, $20, $40, $80, $1b, $36, $6c, $d8, $ab, $4d, $9a, + $2f, $5e, $bc, $63, $c6, $97, $35, $6a, $d4, $b3, $7d, $fa, $ef, $c5, $91); + +{==============================================================================} +type + PDWord = ^LongWord; + +procedure hperm_op(var a, t: integer; n, m: integer); +begin + t:= ((a shl (16 - n)) xor a) and m; + a:= a xor t xor (t shr (16 - n)); +end; + +procedure perm_op(var a, b, t: integer; n, m: integer); +begin + t:= ((a shr n) xor b) and m; + b:= b xor t; + a:= a xor (t shl n); +end; + +{==============================================================================} +function TSynaBlockCipher.GetSize: byte; +begin + Result := 8; +end; + +procedure TSynaBlockCipher.IncCounter; +var + i: integer; +begin + Inc(CV[GetSize]); + i:= GetSize -1; + while (i> 0) and (CV[i + 1] = #0) do + begin + Inc(CV[i]); + Dec(i); + end; +end; + +procedure TSynaBlockCipher.Reset; +begin + CV := IV; +end; + +procedure TSynaBlockCipher.InitKey(Key: AnsiString); +begin +end; + +procedure TSynaBlockCipher.SetIV(const Value: AnsiString); +begin + IV := PadString(Value, GetSize, #0); + Reset; +end; + +function TSynaBlockCipher.GetIV: AnsiString; +begin + Result := CV; +end; + +function TSynaBlockCipher.EncryptECB(const InData: AnsiString): AnsiString; +begin + Result := InData; +end; + +function TSynaBlockCipher.DecryptECB(const InData: AnsiString): AnsiString; +begin + Result := InData; +end; + +function TSynaBlockCipher.EncryptCBC(const Indata: AnsiString): AnsiString; +var + i: integer; + s: ansistring; + l: integer; + bs: byte; +begin + Result := ''; + l := Length(InData); + bs := GetSize; + for i:= 1 to (l div bs) do + begin + s := copy(Indata, (i - 1) * bs + 1, bs); + s := XorString(s, CV); + s := EncryptECB(s); + CV := s; + Result := Result + s; + end; + if (l mod bs)<> 0 then + begin + CV := EncryptECB(CV); + s := copy(Indata, (l div bs) * bs + 1, l mod bs); + s := XorString(s, CV); + Result := Result + s; + end; +end; + +function TSynaBlockCipher.DecryptCBC(const Indata: AnsiString): AnsiString; +var + i: integer; + s, temp: ansistring; + l: integer; + bs: byte; +begin + Result := ''; + l := Length(InData); + bs := GetSize; + for i:= 1 to (l div bs) do + begin + s := copy(Indata, (i - 1) * bs + 1, bs); + temp := s; + s := DecryptECB(s); + s := XorString(s, CV); + Result := Result + s; + CV := Temp; + end; + if (l mod bs)<> 0 then + begin + CV := EncryptECB(CV); + s := copy(Indata, (l div bs) * bs + 1, l mod bs); + s := XorString(s, CV); + Result := Result + s; + end; +end; + +function TSynaBlockCipher.EncryptCFB8bit(const Indata: AnsiString): AnsiString; +var + i: integer; + Temp: AnsiString; + c: AnsiChar; +begin + Result := ''; + for i:= 1 to Length(Indata) do + begin + Temp := EncryptECB(CV); + c := AnsiChar(ord(InData[i]) xor ord(temp[1])); + Result := Result + c; + Delete(CV, 1, 1); + CV := CV + c; + end; +end; + +function TSynaBlockCipher.DecryptCFB8bit(const Indata: AnsiString): AnsiString; +var + i: integer; + Temp: AnsiString; + c: AnsiChar; +begin + Result := ''; + for i:= 1 to length(Indata) do + begin + c:= Indata[i]; + Temp := EncryptECB(CV); + Result := Result + AnsiChar(ord(InData[i]) xor ord(temp[1])); + Delete(CV, 1, 1); + CV := CV + c; + end; +end; + +function TSynaBlockCipher.EncryptCFBblock(const Indata: AnsiString): AnsiString; +var + i: integer; + s: AnsiString; + l: integer; + bs: byte; +begin + Result := ''; + l := Length(InData); + bs := GetSize; + for i:= 1 to (l div bs) do + begin + CV := EncryptECB(CV); + s := copy(Indata, (i - 1) * bs + 1, bs); + s := XorString(s, CV); + Result := Result + s; + CV := s; + end; + if (l mod bs)<> 0 then + begin + CV := EncryptECB(CV); + s := copy(Indata, (l div bs) * bs + 1, l mod bs); + s := XorString(s, CV); + Result := Result + s; + end; +end; + +function TSynaBlockCipher.DecryptCFBblock(const Indata: AnsiString): AnsiString; +var + i: integer; + S, Temp: AnsiString; + l: integer; + bs: byte; +begin + Result := ''; + l := Length(InData); + bs := GetSize; + for i:= 1 to (l div bs) do + begin + s := copy(Indata, (i - 1) * bs + 1, bs); + Temp := s; + CV := EncryptECB(CV); + s := XorString(s, CV); + Result := result + s; + CV := temp; + end; + if (l mod bs)<> 0 then + begin + CV := EncryptECB(CV); + s := copy(Indata, (l div bs) * bs + 1, l mod bs); + s := XorString(s, CV); + Result := Result + s; + end; +end; + +function TSynaBlockCipher.EncryptOFB(const Indata: AnsiString): AnsiString; +var + i: integer; + s: AnsiString; + l: integer; + bs: byte; +begin + Result := ''; + l := Length(InData); + bs := GetSize; + for i:= 1 to (l div bs) do + begin + CV := EncryptECB(CV); + s := copy(Indata, (i - 1) * bs + 1, bs); + s := XorString(s, CV); + Result := Result + s; + end; + if (l mod bs)<> 0 then + begin + CV := EncryptECB(CV); + s := copy(Indata, (l div bs) * bs + 1, l mod bs); + s := XorString(s, CV); + Result := Result + s; + end; +end; + +function TSynaBlockCipher.DecryptOFB(const Indata: AnsiString): AnsiString; +var + i: integer; + s: AnsiString; + l: integer; + bs: byte; +begin + Result := ''; + l := Length(InData); + bs := GetSize; + for i:= 1 to (l div bs) do + begin + Cv := EncryptECB(CV); + s := copy(Indata, (i - 1) * bs + 1, bs); + s := XorString(s, CV); + Result := Result + s; + end; + if (l mod bs)<> 0 then + begin + CV := EncryptECB(CV); + s := copy(Indata, (l div bs) * bs + 1, l mod bs); + s := XorString(s, CV); + Result := Result + s; + end; +end; + +function TSynaBlockCipher.EncryptCTR(const Indata: AnsiString): AnsiString; +var + temp: AnsiString; + i: integer; + s: AnsiString; + l: integer; + bs: byte; +begin + Result := ''; + l := Length(InData); + bs := GetSize; + for i:= 1 to (l div bs) do + begin + temp := EncryptECB(CV); + IncCounter; + s := copy(Indata, (i - 1) * bs + 1, bs); + s := XorString(s, temp); + Result := Result + s; + end; + if (l mod bs)<> 0 then + begin + temp := EncryptECB(CV); + IncCounter; + s := copy(Indata, (l div bs) * bs + 1, l mod bs); + s := XorString(s, temp); + Result := Result + s; + end; +end; + +function TSynaBlockCipher.DecryptCTR(const Indata: AnsiString): AnsiString; +var + temp: AnsiString; + s: AnsiString; + i: integer; + l: integer; + bs: byte; +begin + Result := ''; + l := Length(InData); + bs := GetSize; + for i:= 1 to (l div bs) do + begin + temp := EncryptECB(CV); + IncCounter; + s := copy(Indata, (i - 1) * bs + 1, bs); + s := XorString(s, temp); + Result := Result + s; + end; + if (l mod bs)<> 0 then + begin + temp := EncryptECB(CV); + IncCounter; + s := copy(Indata, (l div bs) * bs + 1, l mod bs); + s := XorString(s, temp); + Result := Result + s; + end; +end; + +constructor TSynaBlockCipher.Create(Key: AnsiString); +begin + inherited Create; + InitKey(Key); + IV := StringOfChar(#0, GetSize); + IV := EncryptECB(IV); + Reset; +end; + +{==============================================================================} + +procedure TSynaCustomDes.DoInit(KeyB: AnsiString; var KeyData: TDesKeyData); +var + c, d, t, s, t2, i: integer; +begin + KeyB := PadString(KeyB, 8, #0); + c:= ord(KeyB[1]) or (ord(KeyB[2]) shl 8) or (ord(KeyB[3]) shl 16) or (ord(KeyB[4]) shl 24); + d:= ord(KeyB[5]) or (ord(KeyB[6]) shl 8) or (ord(KeyB[7]) shl 16) or (ord(KeyB[8]) shl 24); + perm_op(d,c,t,4,integer($0f0f0f0f)); + hperm_op(c,t,integer(-2),integer($cccc0000)); + hperm_op(d,t,integer(-2),integer($cccc0000)); + perm_op(d,c,t,1,integer($55555555)); + perm_op(c,d,t,8,integer($00ff00ff)); + perm_op(d,c,t,1,integer($55555555)); + d:= ((d and $ff) shl 16) or (d and $ff00) or ((d and $ff0000) shr 16) or + ((c and integer($f0000000)) shr 4); + c:= c and $fffffff; + for i:= 0 to 15 do + begin + if shifts2[i]<> 0 then + begin + c:= ((c shr 2) or (c shl 26)); + d:= ((d shr 2) or (d shl 26)); + end + else + begin + c:= ((c shr 1) or (c shl 27)); + d:= ((d shr 1) or (d shl 27)); + end; + c:= c and $fffffff; + d:= d and $fffffff; + s:= des_skb[0,c and $3f] or + des_skb[1,((c shr 6) and $03) or ((c shr 7) and $3c)] or + des_skb[2,((c shr 13) and $0f) or ((c shr 14) and $30)] or + des_skb[3,((c shr 20) and $01) or ((c shr 21) and $06) or ((c shr 22) and $38)]; + t:= des_skb[4,d and $3f] or + des_skb[5,((d shr 7) and $03) or ((d shr 8) and $3c)] or + des_skb[6, (d shr 15) and $3f ] or + des_skb[7,((d shr 21) and $0f) or ((d shr 22) and $30)]; + t2:= ((t shl 16) or (s and $ffff)); + KeyData[(i shl 1)]:= ((t2 shl 2) or (t2 shr 30)); + t2:= ((s shr 16) or (t and integer($ffff0000))); + KeyData[(i shl 1)+1]:= ((t2 shl 6) or (t2 shr 26)); + end; +end; + +function TSynaCustomDes.EncryptBlock(const InData: AnsiString; var KeyData: TDesKeyData): AnsiString; +var + l, r, t, u: integer; + i: longint; +begin + r := Swapbytes(DecodeLongint(Indata, 1)); + l := swapbytes(DecodeLongint(Indata, 5)); + t:= ((l shr 4) xor r) and $0f0f0f0f; + r:= r xor t; + l:= l xor (t shl 4); + t:= ((r shr 16) xor l) and $0000ffff; + l:= l xor t; + r:= r xor (t shl 16); + t:= ((l shr 2) xor r) and $33333333; + r:= r xor t; + l:= l xor (t shl 2); + t:= ((r shr 8) xor l) and $00ff00ff; + l:= l xor t; + r:= r xor (t shl 8); + t:= ((l shr 1) xor r) and $55555555; + r:= r xor t; + l:= l xor (t shl 1); + r:= (r shr 29) or (r shl 3); + l:= (l shr 29) or (l shl 3); + i:= 0; + while i< 32 do + begin + u:= r xor KeyData[i ]; + t:= r xor KeyData[i+1]; + t:= (t shr 4) or (t shl 28); + l:= l xor des_SPtrans[0,(u shr 2) and $3f] xor + des_SPtrans[2,(u shr 10) and $3f] xor + des_SPtrans[4,(u shr 18) and $3f] xor + des_SPtrans[6,(u shr 26) and $3f] xor + des_SPtrans[1,(t shr 2) and $3f] xor + des_SPtrans[3,(t shr 10) and $3f] xor + des_SPtrans[5,(t shr 18) and $3f] xor + des_SPtrans[7,(t shr 26) and $3f]; + u:= l xor KeyData[i+2]; + t:= l xor KeyData[i+3]; + t:= (t shr 4) or (t shl 28); + r:= r xor des_SPtrans[0,(u shr 2) and $3f] xor + des_SPtrans[2,(u shr 10) and $3f] xor + des_SPtrans[4,(u shr 18) and $3f] xor + des_SPtrans[6,(u shr 26) and $3f] xor + des_SPtrans[1,(t shr 2) and $3f] xor + des_SPtrans[3,(t shr 10) and $3f] xor + des_SPtrans[5,(t shr 18) and $3f] xor + des_SPtrans[7,(t shr 26) and $3f]; + u:= r xor KeyData[i+4]; + t:= r xor KeyData[i+5]; + t:= (t shr 4) or (t shl 28); + l:= l xor des_SPtrans[0,(u shr 2) and $3f] xor + des_SPtrans[2,(u shr 10) and $3f] xor + des_SPtrans[4,(u shr 18) and $3f] xor + des_SPtrans[6,(u shr 26) and $3f] xor + des_SPtrans[1,(t shr 2) and $3f] xor + des_SPtrans[3,(t shr 10) and $3f] xor + des_SPtrans[5,(t shr 18) and $3f] xor + des_SPtrans[7,(t shr 26) and $3f]; + u:= l xor KeyData[i+6]; + t:= l xor KeyData[i+7]; + t:= (t shr 4) or (t shl 28); + r:= r xor des_SPtrans[0,(u shr 2) and $3f] xor + des_SPtrans[2,(u shr 10) and $3f] xor + des_SPtrans[4,(u shr 18) and $3f] xor + des_SPtrans[6,(u shr 26) and $3f] xor + des_SPtrans[1,(t shr 2) and $3f] xor + des_SPtrans[3,(t shr 10) and $3f] xor + des_SPtrans[5,(t shr 18) and $3f] xor + des_SPtrans[7,(t shr 26) and $3f]; + Inc(i,8); + end; + r:= (r shr 3) or (r shl 29); + l:= (l shr 3) or (l shl 29); + t:= ((r shr 1) xor l) and $55555555; + l:= l xor t; + r:= r xor (t shl 1); + t:= ((l shr 8) xor r) and $00ff00ff; + r:= r xor t; + l:= l xor (t shl 8); + t:= ((r shr 2) xor l) and $33333333; + l:= l xor t; + r:= r xor (t shl 2); + t:= ((l shr 16) xor r) and $0000ffff; + r:= r xor t; + l:= l xor (t shl 16); + t:= ((r shr 4) xor l) and $0f0f0f0f; + l:= l xor t; + r:= r xor (t shl 4); + Result := CodeLongInt(Swapbytes(l)) + CodeLongInt(Swapbytes(r)); +end; + +function TSynaCustomDes.DecryptBlock(const InData: AnsiString; var KeyData: TDesKeyData): AnsiString; +var + l, r, t, u: integer; + i: longint; +begin + r := Swapbytes(DecodeLongint(Indata, 1)); + l := Swapbytes(DecodeLongint(Indata, 5)); + t:= ((l shr 4) xor r) and $0f0f0f0f; + r:= r xor t; + l:= l xor (t shl 4); + t:= ((r shr 16) xor l) and $0000ffff; + l:= l xor t; + r:= r xor (t shl 16); + t:= ((l shr 2) xor r) and $33333333; + r:= r xor t; + l:= l xor (t shl 2); + t:= ((r shr 8) xor l) and $00ff00ff; + l:= l xor t; + r:= r xor (t shl 8); + t:= ((l shr 1) xor r) and $55555555; + r:= r xor t; + l:= l xor (t shl 1); + r:= (r shr 29) or (r shl 3); + l:= (l shr 29) or (l shl 3); + i:= 30; + while i> 0 do + begin + u:= r xor KeyData[i ]; + t:= r xor KeyData[i+1]; + t:= (t shr 4) or (t shl 28); + l:= l xor des_SPtrans[0,(u shr 2) and $3f] xor + des_SPtrans[2,(u shr 10) and $3f] xor + des_SPtrans[4,(u shr 18) and $3f] xor + des_SPtrans[6,(u shr 26) and $3f] xor + des_SPtrans[1,(t shr 2) and $3f] xor + des_SPtrans[3,(t shr 10) and $3f] xor + des_SPtrans[5,(t shr 18) and $3f] xor + des_SPtrans[7,(t shr 26) and $3f]; + u:= l xor KeyData[i-2]; + t:= l xor KeyData[i-1]; + t:= (t shr 4) or (t shl 28); + r:= r xor des_SPtrans[0,(u shr 2) and $3f] xor + des_SPtrans[2,(u shr 10) and $3f] xor + des_SPtrans[4,(u shr 18) and $3f] xor + des_SPtrans[6,(u shr 26) and $3f] xor + des_SPtrans[1,(t shr 2) and $3f] xor + des_SPtrans[3,(t shr 10) and $3f] xor + des_SPtrans[5,(t shr 18) and $3f] xor + des_SPtrans[7,(t shr 26) and $3f]; + u:= r xor KeyData[i-4]; + t:= r xor KeyData[i-3]; + t:= (t shr 4) or (t shl 28); + l:= l xor des_SPtrans[0,(u shr 2) and $3f] xor + des_SPtrans[2,(u shr 10) and $3f] xor + des_SPtrans[4,(u shr 18) and $3f] xor + des_SPtrans[6,(u shr 26) and $3f] xor + des_SPtrans[1,(t shr 2) and $3f] xor + des_SPtrans[3,(t shr 10) and $3f] xor + des_SPtrans[5,(t shr 18) and $3f] xor + des_SPtrans[7,(t shr 26) and $3f]; + u:= l xor KeyData[i-6]; + t:= l xor KeyData[i-5]; + t:= (t shr 4) or (t shl 28); + r:= r xor des_SPtrans[0,(u shr 2) and $3f] xor + des_SPtrans[2,(u shr 10) and $3f] xor + des_SPtrans[4,(u shr 18) and $3f] xor + des_SPtrans[6,(u shr 26) and $3f] xor + des_SPtrans[1,(t shr 2) and $3f] xor + des_SPtrans[3,(t shr 10) and $3f] xor + des_SPtrans[5,(t shr 18) and $3f] xor + des_SPtrans[7,(t shr 26) and $3f]; + Dec(i,8); + end; + r:= (r shr 3) or (r shl 29); + l:= (l shr 3) or (l shl 29); + t:= ((r shr 1) xor l) and $55555555; + l:= l xor t; + r:= r xor (t shl 1); + t:= ((l shr 8) xor r) and $00ff00ff; + r:= r xor t; + l:= l xor (t shl 8); + t:= ((r shr 2) xor l) and $33333333; + l:= l xor t; + r:= r xor (t shl 2); + t:= ((l shr 16) xor r) and $0000ffff; + r:= r xor t; + l:= l xor (t shl 16); + t:= ((r shr 4) xor l) and $0f0f0f0f; + l:= l xor t; + r:= r xor (t shl 4); + Result := CodeLongInt(Swapbytes(l)) + CodeLongInt(Swapbytes(r)); +end; + +{==============================================================================} + +procedure TSynaDes.InitKey(Key: AnsiString); +begin + Key := PadString(Key, 8, #0); + DoInit(Key,KeyData); +end; + +function TSynaDes.EncryptECB(const InData: AnsiString): AnsiString; +begin + Result := EncryptBlock(InData,KeyData); +end; + +function TSynaDes.DecryptECB(const InData: AnsiString): AnsiString; +begin + Result := DecryptBlock(Indata,KeyData); +end; + +{==============================================================================} + +procedure TSyna3Des.InitKey(Key: AnsiString); +var + Size: integer; + n: integer; +begin + Size := length(Key); + key := PadString(key, 3 * 8, #0); + DoInit(Copy(key, 1, 8),KeyData[0]); + DoInit(Copy(key, 9, 8),KeyData[1]); + if Size > 16 then + DoInit(Copy(key, 17, 8),KeyData[2]) + else + for n := 0 to high(KeyData[0]) do + KeyData[2][n] := Keydata[0][n]; +end; + +function TSyna3Des.EncryptECB(const InData: AnsiString): AnsiString; +begin + Result := EncryptBlock(Indata,KeyData[0]); + Result := DecryptBlock(Result,KeyData[1]); + Result := EncryptBlock(Result,KeyData[2]); +end; + +function TSyna3Des.DecryptECB(const InData: AnsiString): AnsiString; +begin + Result := DecryptBlock(InData,KeyData[2]); + Result := EncryptBlock(Result,KeyData[1]); + Result := DecryptBlock(Result,KeyData[0]); +end; + +{==============================================================================} + +procedure InvMixColumn(a: PByteArray; BC: byte); +var + j: longword; +begin + for j:= 0 to (BC-1) do + PDWord(@(a^[j*4]))^:= PDWord(@U1[a^[j*4+0]])^ + xor PDWord(@U2[a^[j*4+1]])^ + xor PDWord(@U3[a^[j*4+2]])^ + xor PDWord(@U4[a^[j*4+3]])^; +end; + +{==============================================================================} + +function TSynaAes.GetSize: byte; +begin + Result := 16; +end; + +procedure TSynaAes.InitKey(Key: AnsiString); +var + Size: integer; + KC, ROUNDS, j, r, t, rconpointer: longword; + tk: array[0..MAXKC-1,0..3] of byte; + n: integer; +begin + FillChar(tk,Sizeof(tk),0); + //key must have at least 128 bits and max 256 bits + if length(key) < 16 then + key := PadString(key, 16, #0); + if length(key) > 32 then + delete(key, 33, maxint); + Size := length(Key); + Move(PAnsiChar(Key)^, tk, Size); + if Size<= 16 then + begin + KC:= 4; + Rounds:= 10; + end + else if Size<= 24 then + begin + KC:= 6; + Rounds:= 12; + end + else + begin + KC:= 8; + Rounds:= 14; + end; + numrounds:= rounds; + r:= 0; + t:= 0; + j:= 0; + while (j< KC) and (r< (rounds+1)) do + begin + while (j< KC) and (t< BC) do + begin + rk[r,t]:= PDWord(@tk[j])^; + Inc(j); + Inc(t); + end; + if t= BC then + begin + t:= 0; + Inc(r); + end; + end; + rconpointer:= 0; + while (r< (rounds+1)) do + begin + tk[0,0]:= tk[0,0] xor S[tk[KC-1,1]]; + tk[0,1]:= tk[0,1] xor S[tk[KC-1,2]]; + tk[0,2]:= tk[0,2] xor S[tk[KC-1,3]]; + tk[0,3]:= tk[0,3] xor S[tk[KC-1,0]]; + tk[0,0]:= tk[0,0] xor rcon[rconpointer]; + Inc(rconpointer); + if KC<> 8 then + begin + for j:= 1 to (KC-1) do + PDWord(@tk[j])^:= PDWord(@tk[j])^ xor PDWord(@tk[j-1])^; + end + else + begin + for j:= 1 to ((KC div 2)-1) do + PDWord(@tk[j])^:= PDWord(@tk[j])^ xor PDWord(@tk[j-1])^; + tk[KC div 2,0]:= tk[KC div 2,0] xor S[tk[KC div 2 - 1,0]]; + tk[KC div 2,1]:= tk[KC div 2,1] xor S[tk[KC div 2 - 1,1]]; + tk[KC div 2,2]:= tk[KC div 2,2] xor S[tk[KC div 2 - 1,2]]; + tk[KC div 2,3]:= tk[KC div 2,3] xor S[tk[KC div 2 - 1,3]]; + for j:= ((KC div 2) + 1) to (KC-1) do + PDWord(@tk[j])^:= PDWord(@tk[j])^ xor PDWord(@tk[j-1])^; + end; + j:= 0; + while (j< KC) and (r< (rounds+1)) do + begin + while (j< KC) and (t< BC) do + begin + rk[r,t]:= PDWord(@tk[j])^; + Inc(j); + Inc(t); + end; + if t= BC then + begin + Inc(r); + t:= 0; + end; + end; + end; + Move(rk,drk,Sizeof(rk)); + for r:= 1 to (numrounds-1) do + InvMixColumn(@drk[r],BC); +end; + +function TSynaAes.EncryptECB(const InData: AnsiString): AnsiString; +var + r: longword; + tempb: array[0..MAXBC-1,0..3] of byte; + a: array[0..MAXBC,0..3] of byte; + p: pointer; +begin + p := @a[0,0]; + move(pointer(InData)^, p^, 16); + for r:= 0 to (numrounds-2) do + begin + PDWord(@tempb[0])^:= PDWord(@a[0])^ xor rk[r,0]; + PDWord(@tempb[1])^:= PDWord(@a[1])^ xor rk[r,1]; + PDWord(@tempb[2])^:= PDWord(@a[2])^ xor rk[r,2]; + PDWord(@tempb[3])^:= PDWord(@a[3])^ xor rk[r,3]; + PDWord(@a[0])^:= PDWord(@T1[tempb[0,0]])^ xor + PDWord(@T2[tempb[1,1]])^ xor + PDWord(@T3[tempb[2,2]])^ xor + PDWord(@T4[tempb[3,3]])^; + PDWord(@a[1])^:= PDWord(@T1[tempb[1,0]])^ xor + PDWord(@T2[tempb[2,1]])^ xor + PDWord(@T3[tempb[3,2]])^ xor + PDWord(@T4[tempb[0,3]])^; + PDWord(@a[2])^:= PDWord(@T1[tempb[2,0]])^ xor + PDWord(@T2[tempb[3,1]])^ xor + PDWord(@T3[tempb[0,2]])^ xor + PDWord(@T4[tempb[1,3]])^; + PDWord(@a[3])^:= PDWord(@T1[tempb[3,0]])^ xor + PDWord(@T2[tempb[0,1]])^ xor + PDWord(@T3[tempb[1,2]])^ xor + PDWord(@T4[tempb[2,3]])^; + end; + PDWord(@tempb[0])^:= PDWord(@a[0])^ xor rk[numrounds-1,0]; + PDWord(@tempb[1])^:= PDWord(@a[1])^ xor rk[numrounds-1,1]; + PDWord(@tempb[2])^:= PDWord(@a[2])^ xor rk[numrounds-1,2]; + PDWord(@tempb[3])^:= PDWord(@a[3])^ xor rk[numrounds-1,3]; + a[0,0]:= T1[tempb[0,0],1]; + a[0,1]:= T1[tempb[1,1],1]; + a[0,2]:= T1[tempb[2,2],1]; + a[0,3]:= T1[tempb[3,3],1]; + a[1,0]:= T1[tempb[1,0],1]; + a[1,1]:= T1[tempb[2,1],1]; + a[1,2]:= T1[tempb[3,2],1]; + a[1,3]:= T1[tempb[0,3],1]; + a[2,0]:= T1[tempb[2,0],1]; + a[2,1]:= T1[tempb[3,1],1]; + a[2,2]:= T1[tempb[0,2],1]; + a[2,3]:= T1[tempb[1,3],1]; + a[3,0]:= T1[tempb[3,0],1]; + a[3,1]:= T1[tempb[0,1],1]; + a[3,2]:= T1[tempb[1,2],1]; + a[3,3]:= T1[tempb[2,3],1]; + PDWord(@a[0])^:= PDWord(@a[0])^ xor rk[numrounds,0]; + PDWord(@a[1])^:= PDWord(@a[1])^ xor rk[numrounds,1]; + PDWord(@a[2])^:= PDWord(@a[2])^ xor rk[numrounds,2]; + PDWord(@a[3])^:= PDWord(@a[3])^ xor rk[numrounds,3]; + + Result := StringOfChar(#0, 16); + move(p^, pointer(Result)^, 16); +end; + +function TSynaAes.DecryptECB(const InData: AnsiString): AnsiString; +var + r: longword; + tempb: array[0..MAXBC-1,0..3] of byte; + a: array[0..MAXBC,0..3] of byte; + p: pointer; +begin + p := @a[0,0]; + move(pointer(InData)^, p^, 16); + for r:= NumRounds downto 2 do + begin + PDWord(@tempb[0])^:= PDWord(@a[0])^ xor drk[r,0]; + PDWord(@tempb[1])^:= PDWord(@a[1])^ xor drk[r,1]; + PDWord(@tempb[2])^:= PDWord(@a[2])^ xor drk[r,2]; + PDWord(@tempb[3])^:= PDWord(@a[3])^ xor drk[r,3]; + PDWord(@a[0])^:= PDWord(@T5[tempb[0,0]])^ xor + PDWord(@T6[tempb[3,1]])^ xor + PDWord(@T7[tempb[2,2]])^ xor + PDWord(@T8[tempb[1,3]])^; + PDWord(@a[1])^:= PDWord(@T5[tempb[1,0]])^ xor + PDWord(@T6[tempb[0,1]])^ xor + PDWord(@T7[tempb[3,2]])^ xor + PDWord(@T8[tempb[2,3]])^; + PDWord(@a[2])^:= PDWord(@T5[tempb[2,0]])^ xor + PDWord(@T6[tempb[1,1]])^ xor + PDWord(@T7[tempb[0,2]])^ xor + PDWord(@T8[tempb[3,3]])^; + PDWord(@a[3])^:= PDWord(@T5[tempb[3,0]])^ xor + PDWord(@T6[tempb[2,1]])^ xor + PDWord(@T7[tempb[1,2]])^ xor + PDWord(@T8[tempb[0,3]])^; + end; + PDWord(@tempb[0])^:= PDWord(@a[0])^ xor drk[1,0]; + PDWord(@tempb[1])^:= PDWord(@a[1])^ xor drk[1,1]; + PDWord(@tempb[2])^:= PDWord(@a[2])^ xor drk[1,2]; + PDWord(@tempb[3])^:= PDWord(@a[3])^ xor drk[1,3]; + a[0,0]:= S5[tempb[0,0]]; + a[0,1]:= S5[tempb[3,1]]; + a[0,2]:= S5[tempb[2,2]]; + a[0,3]:= S5[tempb[1,3]]; + a[1,0]:= S5[tempb[1,0]]; + a[1,1]:= S5[tempb[0,1]]; + a[1,2]:= S5[tempb[3,2]]; + a[1,3]:= S5[tempb[2,3]]; + a[2,0]:= S5[tempb[2,0]]; + a[2,1]:= S5[tempb[1,1]]; + a[2,2]:= S5[tempb[0,2]]; + a[2,3]:= S5[tempb[3,3]]; + a[3,0]:= S5[tempb[3,0]]; + a[3,1]:= S5[tempb[2,1]]; + a[3,2]:= S5[tempb[1,2]]; + a[3,3]:= S5[tempb[0,3]]; + PDWord(@a[0])^:= PDWord(@a[0])^ xor drk[0,0]; + PDWord(@a[1])^:= PDWord(@a[1])^ xor drk[0,1]; + PDWord(@a[2])^:= PDWord(@a[2])^ xor drk[0,2]; + PDWord(@a[3])^:= PDWord(@a[3])^ xor drk[0,3]; + Result := StringOfChar(#0, 16); + move(p^, pointer(Result)^, 16); +end; + +{==============================================================================} + +function TestDes: boolean; +var + des: TSynaDes; + s, t: string; +const + key = '01234567'; + data1= '01234567'; + data2= '0123456789abcdefghij'; +begin + //ECB + des := TSynaDes.Create(key); + try + s := des.EncryptECB(data1); + t := strtohex(s); + result := t = 'c50ad028c6da9800'; + s := des.DecryptECB(s); + result := result and (data1 = s); + finally + des.free; + end; + //CBC + des := TSynaDes.Create(key); + try + s := des.EncryptCBC(data2); + t := strtohex(s); + result := result and (t = 'eec50f6353115ad6dee90a22ed1b6a88a0926e35'); + des.Reset; + s := des.DecryptCBC(s); + result := result and (data2 = s); + finally + des.free; + end; + //CFB-8bit + des := TSynaDes.Create(key); + try + s := des.EncryptCFB8bit(data2); + t := strtohex(s); + result := result and (t = 'eb6aa12c2f0ff634b4dfb6da6cb2af8f9c5c1452'); + des.Reset; + s := des.DecryptCFB8bit(s); + result := result and (data2 = s); + finally + des.free; + end; + //CFB-block + des := TSynaDes.Create(key); + try + s := des.EncryptCFBblock(data2); + t := strtohex(s); + result := result and (t = 'ebdbbaa7f9286cdec28605e07f9b7f3be1053257'); + des.Reset; + s := des.DecryptCFBblock(s); + result := result and (data2 = s); + finally + des.free; + end; + //OFB + des := TSynaDes.Create(key); + try + s := des.EncryptOFB(data2); + t := strtohex(s); + result := result and (t = 'ebdbbaa7f9286cdee0b8b3798c4c34baac87dbdc'); + des.Reset; + s := des.DecryptOFB(s); + result := result and (data2 = s); + finally + des.free; + end; + //CTR + des := TSynaDes.Create(key); + try + s := des.EncryptCTR(data2); + t := strtohex(s); + result := result and (t = 'ebdbbaa7f9286cde0dd20b45f3afd9aa1b91b87e'); + des.Reset; + s := des.DecryptCTR(s); + result := result and (data2 = s); + finally + des.free; + end; +end; + +function Test3Des: boolean; +var + des: TSyna3Des; + s, t: string; +const + key = '0123456789abcdefghijklmn'; + data1= '01234567'; + data2= '0123456789abcdefghij'; +begin + //ECB + des := TSyna3Des.Create(key); + try + s := des.EncryptECB(data1); + t := strtohex(s); + result := t = 'e0dee91008dc460c'; + s := des.DecryptECB(s); + result := result and (data1 = s); + finally + des.free; + end; + //CBC + des := TSyna3Des.Create(key); + try + s := des.EncryptCBC(data2); + t := strtohex(s); + result := result and (t = 'ee844a2a4f49c01b91a1599b8eba29128c1ad87a'); + des.Reset; + s := des.DecryptCBC(s); + result := result and (data2 = s); + finally + des.free; + end; + //CFB-8bit + des := TSyna3Des.Create(key); + try + s := des.EncryptCFB8bit(data2); + t := strtohex(s); + result := result and (t = '935bbf5210c32cfa1faf61f91e8dc02dfa0ff1e8'); + des.Reset; + s := des.DecryptCFB8bit(s); + result := result and (data2 = s); + finally + des.free; + end; + //CFB-block + des := TSyna3Des.Create(key); + try + s := des.EncryptCFBblock(data2); + t := strtohex(s); + result := result and (t = '93754e3d54828fbf4bd81f1739419e8d2cfe1671'); + des.Reset; + s := des.DecryptCFBblock(s); + result := result and (data2 = s); + finally + des.free; + end; + //OFB + des := TSyna3Des.Create(key); + try + s := des.EncryptOFB(data2); + t := strtohex(s); + result := result and (t = '93754e3d54828fbf04ef0a5efc926ebdf2d95f20'); + des.Reset; + s := des.DecryptOFB(s); + result := result and (data2 = s); + finally + des.free; + end; + //CTR + des := TSyna3Des.Create(key); + try + s := des.EncryptCTR(data2); + t := strtohex(s); + result := result and (t = '93754e3d54828fbf1c51a121d2c93f989e70b3ad'); + des.Reset; + s := des.DecryptCTR(s); + result := result and (data2 = s); + finally + des.free; + end; +end; + +function TestAes: boolean; +var + aes: TSynaAes; + s, t: string; +const + key1 = #$00#$01#$02#$03#$05#$06#$07#$08#$0A#$0B#$0C#$0D#$0F#$10#$11#$12; + data1= #$50#$68#$12#$A4#$5F#$08#$C8#$89#$B9#$7F#$59#$80#$03#$8B#$83#$59; + key2 = #$A0#$A1#$A2#$A3#$A5#$A6#$A7#$A8#$AA#$AB#$AC#$AD#$AF#$B0#$B1#$B2#$B4#$B5#$B6#$B7#$B9#$BA#$BB#$BC; + data2= #$4F#$1C#$76#$9D#$1E#$5B#$05#$52#$C7#$EC#$A8#$4D#$EA#$26#$A5#$49; + key3 = #$00#$01#$02#$03#$05#$06#$07#$08#$0A#$0B#$0C#$0D#$0F#$10#$11#$12#$14#$15#$16#$17#$19#$1A#$1B#$1C#$1E#$1F#$20#$21#$23#$24#$25#$26; + data3= #$5E#$25#$CA#$78#$F0#$DE#$55#$80#$25#$24#$D3#$8D#$A3#$FE#$44#$56; +begin + //ECB + aes := TSynaAes.Create(key1); + try + t := aes.EncryptECB(data1); + result := t = #$D8#$F5#$32#$53#$82#$89#$EF#$7D#$06#$B5#$06#$A4#$FD#$5B#$E9#$C9; + s := aes.DecryptECB(t); + result := result and (data1 = s); + finally + aes.free; + end; + aes := TSynaAes.Create(key2); + try + t := aes.EncryptECB(data2); + result := result and (t = #$F3#$84#$72#$10#$D5#$39#$1E#$23#$60#$60#$8E#$5A#$CB#$56#$05#$81); + s := aes.DecryptECB(t); + result := result and (data2 = s); + finally + aes.free; + end; + aes := TSynaAes.Create(key3); + try + t := aes.EncryptECB(data3); + result := result and (t = #$E8#$B7#$2B#$4E#$8B#$E2#$43#$43#$8C#$9F#$FF#$1F#$0E#$20#$58#$72); + s := aes.DecryptECB(t); + result := result and (data3 = s); + finally + aes.free; + end; +end; + +{==============================================================================} + +end. diff --git a/synapse/synadbg.pas b/synapse/synadbg.pas new file mode 100644 index 0000000..6f60f4c --- /dev/null +++ b/synapse/synadbg.pas @@ -0,0 +1,156 @@ +{==============================================================================| +| Project : Ararat Synapse | 001.001.002 | +|==============================================================================| +| Content: Socket debug tools | +|==============================================================================| +| Copyright (c)2008-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)2008-2011. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +{:@abstract(Socket debug tools) + +Routines for help with debugging of events on the Sockets. +} + +{$IFDEF UNICODE} + {$WARN IMPLICIT_STRING_CAST OFF} + {$WARN IMPLICIT_STRING_CAST_LOSS OFF} +{$ENDIF} + +unit synadbg; + +interface + +uses + blcksock, synsock, synautil, classes, sysutils, synafpc; + +type + TSynaDebug = class(TObject) + class procedure HookStatus(Sender: TObject; Reason: THookSocketReason; const Value: string); + class procedure HookMonitor(Sender: TObject; Writing: Boolean; const Buffer: TMemory; Len: Integer); + end; + +procedure AppendToLog(const value: Ansistring); + +var + LogFile: string; + +implementation + +procedure AppendToLog(const value: Ansistring); +var + st: TFileStream; + s: string; + h, m, ss, ms: word; + dt: Tdatetime; +begin + if fileexists(LogFile) then + st := TFileStream.Create(LogFile, fmOpenReadWrite or fmShareDenyWrite) + else + st := TFileStream.Create(LogFile, fmCreate or fmShareDenyWrite); + try + st.Position := st.Size; + dt := now; + decodetime(dt, h, m, ss, ms); + s := formatdatetime('yyyymmdd-hhnnss', dt) + format('.%.3d', [ms]) + ' ' + value; + WriteStrToStream(st, s); + finally + st.free; + end; +end; + +class procedure TSynaDebug.HookStatus(Sender: TObject; Reason: THookSocketReason; const Value: string); +var + s: string; +begin + case Reason of + HR_ResolvingBegin: + s := 'HR_ResolvingBegin'; + HR_ResolvingEnd: + s := 'HR_ResolvingEnd'; + HR_SocketCreate: + s := 'HR_SocketCreate'; + HR_SocketClose: + s := 'HR_SocketClose'; + HR_Bind: + s := 'HR_Bind'; + HR_Connect: + s := 'HR_Connect'; + HR_CanRead: + s := 'HR_CanRead'; + HR_CanWrite: + s := 'HR_CanWrite'; + HR_Listen: + s := 'HR_Listen'; + HR_Accept: + s := 'HR_Accept'; + HR_ReadCount: + s := 'HR_ReadCount'; + HR_WriteCount: + s := 'HR_WriteCount'; + HR_Wait: + s := 'HR_Wait'; + HR_Error: + s := 'HR_Error'; + else + s := '-unknown-'; + end; + s := inttohex(PtrInt(Sender), 8) + s + ': ' + value + CRLF; + AppendToLog(s); +end; + +class procedure TSynaDebug.HookMonitor(Sender: TObject; Writing: Boolean; const Buffer: TMemory; Len: Integer); +var + s, d: Ansistring; +begin + setlength(s, len); + move(Buffer^, pointer(s)^, len); + if writing then + d := '-> ' + else + d := '<- '; + s :=inttohex(PtrInt(Sender), 8) + d + s + CRLF; + AppendToLog(s); +end; + +initialization +begin + Logfile := changefileext(paramstr(0), '.slog'); +end; + +end. diff --git a/synapse/synafpc.pas b/synapse/synafpc.pas new file mode 100644 index 0000000..04e8358 --- /dev/null +++ b/synapse/synafpc.pas @@ -0,0 +1,141 @@ +{==============================================================================| +| Project : Ararat Synapse | 001.002.000 | +|==============================================================================| +| Content: Utils for FreePascal compatibility | +|==============================================================================| +| 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)2003-2011. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +{:@exclude} + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$H+} +//old Delphi does not have MSWINDOWS define. +{$IFDEF WIN32} + {$IFNDEF MSWINDOWS} + {$DEFINE MSWINDOWS} + {$ENDIF} +{$ENDIF} + +unit synafpc; + +interface + +uses +{$IFDEF FPC} + dynlibs, sysutils; +{$ELSE} + {$IFDEF MSWINDOWS} + Windows; + {$ELSE} + SysUtils; + {$ENDIF} +{$ENDIF} + +{$IFDEF FPC} +type + TLibHandle = dynlibs.TLibHandle; + +function LoadLibrary(ModuleName: PChar): TLibHandle; +function FreeLibrary(Module: TLibHandle): LongBool; +function GetProcAddress(Module: TLibHandle; Proc: PChar): Pointer; +function GetModuleFileName(Module: TLibHandle; Buffer: PChar; BufLen: Integer): Integer; +{$ELSE} +type + {$IFDEF CIL} + TLibHandle = Integer; + PtrInt = Integer; + {$ELSE} + TLibHandle = HModule; + {$IFNDEF WIN64} + PtrInt = Integer; + {$ENDIF} + {$ENDIF} + {$IFDEF VER100} + LongWord = DWord; + {$ENDIF} +{$ENDIF} + +procedure Sleep(milliseconds: Cardinal); + + +implementation + +{==============================================================================} +{$IFDEF FPC} +function LoadLibrary(ModuleName: PChar): TLibHandle; +begin + Result := dynlibs.LoadLibrary(Modulename); +end; + +function FreeLibrary(Module: TLibHandle): LongBool; +begin + Result := dynlibs.UnloadLibrary(Module); +end; + +function GetProcAddress(Module: TLibHandle; Proc: PChar): Pointer; +begin + Result := dynlibs.GetProcedureAddress(Module, Proc); +end; + +function GetModuleFileName(Module: TLibHandle; Buffer: PChar; BufLen: Integer): Integer; +begin + Result := 0; +end; + +{$ELSE} +{$ENDIF} + +procedure Sleep(milliseconds: Cardinal); +begin +{$IFDEF MSWINDOWS} + {$IFDEF FPC} + sysutils.sleep(milliseconds); + {$ELSE} + windows.sleep(milliseconds); + {$ENDIF} +{$ELSE} + sysutils.sleep(milliseconds); +{$ENDIF} + +end; + +end. diff --git a/synapse/synaicnv.pas b/synapse/synaicnv.pas new file mode 100644 index 0000000..3dd79c5 --- /dev/null +++ b/synapse/synaicnv.pas @@ -0,0 +1,363 @@ +{==============================================================================| +| Project : Ararat Synapse | 001.001.001 | +|==============================================================================| +| Content: ICONV support for Win32, Linux and .NET | +|==============================================================================| +| Copyright (c)2004-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)2004-2010. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$H+} +//old Delphi does not have MSWINDOWS define. +{$IFDEF WIN32} + {$IFNDEF MSWINDOWS} + {$DEFINE MSWINDOWS} + {$ENDIF} +{$ENDIF} + +{:@abstract(LibIconv support) + +This unit is Pascal interface to LibIconv library for charset translations. +LibIconv is loaded dynamicly on-demand. If this library is not found in system, +requested LibIconv function just return errorcode. +} +unit synaicnv; + +interface + +uses +{$IFDEF CIL} + System.Runtime.InteropServices, + System.Text, +{$ENDIF} + synafpc, +{$IFNDEF MSWINDOWS} + {$IFNDEF FPC} + Libc, + {$ENDIF} + SysUtils; +{$ELSE} + Windows; +{$ENDIF} + + +const + {$IFNDEF MSWINDOWS} + DLLIconvName = 'libiconv.so'; + {$ELSE} + DLLIconvName = 'iconv.dll'; + {$ENDIF} + +type + size_t = Cardinal; +{$IFDEF CIL} + iconv_t = IntPtr; +{$ELSE} + iconv_t = Pointer; +{$ENDIF} + argptr = iconv_t; + +var + iconvLibHandle: TLibHandle = 0; + +function SynaIconvOpen(const tocode, fromcode: Ansistring): iconv_t; +function SynaIconvOpenTranslit(const tocode, fromcode: Ansistring): iconv_t; +function SynaIconvOpenIgnore(const tocode, fromcode: Ansistring): iconv_t; +function SynaIconv(cd: iconv_t; inbuf: AnsiString; var outbuf: AnsiString): integer; +function SynaIconvClose(var cd: iconv_t): integer; +function SynaIconvCtl(cd: iconv_t; request: integer; argument: argptr): integer; + +function IsIconvloaded: Boolean; +function InitIconvInterface: Boolean; +function DestroyIconvInterface: Boolean; + +const + ICONV_TRIVIALP = 0; // int *argument + ICONV_GET_TRANSLITERATE = 1; // int *argument + ICONV_SET_TRANSLITERATE = 2; // const int *argument + ICONV_GET_DISCARD_ILSEQ = 3; // int *argument + ICONV_SET_DISCARD_ILSEQ = 4; // const int *argument + + +implementation + +uses SyncObjs; + +{$IFDEF CIL} + [DllImport(DLLIconvName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'libiconv_open')] + function _iconv_open(tocode: string; fromcode: string): iconv_t; external; + + [DllImport(DLLIconvName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'libiconv')] + function _iconv(cd: iconv_t; var inbuf: IntPtr; var inbytesleft: size_t; + var outbuf: IntPtr; var outbytesleft: size_t): size_t; external; + + [DllImport(DLLIconvName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'libiconv_close')] + function _iconv_close(cd: iconv_t): integer; external; + + [DllImport(DLLIconvName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'libiconvctl')] + function _iconvctl(cd: iconv_t; request: integer; argument: argptr): integer; external; + +{$ELSE} +type + Ticonv_open = function(tocode: pAnsichar; fromcode: pAnsichar): iconv_t; cdecl; + Ticonv = function(cd: iconv_t; var inbuf: pointer; var inbytesleft: size_t; + var outbuf: pointer; var outbytesleft: size_t): size_t; cdecl; + Ticonv_close = function(cd: iconv_t): integer; cdecl; + Ticonvctl = function(cd: iconv_t; request: integer; argument: argptr): integer; cdecl; +var + _iconv_open: Ticonv_open = nil; + _iconv: Ticonv = nil; + _iconv_close: Ticonv_close = nil; + _iconvctl: Ticonvctl = nil; +{$ENDIF} + + +var + IconvCS: TCriticalSection; + Iconvloaded: boolean = false; + +function SynaIconvOpen (const tocode, fromcode: Ansistring): iconv_t; +begin +{$IFDEF CIL} + try + Result := _iconv_open(tocode, fromcode); + except + on Exception do + Result := iconv_t(-1); + end; +{$ELSE} + if InitIconvInterface and Assigned(_iconv_open) then + Result := _iconv_open(PAnsiChar(tocode), PAnsiChar(fromcode)) + else + Result := iconv_t(-1); +{$ENDIF} +end; + +function SynaIconvOpenTranslit (const tocode, fromcode: Ansistring): iconv_t; +begin + Result := SynaIconvOpen(tocode + '//IGNORE//TRANSLIT', fromcode); +end; + +function SynaIconvOpenIgnore (const tocode, fromcode: Ansistring): iconv_t; +begin + Result := SynaIconvOpen(tocode + '//IGNORE', fromcode); +end; + +function SynaIconv (cd: iconv_t; inbuf: AnsiString; var outbuf: AnsiString): integer; +var +{$IFDEF CIL} + ib, ob: IntPtr; + ibsave, obsave: IntPtr; + l: integer; +{$ELSE} + ib, ob: Pointer; +{$ENDIF} + ix, ox: size_t; +begin +{$IFDEF CIL} + l := Length(inbuf) * 4; + ibsave := IntPtr.Zero; + obsave := IntPtr.Zero; + try + ibsave := Marshal.StringToHGlobalAnsi(inbuf); + obsave := Marshal.AllocHGlobal(l); + ib := ibsave; + ob := obsave; + ix := Length(inbuf); + ox := l; + _iconv(cd, ib, ix, ob, ox); + Outbuf := Marshal.PtrToStringAnsi(obsave, l); + setlength(Outbuf, l - ox); + Result := Length(inbuf) - ix; + finally + Marshal.FreeCoTaskMem(ibsave); + Marshal.FreeHGlobal(obsave); + end; +{$ELSE} + if InitIconvInterface and Assigned(_iconv) then + begin + setlength(Outbuf, Length(inbuf) * 4); + ib := Pointer(inbuf); + ob := Pointer(Outbuf); + ix := Length(inbuf); + ox := Length(Outbuf); + _iconv(cd, ib, ix, ob, ox); + setlength(Outbuf, cardinal(Length(Outbuf)) - ox); + Result := Cardinal(Length(inbuf)) - ix; + end + else + begin + Outbuf := ''; + Result := 0; + end; +{$ENDIF} +end; + +function SynaIconvClose(var cd: iconv_t): integer; +begin + if cd = iconv_t(-1) then + begin + Result := 0; + Exit; + end; +{$IFDEF CIL} + try; + Result := _iconv_close(cd) + except + on Exception do + Result := -1; + end; + cd := iconv_t(-1); +{$ELSE} + if InitIconvInterface and Assigned(_iconv_close) then + Result := _iconv_close(cd) + else + Result := -1; + cd := iconv_t(-1); +{$ENDIF} +end; + +function SynaIconvCtl (cd: iconv_t; request: integer; argument: argptr): integer; +begin +{$IFDEF CIL} + Result := _iconvctl(cd, request, argument) +{$ELSE} + if InitIconvInterface and Assigned(_iconvctl) then + Result := _iconvctl(cd, request, argument) + else + Result := 0; +{$ENDIF} +end; + +function InitIconvInterface: Boolean; +begin + IconvCS.Enter; + try + if not IsIconvloaded then + begin +{$IFDEF CIL} + IconvLibHandle := 1; +{$ELSE} + IconvLibHandle := LoadLibrary(PChar(DLLIconvName)); +{$ENDIF} + if (IconvLibHandle <> 0) then + begin +{$IFNDEF CIL} + _iconv_open := GetProcAddress(IconvLibHandle, PAnsiChar(AnsiString('libiconv_open'))); + _iconv := GetProcAddress(IconvLibHandle, PAnsiChar(AnsiString('libiconv'))); + _iconv_close := GetProcAddress(IconvLibHandle, PAnsiChar(AnsiString('libiconv_close'))); + _iconvctl := GetProcAddress(IconvLibHandle, PAnsiChar(AnsiString('libiconvctl'))); +{$ENDIF} + Result := True; + Iconvloaded := True; + end + else + begin + //load failed! + if IconvLibHandle <> 0 then + begin +{$IFNDEF CIL} + FreeLibrary(IconvLibHandle); +{$ENDIF} + IconvLibHandle := 0; + end; + Result := False; + end; + end + else + //loaded before... + Result := true; + finally + IconvCS.Leave; + end; +end; + +function DestroyIconvInterface: Boolean; +begin + IconvCS.Enter; + try + Iconvloaded := false; + if IconvLibHandle <> 0 then + begin +{$IFNDEF CIL} + FreeLibrary(IconvLibHandle); +{$ENDIF} + IconvLibHandle := 0; + end; +{$IFNDEF CIL} + _iconv_open := nil; + _iconv := nil; + _iconv_close := nil; + _iconvctl := nil; +{$ENDIF} + finally + IconvCS.Leave; + end; + Result := True; +end; + +function IsIconvloaded: Boolean; +begin + Result := IconvLoaded; +end; + + initialization +begin + IconvCS:= TCriticalSection.Create; +end; + +finalization +begin +{$IFNDEF CIL} + DestroyIconvInterface; +{$ENDIF} + IconvCS.Free; +end; + +end. diff --git a/synapse/synaip.pas b/synapse/synaip.pas new file mode 100644 index 0000000..82a7da4 --- /dev/null +++ b/synapse/synaip.pas @@ -0,0 +1,422 @@ +{==============================================================================| +| Project : Ararat Synapse | 001.002.001 | +|==============================================================================| +| Content: IP address support procedures and functions | +|==============================================================================| +| Copyright (c)2006-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) 2006-2010. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +{:@abstract(IP adress support procedures and functions)} + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$Q-} +{$R-} +{$H+} + +{$IFDEF UNICODE} + {$WARN IMPLICIT_STRING_CAST OFF} + {$WARN IMPLICIT_STRING_CAST_LOSS OFF} + {$WARN SUSPICIOUS_TYPECAST OFF} +{$ENDIF} + +unit synaip; + +interface + +uses + SysUtils, SynaUtil; + +type +{:binary form of IPv6 adress (for string conversion routines)} + TIp6Bytes = array [0..15] of Byte; +{:binary form of IPv6 adress (for string conversion routines)} + TIp6Words = array [0..7] of Word; + +{:Returns @TRUE, if "Value" is a valid IPv4 address. Cannot be a symbolic Name!} +function IsIP(const Value: string): Boolean; + +{:Returns @TRUE, if "Value" is a valid IPv6 address. Cannot be a symbolic Name!} +function IsIP6(const Value: string): Boolean; + +{:Returns a string with the "Host" ip address converted to binary form.} +function IPToID(Host: string): Ansistring; + +{:Convert IPv6 address from their string form to binary byte array.} +function StrToIp6(value: string): TIp6Bytes; + +{:Convert IPv6 address from binary byte array to string form.} +function Ip6ToStr(value: TIp6Bytes): string; + +{:Convert IPv4 address from their string form to binary.} +function StrToIp(value: string): integer; + +{:Convert IPv4 address from binary to string form.} +function IpToStr(value: integer): string; + +{:Convert IPv4 address to reverse form.} +function ReverseIP(Value: AnsiString): AnsiString; + +{:Convert IPv6 address to reverse form.} +function ReverseIP6(Value: AnsiString): AnsiString; + +{:Expand short form of IPv6 address to long form.} +function ExpandIP6(Value: AnsiString): AnsiString; + + +implementation + +{==============================================================================} + +function IsIP(const Value: string): Boolean; +var + TempIP: string; + function ByteIsOk(const Value: string): Boolean; + var + x, n: integer; + begin + x := StrToIntDef(Value, -1); + Result := (x >= 0) and (x < 256); + // X may be in correct range, but value still may not be correct value! + // i.e. "$80" + if Result then + for n := 1 to length(Value) do + if not (AnsiChar(Value[n]) in ['0'..'9']) then + begin + Result := False; + Break; + end; + end; +begin + TempIP := Value; + Result := False; + if not ByteIsOk(Fetch(TempIP, '.')) then + Exit; + if not ByteIsOk(Fetch(TempIP, '.')) then + Exit; + if not ByteIsOk(Fetch(TempIP, '.')) then + Exit; + if ByteIsOk(TempIP) then + Result := True; +end; + +{==============================================================================} + +function IsIP6(const Value: string): Boolean; +var + TempIP: string; + s,t: string; + x: integer; + partcount: integer; + zerocount: integer; + First: Boolean; +begin + TempIP := Value; + Result := False; + if Value = '::' then + begin + Result := True; + Exit; + end; + partcount := 0; + zerocount := 0; + First := True; + while tempIP <> '' do + begin + s := fetch(TempIP, ':'); + if not(First) and (s = '') then + Inc(zerocount); + First := False; + if zerocount > 1 then + break; + Inc(partCount); + if s = '' then + Continue; + if partCount > 8 then + break; + if tempIP = '' then + begin + t := SeparateRight(s, '%'); + s := SeparateLeft(s, '%'); + x := StrToIntDef('$' + t, -1); + if (x < 0) or (x > $ffff) then + break; + end; + x := StrToIntDef('$' + s, -1); + if (x < 0) or (x > $ffff) then + break; + if tempIP = '' then + if not((PartCount = 1) and (ZeroCount = 0)) then + Result := True; + end; +end; + +{==============================================================================} +function IPToID(Host: string): Ansistring; +var + s: string; + i, x: Integer; +begin + Result := ''; + for x := 0 to 3 do + begin + s := Fetch(Host, '.'); + i := StrToIntDef(s, 0); + Result := Result + AnsiChar(i); + end; +end; + +{==============================================================================} + +function StrToIp(value: string): integer; +var + s: string; + i, x: Integer; +begin + Result := 0; + for x := 0 to 3 do + begin + s := Fetch(value, '.'); + i := StrToIntDef(s, 0); + Result := (256 * Result) + i; + end; +end; + +{==============================================================================} + +function IpToStr(value: integer): string; +var + x1, x2: word; + y1, y2: byte; +begin + Result := ''; + x1 := value shr 16; + x2 := value and $FFFF; + y1 := x1 div $100; + y2 := x1 mod $100; + Result := inttostr(y1) + '.' + inttostr(y2) + '.'; + y1 := x2 div $100; + y2 := x2 mod $100; + Result := Result + inttostr(y1) + '.' + inttostr(y2); +end; + +{==============================================================================} + +function ExpandIP6(Value: AnsiString): AnsiString; +var + n: integer; + s: ansistring; + x: integer; +begin + Result := ''; + if value = '' then + exit; + x := countofchar(value, ':'); + if x > 7 then + exit; + if value[1] = ':' then + value := '0' + value; + if value[length(value)] = ':' then + value := value + '0'; + x := 8 - x; + s := ''; + for n := 1 to x do + s := s + ':0'; + s := s + ':'; + Result := replacestring(value, '::', s); +end; +{==============================================================================} + +function StrToIp6(Value: string): TIp6Bytes; +var + IPv6: TIp6Words; + Index: Integer; + n: integer; + b1, b2: byte; + s: string; + x: integer; +begin + for n := 0 to 15 do + Result[n] := 0; + for n := 0 to 7 do + Ipv6[n] := 0; + Index := 0; + Value := ExpandIP6(value); + if value = '' then + exit; + while Value <> '' do + begin + if Index > 7 then + Exit; + s := fetch(value, ':'); + if s = '@' then + break; + if s = '' then + begin + IPv6[Index] := 0; + end + else + begin + x := StrToIntDef('$' + s, -1); + if (x > 65535) or (x < 0) then + Exit; + IPv6[Index] := x; + end; + Inc(Index); + end; + for n := 0 to 7 do + begin + b1 := ipv6[n] div 256; + b2 := ipv6[n] mod 256; + Result[n * 2] := b1; + Result[(n * 2) + 1] := b2; + end; +end; + +{==============================================================================} +//based on routine by the Free Pascal development team +function Ip6ToStr(value: TIp6Bytes): string; +var + i, x: byte; + zr1,zr2: set of byte; + zc1,zc2: byte; + have_skipped: boolean; + ip6w: TIp6words; +begin + zr1 := []; + zr2 := []; + zc1 := 0; + zc2 := 0; + for i := 0 to 7 do + begin + x := i * 2; + ip6w[i] := value[x] * 256 + value[x + 1]; + if ip6w[i] = 0 then + begin + include(zr2, i); + inc(zc2); + end + else + begin + if zc1 < zc2 then + begin + zc1 := zc2; + zr1 := zr2; + zc2 := 0; + zr2 := []; + end; + end; + end; + if zc1 < zc2 then + begin + zr1 := zr2; + end; + SetLength(Result, 8*5-1); + SetLength(Result, 0); + have_skipped := false; + for i := 0 to 7 do + begin + if not(i in zr1) then + begin + if have_skipped then + begin + if Result = '' then + Result := '::' + else + Result := Result + ':'; + have_skipped := false; + end; + Result := Result + IntToHex(Ip6w[i], 1) + ':'; + end + else + begin + have_skipped := true; + end; + end; + if have_skipped then + if Result = '' then + Result := '::0' + else + Result := Result + ':'; + + if Result = '' then + Result := '::0'; + if not (7 in zr1) then + SetLength(Result, Length(Result)-1); + Result := LowerCase(result); +end; + +{==============================================================================} +function ReverseIP(Value: AnsiString): AnsiString; +var + x: Integer; +begin + Result := ''; + repeat + x := LastDelimiter('.', Value); + Result := Result + '.' + Copy(Value, x + 1, Length(Value) - x); + Delete(Value, x, Length(Value) - x + 1); + until x < 1; + if Length(Result) > 0 then + if Result[1] = '.' then + Delete(Result, 1, 1); +end; + +{==============================================================================} +function ReverseIP6(Value: AnsiString): AnsiString; +var + ip6: TIp6bytes; + n: integer; + x, y: integer; +begin + ip6 := StrToIP6(Value); + x := ip6[15] div 16; + y := ip6[15] mod 16; + Result := IntToHex(y, 1) + '.' + IntToHex(x, 1); + for n := 14 downto 0 do + begin + x := ip6[n] div 16; + y := ip6[n] mod 16; + Result := Result + '.' + IntToHex(y, 1) + '.' + IntToHex(x, 1); + end; +end; + +{==============================================================================} +end. diff --git a/synapse/synamisc.pas b/synapse/synamisc.pas new file mode 100644 index 0000000..7b06523 --- /dev/null +++ b/synapse/synamisc.pas @@ -0,0 +1,406 @@ +{==============================================================================| +| Project : Ararat Synapse | 001.003.001 | +|==============================================================================| +| Content: misc. procedures and functions | +|==============================================================================| +| 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) 2002-2010. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +{:@abstract(Misc. network based utilities)} + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$Q-} +{$H+} + +//Kylix does not known UNIX define +{$IFDEF LINUX} + {$IFNDEF UNIX} + {$DEFINE UNIX} + {$ENDIF} +{$ENDIF} + +{$TYPEDADDRESS OFF} + +{$IFDEF UNICODE} + {$WARN IMPLICIT_STRING_CAST OFF} + {$WARN IMPLICIT_STRING_CAST_LOSS OFF} +{$ENDIF} + +unit synamisc; + +interface + +{$IFDEF VER125} + {$DEFINE BCB} +{$ENDIF} +{$IFDEF BCB} + {$ObjExportAll On} + {$HPPEMIT '#pragma comment( lib , "wininet.lib" )'} +{$ENDIF} + +uses + synautil, blcksock, SysUtils, Classes +{$IFDEF UNIX} + {$IFNDEF FPC} + , Libc + {$ENDIF} +{$ELSE} + , Windows +{$ENDIF} +; + +Type + {:@abstract(This record contains information about proxy setting.)} + TProxySetting = record + Host: string; + Port: string; + Bypass: string; + end; + +{:By this function you can turn-on computer on network, if this computer + supporting Wake-on-lan feature. You need MAC number (network card indentifier) + of computer for turn-on. You can also assign target IP addres. If you not + specify it, then is used broadcast for delivery magic wake-on packet. However + broadcasts workinh only on your local network. When you need to wake-up + computer on another network, you must specify any existing IP addres on same + network segment as targeting computer.} +procedure WakeOnLan(MAC, IP: string); + +{:Autodetect current DNS servers used by system. If is defined more then one DNS + server, then result is comma-delimited.} +function GetDNS: string; + +{:Autodetect InternetExplorer proxy setting for given protocol. This function +working only on windows!} +function GetIEProxy(protocol: string): TProxySetting; + +{:Return all known IP addresses on local system. Addresses are divided by comma.} +function GetLocalIPs: string; + +implementation + +{==============================================================================} +procedure WakeOnLan(MAC, IP: string); +var + sock: TUDPBlockSocket; + HexMac: Ansistring; + data: Ansistring; + n: integer; + b: Byte; +begin + if MAC <> '' then + begin + MAC := ReplaceString(MAC, '-', ''); + MAC := ReplaceString(MAC, ':', ''); + if Length(MAC) < 12 then + Exit; + HexMac := ''; + for n := 0 to 5 do + begin + b := StrToIntDef('$' + MAC[n * 2 + 1] + MAC[n * 2 + 2], 0); + HexMac := HexMac + char(b); + end; + if IP = '' then + IP := cBroadcast; + sock := TUDPBlockSocket.Create; + try + sock.CreateSocket; + sock.EnableBroadcast(true); + sock.Connect(IP, '9'); + data := #$FF + #$FF + #$FF + #$FF + #$FF + #$FF; + for n := 1 to 16 do + data := data + HexMac; + sock.SendString(data); + finally + sock.Free; + end; + end; +end; + +{==============================================================================} + +{$IFNDEF UNIX} +function GetDNSbyIpHlp: string; +type + PTIP_ADDRESS_STRING = ^TIP_ADDRESS_STRING; + TIP_ADDRESS_STRING = array[0..15] of Ansichar; + PTIP_ADDR_STRING = ^TIP_ADDR_STRING; + TIP_ADDR_STRING = packed record + Next: PTIP_ADDR_STRING; + IpAddress: TIP_ADDRESS_STRING; + IpMask: TIP_ADDRESS_STRING; + Context: DWORD; + end; + PTFixedInfo = ^TFixedInfo; + TFixedInfo = packed record + HostName: array[1..128 + 4] of Ansichar; + DomainName: array[1..128 + 4] of Ansichar; + CurrentDNSServer: PTIP_ADDR_STRING; + DNSServerList: TIP_ADDR_STRING; + NodeType: UINT; + ScopeID: array[1..256 + 4] of Ansichar; + EnableRouting: UINT; + EnableProxy: UINT; + EnableDNS: UINT; + end; +const + IpHlpDLL = 'IPHLPAPI.DLL'; +var + IpHlpModule: THandle; + FixedInfo: PTFixedInfo; + InfoSize: Longint; + PDnsServer: PTIP_ADDR_STRING; + err: integer; + GetNetworkParams: function(FixedInfo: PTFixedInfo; pOutPutLen: PULONG): DWORD; stdcall; +begin + InfoSize := 0; + Result := '...'; + IpHlpModule := LoadLibrary(IpHlpDLL); + if IpHlpModule = 0 then + exit; + try + GetNetworkParams := GetProcAddress(IpHlpModule,PAnsiChar(AnsiString('GetNetworkParams'))); + if @GetNetworkParams = nil then + Exit; + err := GetNetworkParams(Nil, @InfoSize); + if err <> ERROR_BUFFER_OVERFLOW then + Exit; + Result := ''; + GetMem (FixedInfo, InfoSize); + try + err := GetNetworkParams(FixedInfo, @InfoSize); + if err <> ERROR_SUCCESS then + exit; + with FixedInfo^ do + begin + Result := DnsServerList.IpAddress; + PDnsServer := DnsServerList.Next; + while PDnsServer <> Nil do + begin + if Result <> '' then + Result := Result + ','; + Result := Result + PDnsServer^.IPAddress; + PDnsServer := PDnsServer.Next; + end; + end; + finally + FreeMem(FixedInfo); + end; + finally + FreeLibrary(IpHlpModule); + end; +end; + +function ReadReg(SubKey, Vn: PChar): string; +var + OpenKey: HKEY; + DataType, DataSize: integer; + Temp: array [0..2048] of char; +begin + Result := ''; + if RegOpenKeyEx(HKEY_LOCAL_MACHINE, SubKey, REG_OPTION_NON_VOLATILE, + KEY_READ, OpenKey) = ERROR_SUCCESS then + begin + DataType := REG_SZ; + DataSize := SizeOf(Temp); + if RegQueryValueEx(OpenKey, Vn, nil, @DataType, @Temp, @DataSize) = ERROR_SUCCESS then + SetString(Result, Temp, DataSize div SizeOf(Char) - 1); + RegCloseKey(OpenKey); + end; +end ; +{$ENDIF} + +function GetDNS: string; +{$IFDEF UNIX} +var + l: TStringList; + n: integer; +begin + Result := ''; + l := TStringList.Create; + try + l.LoadFromFile('/etc/resolv.conf'); + for n := 0 to l.Count - 1 do + if Pos('NAMESERVER', uppercase(l[n])) = 1 then + begin + if Result <> '' then + Result := Result + ','; + Result := Result + SeparateRight(l[n], ' '); + end; + finally + l.Free; + end; +end; +{$ELSE} +const + NTdyn = 'System\CurrentControlSet\Services\Tcpip\Parameters\Temporary'; + NTfix = 'System\CurrentControlSet\Services\Tcpip\Parameters'; + W9xfix = 'System\CurrentControlSet\Services\MSTCP'; +begin + Result := GetDNSbyIpHlp; + if Result = '...' then + begin + if Win32Platform = VER_PLATFORM_WIN32_NT then + begin + Result := ReadReg(NTdyn, 'NameServer'); + if result = '' then + Result := ReadReg(NTfix, 'NameServer'); + if result = '' then + Result := ReadReg(NTfix, 'DhcpNameServer'); + end + else + Result := ReadReg(W9xfix, 'NameServer'); + Result := ReplaceString(trim(Result), ' ', ','); + end; +end; +{$ENDIF} + +{==============================================================================} + +function GetIEProxy(protocol: string): TProxySetting; +{$IFDEF UNIX} +begin + Result.Host := ''; + Result.Port := ''; + Result.Bypass := ''; +end; +{$ELSE} +type + PInternetProxyInfo = ^TInternetProxyInfo; + TInternetProxyInfo = packed record + dwAccessType: DWORD; + lpszProxy: LPCSTR; + lpszProxyBypass: LPCSTR; + end; +const + INTERNET_OPTION_PROXY = 38; + INTERNET_OPEN_TYPE_PROXY = 3; + WininetDLL = 'WININET.DLL'; +var + WininetModule: THandle; + ProxyInfo: PInternetProxyInfo; + Err: Boolean; + Len: DWORD; + Proxy: string; + DefProxy: string; + ProxyList: TStringList; + n: integer; + InternetQueryOption: function (hInet: Pointer; dwOption: DWORD; + lpBuffer: Pointer; var lpdwBufferLength: DWORD): BOOL; stdcall; +begin + Result.Host := ''; + Result.Port := ''; + Result.Bypass := ''; + WininetModule := LoadLibrary(WininetDLL); + if WininetModule = 0 then + exit; + try + InternetQueryOption := GetProcAddress(WininetModule,PAnsiChar(AnsiString('InternetQueryOptionA'))); + if @InternetQueryOption = nil then + Exit; + + if protocol = '' then + protocol := 'http'; + Len := 4096; + GetMem(ProxyInfo, Len); + ProxyList := TStringList.Create; + try + Err := InternetQueryOption(nil, INTERNET_OPTION_PROXY, ProxyInfo, Len); + if Err then + if ProxyInfo^.dwAccessType = INTERNET_OPEN_TYPE_PROXY then + begin + ProxyList.CommaText := ReplaceString(ProxyInfo^.lpszProxy, ' ', ','); + Proxy := ''; + DefProxy := ''; + for n := 0 to ProxyList.Count -1 do + begin + if Pos(lowercase(protocol) + '=', lowercase(ProxyList[n])) = 1 then + begin + Proxy := SeparateRight(ProxyList[n], '='); + break; + end; + if Pos('=', ProxyList[n]) < 1 then + DefProxy := ProxyList[n]; + end; + if Proxy = '' then + Proxy := DefProxy; + if Proxy <> '' then + begin + Result.Host := Trim(SeparateLeft(Proxy, ':')); + Result.Port := Trim(SeparateRight(Proxy, ':')); + end; + Result.Bypass := ReplaceString(ProxyInfo^.lpszProxyBypass, ' ', ','); + end; + finally + ProxyList.Free; + FreeMem(ProxyInfo); + end; + finally + FreeLibrary(WininetModule); + end; +end; +{$ENDIF} + +{==============================================================================} + +function GetLocalIPs: string; +var + TcpSock: TTCPBlockSocket; + ipList: TStringList; +begin + Result := ''; + ipList := TStringList.Create; + try + TcpSock := TTCPBlockSocket.create; + try + TcpSock.ResolveNameToIP(TcpSock.LocalName, ipList); + Result := ipList.CommaText; + finally + TcpSock.Free; + end; + finally + ipList.Free; + end; +end; + +{==============================================================================} + +end. diff --git a/synapse/synaser.pas b/synapse/synaser.pas new file mode 100644 index 0000000..3628a36 --- /dev/null +++ b/synapse/synaser.pas @@ -0,0 +1,2339 @@ +{==============================================================================| +| Project : Ararat Synapse | 007.005.002 | +|==============================================================================| +| Content: Serial port support | +|==============================================================================| +| Copyright (c)2001-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)2001-2011. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +| (c)2002, Hans-Georg Joepgen (cpom Comport Ownership Manager and bugfixes) | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +{: @abstract(Serial port communication library) +This unit contains a class that implements serial port communication + for Windows, Linux, Unix or MacOSx. This class provides numerous methods with + same name and functionality as methods of the Ararat Synapse TCP/IP library. + +The following is a small example how establish a connection by modem (in this +case with my USB modem): +@longcode(# + ser:=TBlockSerial.Create; + try + ser.Connect('COM3'); + ser.config(460800,8,'N',0,false,true); + ser.ATCommand('AT'); + if (ser.LastError <> 0) or (not ser.ATResult) then + Exit; + ser.ATConnect('ATDT+420971200111'); + if (ser.LastError <> 0) or (not ser.ATResult) then + Exit; + // you are now connected to a modem at +420971200111 + // you can transmit or receive data now + finally + ser.free; + end; +#) +} + +//old Delphi does not have MSWINDOWS define. +{$IFDEF WIN32} + {$IFNDEF MSWINDOWS} + {$DEFINE MSWINDOWS} + {$ENDIF} +{$ENDIF} + +//Kylix does not known UNIX define +{$IFDEF LINUX} + {$IFNDEF UNIX} + {$DEFINE UNIX} + {$ENDIF} +{$ENDIF} + +{$IFDEF FPC} + {$MODE DELPHI} + {$IFDEF MSWINDOWS} + {$ASMMODE intel} + {$ENDIF} + {define working mode w/o LIBC for fpc} + {$DEFINE NO_LIBC} +{$ENDIF} +{$Q-} +{$H+} +{$M+} + +unit synaser; + +interface + +uses +{$IFNDEF MSWINDOWS} + {$IFNDEF NO_LIBC} + Libc, + KernelIoctl, + {$ELSE} + termio, baseunix, unix, + {$ENDIF} + {$IFNDEF FPC} + Types, + {$ENDIF} +{$ELSE} + Windows, registry, + {$IFDEF FPC} + winver, + {$ENDIF} +{$ENDIF} + synafpc, + Classes, SysUtils, synautil; + +const + CR = #$0d; + LF = #$0a; + CRLF = CR + LF; + cSerialChunk = 8192; + + LockfileDirectory = '/var/lock'; {HGJ} + PortIsClosed = -1; {HGJ} + ErrAlreadyOwned = 9991; {HGJ} + ErrAlreadyInUse = 9992; {HGJ} + ErrWrongParameter = 9993; {HGJ} + ErrPortNotOpen = 9994; {HGJ} + ErrNoDeviceAnswer = 9995; {HGJ} + ErrMaxBuffer = 9996; + ErrTimeout = 9997; + ErrNotRead = 9998; + ErrFrame = 9999; + ErrOverrun = 10000; + ErrRxOver = 10001; + ErrRxParity = 10002; + ErrTxFull = 10003; + + dcb_Binary = $00000001; + dcb_ParityCheck = $00000002; + dcb_OutxCtsFlow = $00000004; + dcb_OutxDsrFlow = $00000008; + dcb_DtrControlMask = $00000030; + dcb_DtrControlDisable = $00000000; + dcb_DtrControlEnable = $00000010; + dcb_DtrControlHandshake = $00000020; + dcb_DsrSensivity = $00000040; + dcb_TXContinueOnXoff = $00000080; + dcb_OutX = $00000100; + dcb_InX = $00000200; + dcb_ErrorChar = $00000400; + dcb_NullStrip = $00000800; + dcb_RtsControlMask = $00003000; + dcb_RtsControlDisable = $00000000; + dcb_RtsControlEnable = $00001000; + dcb_RtsControlHandshake = $00002000; + dcb_RtsControlToggle = $00003000; + dcb_AbortOnError = $00004000; + dcb_Reserveds = $FFFF8000; + + {:stopbit value for 1 stopbit} + SB1 = 0; + {:stopbit value for 1.5 stopbit} + SB1andHalf = 1; + {:stopbit value for 2 stopbits} + SB2 = 2; + +{$IFNDEF MSWINDOWS} +const + INVALID_HANDLE_VALUE = THandle(-1); + CS7fix = $0000020; + +type + TDCB = record + DCBlength: DWORD; + BaudRate: DWORD; + Flags: Longint; + wReserved: Word; + XonLim: Word; + XoffLim: Word; + ByteSize: Byte; + Parity: Byte; + StopBits: Byte; + XonChar: CHAR; + XoffChar: CHAR; + ErrorChar: CHAR; + EofChar: CHAR; + EvtChar: CHAR; + wReserved1: Word; + end; + PDCB = ^TDCB; + +const +{$IFDEF UNIX} + {$IFDEF DARWIN} + MaxRates = 18; //MAC + {$ELSE} + MaxRates = 30; //UNIX + {$ENDIF} +{$ELSE} + MaxRates = 19; //WIN +{$ENDIF} + Rates: array[0..MaxRates, 0..1] of cardinal = + ( + (0, B0), + (50, B50), + (75, B75), + (110, B110), + (134, B134), + (150, B150), + (200, B200), + (300, B300), + (600, B600), + (1200, B1200), + (1800, B1800), + (2400, B2400), + (4800, B4800), + (9600, B9600), + (19200, B19200), + (38400, B38400), + (57600, B57600), + (115200, B115200), + (230400, B230400) +{$IFNDEF DARWIN} + ,(460800, B460800) + {$IFDEF UNIX} + ,(500000, B500000), + (576000, B576000), + (921600, B921600), + (1000000, B1000000), + (1152000, B1152000), + (1500000, B1500000), + (2000000, B2000000), + (2500000, B2500000), + (3000000, B3000000), + (3500000, B3500000), + (4000000, B4000000) + {$ENDIF} +{$ENDIF} + ); +{$ENDIF} + +{$IFDEF DARWIN} +const // From fcntl.h + O_SYNC = $0080; { synchronous writes } +{$ENDIF} + +const + sOK = 0; + sErr = integer(-1); + +type + + {:Possible status event types for @link(THookSerialStatus)} + THookSerialReason = ( + HR_SerialClose, + HR_Connect, + HR_CanRead, + HR_CanWrite, + HR_ReadCount, + HR_WriteCount, + HR_Wait + ); + + {:procedural prototype for status event hooking} + THookSerialStatus = procedure(Sender: TObject; Reason: THookSerialReason; + const Value: string) of object; + + {:@abstract(Exception type for SynaSer errors)} + ESynaSerError = class(Exception) + public + ErrorCode: integer; + ErrorMessage: string; + end; + + {:@abstract(Main class implementing all communication routines)} + TBlockSerial = class(TObject) + protected + FOnStatus: THookSerialStatus; + Fhandle: THandle; + FTag: integer; + FDevice: string; + FLastError: integer; + FLastErrorDesc: string; + FBuffer: AnsiString; + FRaiseExcept: boolean; + FRecvBuffer: integer; + FSendBuffer: integer; + FModemWord: integer; + FRTSToggle: Boolean; + FDeadlockTimeout: integer; + FInstanceActive: boolean; {HGJ} + FTestDSR: Boolean; + FTestCTS: Boolean; + FLastCR: Boolean; + FLastLF: Boolean; + FMaxLineLength: Integer; + FLinuxLock: Boolean; + FMaxSendBandwidth: Integer; + FNextSend: LongWord; + FMaxRecvBandwidth: Integer; + FNextRecv: LongWord; + FConvertLineEnd: Boolean; + FATResult: Boolean; + FAtTimeout: integer; + FInterPacketTimeout: Boolean; + FComNr: integer; +{$IFDEF MSWINDOWS} + FPortAddr: Word; + function CanEvent(Event: dword; Timeout: integer): boolean; + procedure DecodeCommError(Error: DWord); virtual; + function GetPortAddr: Word; virtual; + function ReadTxEmpty(PortAddr: Word): Boolean; virtual; +{$ENDIF} + procedure SetSizeRecvBuffer(size: integer); virtual; + function GetDSR: Boolean; virtual; + procedure SetDTRF(Value: Boolean); virtual; + function GetCTS: Boolean; virtual; + procedure SetRTSF(Value: Boolean); virtual; + function GetCarrier: Boolean; virtual; + function GetRing: Boolean; virtual; + procedure DoStatus(Reason: THookSerialReason; const Value: string); virtual; + procedure GetComNr(Value: string); virtual; + function PreTestFailing: boolean; virtual;{HGJ} + function TestCtrlLine: Boolean; virtual; +{$IFDEF UNIX} + procedure DcbToTermios(const dcb: TDCB; var term: termios); virtual; + procedure TermiosToDcb(const term: termios; var dcb: TDCB); virtual; + function ReadLockfile: integer; virtual; + function LockfileName: String; virtual; + procedure CreateLockfile(PidNr: integer); virtual; +{$ENDIF} + procedure LimitBandwidth(Length: Integer; MaxB: integer; var Next: LongWord); virtual; + procedure SetBandwidth(Value: Integer); virtual; + public + {: data Control Block with communication parameters. Usable only when you + need to call API directly.} + DCB: Tdcb; +{$IFDEF UNIX} + TermiosStruc: termios; +{$ENDIF} + {:Object constructor.} + constructor Create; + {:Object destructor.} + destructor Destroy; override; + + {:Returns a string containing the version number of the library.} + class function GetVersion: string; virtual; + + {:Destroy handle in use. It close connection to serial port.} + procedure CloseSocket; virtual; + + {:Reconfigure communication parameters on the fly. You must be connected to + port before! + @param(baud Define connection speed. Baud rate can be from 50 to 4000000 + bits per second. (it depends on your hardware!)) + @param(bits Number of bits in communication.) + @param(parity Define communication parity (N - None, O - Odd, E - Even, M - Mark or S - Space).) + @param(stop Define number of stopbits. Use constants @link(SB1), + @link(SB1andHalf) and @link(SB2).) + @param(softflow Enable XON/XOFF handshake.) + @param(hardflow Enable CTS/RTS handshake.)} + procedure Config(baud, bits: integer; parity: char; stop: integer; + softflow, hardflow: boolean); virtual; + + {:Connects to the port indicated by comport. Comport can be used in Windows + style (COM2), or in Linux style (/dev/ttyS1). When you use windows style + in Linux, then it will be converted to Linux name. And vice versa! However + you can specify any device name! (other device names then standart is not + converted!) + + After successfull connection the DTR signal is set (if you not set hardware + handshake, then the RTS signal is set, too!) + + Connection parameters is predefined by your system configuration. If you + need use another parameters, then you can use Config method after. + Notes: + + - Remember, the commonly used serial Laplink cable does not support + hardware handshake. + + - Before setting any handshake you must be sure that it is supported by + your hardware. + + - Some serial devices are slow. In some cases you must wait up to a few + seconds after connection for the device to respond. + + - when you connect to a modem device, then is best to test it by an empty + AT command. (call ATCommand('AT'))} + procedure Connect(comport: string); virtual; + + {:Set communication parameters from the DCB structure (the DCB structure is + simulated under Linux).} + procedure SetCommState; virtual; + + {:Read communication parameters into the DCB structure (DCB structure is + simulated under Linux).} + procedure GetCommState; virtual; + + {:Sends Length bytes of data from Buffer through the connected port.} + function SendBuffer(buffer: pointer; length: integer): integer; virtual; + + {:One data BYTE is sent.} + procedure SendByte(data: byte); virtual; + + {:Send the string in the data parameter. No terminator is appended by this + method. If you need to send a string with CR/LF terminator, you must append + the CR/LF characters to the data string! + + Since no terminator is appended, you can use this function for sending + binary data too.} + procedure SendString(data: AnsiString); virtual; + + {:send four bytes as integer.} + procedure SendInteger(Data: integer); virtual; + + {:send data as one block. Each block begins with integer value with Length + of block.} + procedure SendBlock(const Data: AnsiString); virtual; + + {:send content of stream from current position} + procedure SendStreamRaw(const Stream: TStream); virtual; + + {:send content of stream as block. see @link(SendBlock)} + procedure SendStream(const Stream: TStream); virtual; + + {:send content of stream as block, but this is compatioble with Indy library. + (it have swapped lenght of block). See @link(SendStream)} + procedure SendStreamIndy(const Stream: TStream); virtual; + + {:Waits until the allocated buffer is filled by received data. Returns number + of data bytes received, which equals to the Length value under normal + operation. If it is not equal, the communication channel is possibly broken. + + This method not using any internal buffering, like all others receiving + methods. You cannot freely combine this method with all others receiving + methods!} + function RecvBuffer(buffer: pointer; length: integer): integer; virtual; + + {:Method waits until data is received. If no data is received within + the Timeout (in milliseconds) period, @link(LastError) is set to + @link(ErrTimeout). This method is used to read any amount of data + (e. g. 1MB), and may be freely combined with all receviving methods what + have Timeout parameter, like the @link(RecvString), @link(RecvByte) or + @link(RecvTerminated) methods.} + function RecvBufferEx(buffer: pointer; length: integer; timeout: integer): integer; virtual; + + {:It is like recvBufferEx, but data is readed to dynamicly allocated binary + string.} + function RecvBufferStr(Length: Integer; Timeout: Integer): AnsiString; virtual; + + {:Read all available data and return it in the function result string. This + function may be combined with @link(RecvString), @link(RecvByte) or related + methods.} + function RecvPacket(Timeout: Integer): AnsiString; virtual; + + {:Waits until one data byte is received which is returned as the function + result. If no data is received within the Timeout (in milliseconds) period, + @link(LastError) is set to @link(ErrTimeout).} + function RecvByte(timeout: integer): byte; virtual; + + {:This method waits until a terminated data string is received. This string + is terminated by the Terminator string. The resulting string is returned + without this termination string! If no data is received within the Timeout + (in milliseconds) period, @link(LastError) is set to @link(ErrTimeout).} + function RecvTerminated(Timeout: Integer; const Terminator: AnsiString): AnsiString; virtual; + + {:This method waits until a terminated data string is received. The string + is terminated by a CR/LF sequence. The resulting string is returned without + the terminator (CR/LF)! If no data is received within the Timeout (in + milliseconds) period, @link(LastError) is set to @link(ErrTimeout). + + If @link(ConvertLineEnd) is used, then the CR/LF sequence may not be exactly + CR/LF. See the description of @link(ConvertLineEnd). + + This method serves for line protocol implementation and uses its own + buffers to maximize performance. Therefore do NOT use this method with the + @link(RecvBuffer) method to receive data as it may cause data loss.} + function Recvstring(timeout: integer): AnsiString; virtual; + + {:Waits until four data bytes are received which is returned as the function + integer result. If no data is received within the Timeout (in milliseconds) period, + @link(LastError) is set to @link(ErrTimeout).} + function RecvInteger(Timeout: Integer): Integer; virtual; + + {:Waits until one data block is received. See @link(sendblock). If no data + is received within the Timeout (in milliseconds) period, @link(LastError) + is set to @link(ErrTimeout).} + function RecvBlock(Timeout: Integer): AnsiString; virtual; + + {:Receive all data to stream, until some error occured. (for example timeout)} + procedure RecvStreamRaw(const Stream: TStream; Timeout: Integer); virtual; + + {:receive requested count of bytes to stream} + procedure RecvStreamSize(const Stream: TStream; Timeout: Integer; Size: Integer); virtual; + + {:receive block of data to stream. (Data can be sended by @link(sendstream)} + procedure RecvStream(const Stream: TStream; Timeout: Integer); virtual; + + {:receive block of data to stream. (Data can be sended by @link(sendstreamIndy)} + procedure RecvStreamIndy(const Stream: TStream; Timeout: Integer); virtual; + + {:Returns the number of received bytes waiting for reading. 0 is returned + when there is no data waiting.} + function WaitingData: integer; virtual; + + {:Same as @link(WaitingData), but in respect to data in the internal + @link(LineBuffer).} + function WaitingDataEx: integer; virtual; + + {:Returns the number of bytes waiting to be sent in the output buffer. + 0 is returned when the output buffer is empty.} + function SendingData: integer; virtual; + + {:Enable or disable RTS driven communication (half-duplex). It can be used + to communicate with RS485 converters, or other special equipment. If you + enable this feature, the system automatically controls the RTS signal. + + Notes: + + - On Windows NT (or higher) ir RTS signal driven by system driver. + + - On Win9x family is used special code for waiting until last byte is + sended from your UART. + + - On Linux you must have kernel 2.1 or higher!} + procedure EnableRTSToggle(value: boolean); virtual; + + {:Waits until all data to is sent and buffers are emptied. + Warning: On Windows systems is this method returns when all buffers are + flushed to the serial port controller, before the last byte is sent!} + procedure Flush; virtual; + + {:Unconditionally empty all buffers. It is good when you need to interrupt + communication and for cleanups.} + procedure Purge; virtual; + + {:Returns @True, if you can from read any data from the port. Status is + tested for a period of time given by the Timeout parameter (in milliseconds). + If the value of the Timeout parameter is 0, the status is tested only once + and the function returns immediately. If the value of the Timeout parameter + is set to -1, the function returns only after it detects data on the port + (this may cause the process to hang).} + function CanRead(Timeout: integer): boolean; virtual; + + {:Returns @True, if you can write any data to the port (this function is not + sending the contents of the buffer). Status is tested for a period of time + given by the Timeout parameter (in milliseconds). If the value of + the Timeout parameter is 0, the status is tested only once and the function + returns immediately. If the value of the Timeout parameter is set to -1, + the function returns only after it detects that it can write data to + the port (this may cause the process to hang).} + function CanWrite(Timeout: integer): boolean; virtual; + + {:Same as @link(CanRead), but the test is against data in the internal + @link(LineBuffer) too.} + function CanReadEx(Timeout: integer): boolean; virtual; + + {:Returns the status word of the modem. Decoding the status word could yield + the status of carrier detect signaland other signals. This method is used + internally by the modem status reading properties. You usually do not need + to call this method directly.} + function ModemStatus: integer; virtual; + + {:Send a break signal to the communication device for Duration milliseconds.} + procedure SetBreak(Duration: integer); virtual; + + {:This function is designed to send AT commands to the modem. The AT command + is sent in the Value parameter and the response is returned in the function + return value (may contain multiple lines!). + If the AT command is processed successfully (modem returns OK), then the + @link(ATResult) property is set to True. + + This function is designed only for AT commands that return OK or ERROR + response! To call connection commands the @link(ATConnect) method. + Remember, when you connect to a modem device, it is in AT command mode. + Now you can send AT commands to the modem. If you need to transfer data to + the modem on the other side of the line, you must first switch to data mode + using the @link(ATConnect) method.} + function ATCommand(value: AnsiString): AnsiString; virtual; + + {:This function is used to send connect type AT commands to the modem. It is + for commands to switch to connected state. (ATD, ATA, ATO,...) + It sends the AT command in the Value parameter and returns the modem's + response (may be multiple lines - usually with connection parameters info). + If the AT command is processed successfully (the modem returns CONNECT), + then the ATResult property is set to @True. + + This function is designed only for AT commands which respond by CONNECT, + BUSY, NO DIALTONE NO CARRIER or ERROR. For other AT commands use the + @link(ATCommand) method. + + The connect timeout is 90*@link(ATTimeout). If this command is successful + (@link(ATresult) is @true), then the modem is in data state. When you now + send or receive some data, it is not to or from your modem, but from the + modem on other side of the line. Now you can transfer your data. + If the connection attempt failed (@link(ATResult) is @False), then the + modem is still in AT command mode.} + function ATConnect(value: AnsiString): AnsiString; virtual; + + {:If you "manually" call API functions, forward their return code in + the SerialResult parameter to this function, which evaluates it and sets + @link(LastError) and @link(LastErrorDesc).} + function SerialCheck(SerialResult: integer): integer; virtual; + + {:If @link(Lasterror) is not 0 and exceptions are enabled, then this procedure + raises an exception. This method is used internally. You may need it only + in special cases.} + procedure ExceptCheck; virtual; + + {:Set Synaser to error state with ErrNumber code. Usually used by internal + routines.} + procedure SetSynaError(ErrNumber: integer); virtual; + + {:Raise Synaser error with ErrNumber code. Usually used by internal routines.} + procedure RaiseSynaError(ErrNumber: integer); virtual; +{$IFDEF UNIX} + function cpomComportAccessible: boolean; virtual;{HGJ} + procedure cpomReleaseComport; virtual; {HGJ} +{$ENDIF} + {:True device name of currently used port} + property Device: string read FDevice; + + {:Error code of last operation. Value is defined by the host operating + system, but value 0 is always OK.} + property LastError: integer read FLastError; + + {:Human readable description of LastError code.} + property LastErrorDesc: string read FLastErrorDesc; + + {:Indicates if the last @link(ATCommand) or @link(ATConnect) method was successful} + property ATResult: Boolean read FATResult; + + {:Read the value of the RTS signal.} + property RTS: Boolean write SetRTSF; + + {:Indicates the presence of the CTS signal} + property CTS: boolean read GetCTS; + + {:Use this property to set the value of the DTR signal.} + property DTR: Boolean write SetDTRF; + + {:Exposes the status of the DSR signal.} + property DSR: boolean read GetDSR; + + {:Indicates the presence of the Carrier signal} + property Carrier: boolean read GetCarrier; + + {:Reflects the status of the Ring signal.} + property Ring: boolean read GetRing; + + {:indicates if this instance of SynaSer is active. (Connected to some port)} + property InstanceActive: boolean read FInstanceActive; {HGJ} + + {:Defines maximum bandwidth for all sending operations in bytes per second. + If this value is set to 0 (default), bandwidth limitation is not used.} + property MaxSendBandwidth: Integer read FMaxSendBandwidth Write FMaxSendBandwidth; + + {:Defines maximum bandwidth for all receiving operations in bytes per second. + If this value is set to 0 (default), bandwidth limitation is not used.} + property MaxRecvBandwidth: Integer read FMaxRecvBandwidth Write FMaxRecvBandwidth; + + {:Defines maximum bandwidth for all sending and receiving operations + in bytes per second. If this value is set to 0 (default), bandwidth + limitation is not used.} + property MaxBandwidth: Integer Write SetBandwidth; + + {:Size of the Windows internal receive buffer. Default value is usually + 4096 bytes. Note: Valid only in Windows versions!} + property SizeRecvBuffer: integer read FRecvBuffer write SetSizeRecvBuffer; + published + {:Returns the descriptive text associated with ErrorCode. You need this + method only in special cases. Description of LastError is now accessible + through the LastErrorDesc property.} + class function GetErrorDesc(ErrorCode: integer): string; + + {:Freely usable property} + property Tag: integer read FTag write FTag; + + {:Contains the handle of the open communication port. + You may need this value to directly call communication functions outside + SynaSer.} + property Handle: THandle read Fhandle write FHandle; + + {:Internally used read buffer.} + property LineBuffer: AnsiString read FBuffer write FBuffer; + + {:If @true, communication errors raise exceptions. If @false (default), only + the @link(LastError) value is set.} + property RaiseExcept: boolean read FRaiseExcept write FRaiseExcept; + + {:This event is triggered when the communication status changes. It can be + used to monitor communication status.} + property OnStatus: THookSerialStatus read FOnStatus write FOnStatus; + + {:If you set this property to @true, then the value of the DSR signal + is tested before every data transfer. It can be used to detect the presence + of a communications device.} + property TestDSR: boolean read FTestDSR write FTestDSR; + + {:If you set this property to @true, then the value of the CTS signal + is tested before every data transfer. It can be used to detect the presence + of a communications device. Warning: This property cannot be used if you + need hardware handshake!} + property TestCTS: boolean read FTestCTS write FTestCTS; + + {:Use this property you to limit the maximum size of LineBuffer + (as a protection against unlimited memory allocation for LineBuffer). + Default value is 0 - no limit.} + property MaxLineLength: Integer read FMaxLineLength Write FMaxLineLength; + + {:This timeout value is used as deadlock protection when trying to send data + to (or receive data from) a device that stopped communicating during data + transmission (e.g. by physically disconnecting the device). + The timeout value is in milliseconds. The default value is 30,000 (30 seconds).} + property DeadlockTimeout: Integer read FDeadlockTimeout Write FDeadlockTimeout; + + {:If set to @true (default value), port locking is enabled (under Linux only). + WARNING: To use this feature, the application must run by a user with full + permission to the /var/lock directory!} + property LinuxLock: Boolean read FLinuxLock write FLinuxLock; + + {:Indicates if non-standard line terminators should be converted to a CR/LF pair + (standard DOS line terminator). If @TRUE, line terminators CR, single LF + or LF/CR are converted to CR/LF. Defaults to @FALSE. + This property has effect only on the behavior of the RecvString method.} + property ConvertLineEnd: Boolean read FConvertLineEnd Write FConvertLineEnd; + + {:Timeout for AT modem based operations} + property AtTimeout: integer read FAtTimeout Write FAtTimeout; + + {:If @true (default), then all timeouts is timeout between two characters. + If @False, then timeout is overall for whoole reading operation.} + property InterPacketTimeout: Boolean read FInterPacketTimeout Write FInterPacketTimeout; + end; + +{:Returns list of existing computer serial ports. Working properly only in Windows!} +function GetSerialPortNames: string; + +implementation + +constructor TBlockSerial.Create; +begin + inherited create; + FRaiseExcept := false; + FHandle := INVALID_HANDLE_VALUE; + FDevice := ''; + FComNr:= PortIsClosed; {HGJ} + FInstanceActive:= false; {HGJ} + Fbuffer := ''; + FRTSToggle := False; + FMaxLineLength := 0; + FTestDSR := False; + FTestCTS := False; + FDeadlockTimeout := 30000; + FLinuxLock := True; + FMaxSendBandwidth := 0; + FNextSend := 0; + FMaxRecvBandwidth := 0; + FNextRecv := 0; + FConvertLineEnd := False; + SetSynaError(sOK); + FRecvBuffer := 4096; + FLastCR := False; + FLastLF := False; + FAtTimeout := 1000; + FInterPacketTimeout := True; +end; + +destructor TBlockSerial.Destroy; +begin + CloseSocket; + inherited destroy; +end; + +class function TBlockSerial.GetVersion: string; +begin + Result := 'SynaSer 7.5.0'; +end; + +procedure TBlockSerial.CloseSocket; +begin + if Fhandle <> INVALID_HANDLE_VALUE then + begin + Purge; + RTS := False; + DTR := False; + FileClose(FHandle); + end; + if InstanceActive then + begin + {$IFDEF UNIX} + if FLinuxLock then + cpomReleaseComport; + {$ENDIF} + FInstanceActive:= false + end; + Fhandle := INVALID_HANDLE_VALUE; + FComNr:= PortIsClosed; + SetSynaError(sOK); + DoStatus(HR_SerialClose, FDevice); +end; + +{$IFDEF MSWINDOWS} +function TBlockSerial.GetPortAddr: Word; +begin + Result := 0; + if Win32Platform <> VER_PLATFORM_WIN32_NT then + begin + EscapeCommFunction(FHandle, 10); + asm + MOV @Result, DX; + end; + end; +end; + +function TBlockSerial.ReadTxEmpty(PortAddr: Word): Boolean; +begin + Result := True; + if Win32Platform <> VER_PLATFORM_WIN32_NT then + begin + asm + MOV DX, PortAddr; + ADD DX, 5; + IN AL, DX; + AND AL, $40; + JZ @K; + MOV AL,1; + @K: MOV @Result, AL; + end; + end; +end; +{$ENDIF} + +procedure TBlockSerial.GetComNr(Value: string); +begin + FComNr := PortIsClosed; + if pos('COM', uppercase(Value)) = 1 then + FComNr := StrToIntdef(copy(Value, 4, Length(Value) - 3), PortIsClosed + 1) - 1; + if pos('/DEV/TTYS', uppercase(Value)) = 1 then + FComNr := StrToIntdef(copy(Value, 10, Length(Value) - 9), PortIsClosed - 1); +end; + +procedure TBlockSerial.SetBandwidth(Value: Integer); +begin + MaxSendBandwidth := Value; + MaxRecvBandwidth := Value; +end; + +procedure TBlockSerial.LimitBandwidth(Length: Integer; MaxB: integer; var Next: LongWord); +var + x: LongWord; + y: LongWord; +begin + if MaxB > 0 then + begin + y := GetTick; + if Next > y then + begin + x := Next - y; + if x > 0 then + begin + DoStatus(HR_Wait, IntToStr(x)); + sleep(x); + end; + end; + Next := GetTick + Trunc((Length / MaxB) * 1000); + end; +end; + +procedure TBlockSerial.Config(baud, bits: integer; parity: char; stop: integer; + softflow, hardflow: boolean); +begin + FillChar(dcb, SizeOf(dcb), 0); + GetCommState; + dcb.DCBlength := SizeOf(dcb); + dcb.BaudRate := baud; + dcb.ByteSize := bits; + case parity of + 'N', 'n': dcb.parity := 0; + 'O', 'o': dcb.parity := 1; + 'E', 'e': dcb.parity := 2; + 'M', 'm': dcb.parity := 3; + 'S', 's': dcb.parity := 4; + end; + dcb.StopBits := stop; + dcb.XonChar := #17; + dcb.XoffChar := #19; + dcb.XonLim := FRecvBuffer div 4; + dcb.XoffLim := FRecvBuffer div 4; + dcb.Flags := dcb_Binary; + if softflow then + dcb.Flags := dcb.Flags or dcb_OutX or dcb_InX; + if hardflow then + dcb.Flags := dcb.Flags or dcb_OutxCtsFlow or dcb_RtsControlHandshake + else + dcb.Flags := dcb.Flags or dcb_RtsControlEnable; + dcb.Flags := dcb.Flags or dcb_DtrControlEnable; + if dcb.Parity > 0 then + dcb.Flags := dcb.Flags or dcb_ParityCheck; + SetCommState; +end; + +procedure TBlockSerial.Connect(comport: string); +{$IFDEF MSWINDOWS} +var + CommTimeouts: TCommTimeouts; +{$ENDIF} +begin + // Is this TBlockSerial Instance already busy? + if InstanceActive then {HGJ} + begin {HGJ} + RaiseSynaError(ErrAlreadyInUse); + Exit; {HGJ} + end; {HGJ} + FBuffer := ''; + FDevice := comport; + GetComNr(comport); +{$IFDEF MSWINDOWS} + SetLastError (sOK); +{$ELSE} + {$IFNDEF FPC} + SetLastError (sOK); + {$ELSE} + fpSetErrno(sOK); + {$ENDIF} +{$ENDIF} +{$IFNDEF MSWINDOWS} + if FComNr <> PortIsClosed then + FDevice := '/dev/ttyS' + IntToStr(FComNr); + // Comport already owned by another process? {HGJ} + if FLinuxLock then + if not cpomComportAccessible then + begin + RaiseSynaError(ErrAlreadyOwned); + Exit; + end; +{$IFNDEF FPC} + FHandle := THandle(Libc.open(pchar(FDevice), O_RDWR or O_SYNC)); +{$ELSE} + FHandle := THandle(fpOpen(FDevice, O_RDWR or O_SYNC)); +{$ENDIF} + if FHandle = INVALID_HANDLE_VALUE then //because THandle is not integer on all platforms! + SerialCheck(-1) + else + SerialCheck(0); + {$IFDEF UNIX} + if FLastError <> sOK then + if FLinuxLock then + cpomReleaseComport; + {$ENDIF} + ExceptCheck; + if FLastError <> sOK then + Exit; +{$ELSE} + if FComNr <> PortIsClosed then + FDevice := '\\.\COM' + IntToStr(FComNr + 1); + FHandle := THandle(CreateFile(PChar(FDevice), GENERIC_READ or GENERIC_WRITE, + 0, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL or FILE_FLAG_OVERLAPPED, 0)); + if FHandle = INVALID_HANDLE_VALUE then //because THandle is not integer on all platforms! + SerialCheck(-1) + else + SerialCheck(0); + ExceptCheck; + if FLastError <> sOK then + Exit; + SetCommMask(FHandle, 0); + SetupComm(Fhandle, FRecvBuffer, 0); + CommTimeOuts.ReadIntervalTimeout := MAXWORD; + CommTimeOuts.ReadTotalTimeoutMultiplier := 0; + CommTimeOuts.ReadTotalTimeoutConstant := 0; + CommTimeOuts.WriteTotalTimeoutMultiplier := 0; + CommTimeOuts.WriteTotalTimeoutConstant := 0; + SetCommTimeOuts(FHandle, CommTimeOuts); + FPortAddr := GetPortAddr; +{$ENDIF} + SetSynaError(sOK); + if not TestCtrlLine then {HGJ} + begin + SetSynaError(ErrNoDeviceAnswer); + FileClose(FHandle); {HGJ} + {$IFDEF UNIX} + if FLinuxLock then + cpomReleaseComport; {HGJ} + {$ENDIF} {HGJ} + Fhandle := INVALID_HANDLE_VALUE; {HGJ} + FComNr:= PortIsClosed; {HGJ} + end + else + begin + FInstanceActive:= True; + RTS := True; + DTR := True; + Purge; + end; + ExceptCheck; + DoStatus(HR_Connect, FDevice); +end; + +function TBlockSerial.SendBuffer(buffer: pointer; length: integer): integer; +{$IFDEF MSWINDOWS} +var + Overlapped: TOverlapped; + x, y, Err: DWord; +{$ENDIF} +begin + Result := 0; + if PreTestFailing then {HGJ} + Exit; {HGJ} + LimitBandwidth(Length, FMaxSendBandwidth, FNextsend); + if FRTSToggle then + begin + Flush; + RTS := True; + end; +{$IFNDEF MSWINDOWS} + result := FileWrite(Fhandle, Buffer^, Length); + serialcheck(result); +{$ELSE} + FillChar(Overlapped, Sizeof(Overlapped), 0); + SetSynaError(sOK); + y := 0; + if not WriteFile(FHandle, Buffer^, Length, DWord(Result), @Overlapped) then + y := GetLastError; + if y = ERROR_IO_PENDING then + begin + x := WaitForSingleObject(FHandle, FDeadlockTimeout); + if x = WAIT_TIMEOUT then + begin + PurgeComm(FHandle, PURGE_TXABORT); + SetSynaError(ErrTimeout); + end; + GetOverlappedResult(FHandle, Overlapped, Dword(Result), False); + end + else + SetSynaError(y); + ClearCommError(FHandle, err, nil); + if err <> 0 then + DecodeCommError(err); +{$ENDIF} + if FRTSToggle then + begin + Flush; + CanWrite(255); + RTS := False; + end; + ExceptCheck; + DoStatus(HR_WriteCount, IntToStr(Result)); +end; + +procedure TBlockSerial.SendByte(data: byte); +begin + SendBuffer(@Data, 1); +end; + +procedure TBlockSerial.SendString(data: AnsiString); +begin + SendBuffer(Pointer(Data), Length(Data)); +end; + +procedure TBlockSerial.SendInteger(Data: integer); +begin + SendBuffer(@data, SizeOf(Data)); +end; + +procedure TBlockSerial.SendBlock(const Data: AnsiString); +begin + SendInteger(Length(data)); + SendString(Data); +end; + +procedure TBlockSerial.SendStreamRaw(const Stream: TStream); +var + si: integer; + x, y, yr: integer; + s: AnsiString; +begin + si := Stream.Size - Stream.Position; + x := 0; + while x < si do + begin + y := si - x; + if y > cSerialChunk then + y := cSerialChunk; + Setlength(s, y); + yr := Stream.read(PAnsiChar(s)^, y); + if yr > 0 then + begin + SetLength(s, yr); + SendString(s); + Inc(x, yr); + end + else + break; + end; +end; + +procedure TBlockSerial.SendStreamIndy(const Stream: TStream); +var + si: integer; +begin + si := Stream.Size - Stream.Position; + si := Swapbytes(si); + SendInteger(si); + SendStreamRaw(Stream); +end; + +procedure TBlockSerial.SendStream(const Stream: TStream); +var + si: integer; +begin + si := Stream.Size - Stream.Position; + SendInteger(si); + SendStreamRaw(Stream); +end; + +function TBlockSerial.RecvBuffer(buffer: pointer; length: integer): integer; +{$IFNDEF MSWINDOWS} +begin + Result := 0; + if PreTestFailing then {HGJ} + Exit; {HGJ} + LimitBandwidth(Length, FMaxRecvBandwidth, FNextRecv); + result := FileRead(FHandle, Buffer^, length); + serialcheck(result); +{$ELSE} +var + Overlapped: TOverlapped; + x, y, Err: DWord; +begin + Result := 0; + if PreTestFailing then {HGJ} + Exit; {HGJ} + LimitBandwidth(Length, FMaxRecvBandwidth, FNextRecv); + FillChar(Overlapped, Sizeof(Overlapped), 0); + SetSynaError(sOK); + y := 0; + if not ReadFile(FHandle, Buffer^, length, Dword(Result), @Overlapped) then + y := GetLastError; + if y = ERROR_IO_PENDING then + begin + x := WaitForSingleObject(FHandle, FDeadlockTimeout); + if x = WAIT_TIMEOUT then + begin + PurgeComm(FHandle, PURGE_RXABORT); + SetSynaError(ErrTimeout); + end; + GetOverlappedResult(FHandle, Overlapped, Dword(Result), False); + end + else + SetSynaError(y); + ClearCommError(FHandle, err, nil); + if err <> 0 then + DecodeCommError(err); +{$ENDIF} + ExceptCheck; + DoStatus(HR_ReadCount, IntToStr(Result)); +end; + +function TBlockSerial.RecvBufferEx(buffer: pointer; length: integer; timeout: integer): integer; +var + s: AnsiString; + rl, l: integer; + ti: LongWord; +begin + Result := 0; + if PreTestFailing then {HGJ} + Exit; {HGJ} + SetSynaError(sOK); + rl := 0; + repeat + ti := GetTick; + s := RecvPacket(Timeout); + l := System.Length(s); + if (rl + l) > Length then + l := Length - rl; + Move(Pointer(s)^, IncPoint(Buffer, rl)^, l); + rl := rl + l; + if FLastError <> sOK then + Break; + if rl >= Length then + Break; + if not FInterPacketTimeout then + begin + Timeout := Timeout - integer(TickDelta(ti, GetTick)); + if Timeout <= 0 then + begin + SetSynaError(ErrTimeout); + Break; + end; + end; + until False; + delete(s, 1, l); + FBuffer := s; + Result := rl; +end; + +function TBlockSerial.RecvBufferStr(Length: Integer; Timeout: Integer): AnsiString; +var + x: integer; +begin + Result := ''; + if PreTestFailing then {HGJ} + Exit; {HGJ} + SetSynaError(sOK); + if Length > 0 then + begin + Setlength(Result, Length); + x := RecvBufferEx(PAnsiChar(Result), Length , Timeout); + if FLastError = sOK then + SetLength(Result, x) + else + Result := ''; + end; +end; + +function TBlockSerial.RecvPacket(Timeout: Integer): AnsiString; +var + x: integer; +begin + Result := ''; + if PreTestFailing then {HGJ} + Exit; {HGJ} + SetSynaError(sOK); + if FBuffer <> '' then + begin + Result := FBuffer; + FBuffer := ''; + end + else + begin + //not drain CPU on large downloads... + Sleep(0); + x := WaitingData; + if x > 0 then + begin + SetLength(Result, x); + x := RecvBuffer(Pointer(Result), x); + if x >= 0 then + SetLength(Result, x); + end + else + begin + if CanRead(Timeout) then + begin + x := WaitingData; + if x = 0 then + SetSynaError(ErrTimeout); + if x > 0 then + begin + SetLength(Result, x); + x := RecvBuffer(Pointer(Result), x); + if x >= 0 then + SetLength(Result, x); + end; + end + else + SetSynaError(ErrTimeout); + end; + end; + ExceptCheck; +end; + + +function TBlockSerial.RecvByte(timeout: integer): byte; +begin + Result := 0; + if PreTestFailing then {HGJ} + Exit; {HGJ} + SetSynaError(sOK); + if FBuffer = '' then + FBuffer := RecvPacket(Timeout); + if (FLastError = sOK) and (FBuffer <> '') then + begin + Result := Ord(FBuffer[1]); + System.Delete(FBuffer, 1, 1); + end; + ExceptCheck; +end; + +function TBlockSerial.RecvTerminated(Timeout: Integer; const Terminator: AnsiString): AnsiString; +var + x: Integer; + s: AnsiString; + l: Integer; + CorCRLF: Boolean; + t: ansistring; + tl: integer; + ti: LongWord; +begin + Result := ''; + if PreTestFailing then {HGJ} + Exit; {HGJ} + SetSynaError(sOK); + l := system.Length(Terminator); + if l = 0 then + Exit; + tl := l; + CorCRLF := FConvertLineEnd and (Terminator = CRLF); + s := ''; + x := 0; + repeat + ti := GetTick; + //get rest of FBuffer or incomming new data... + s := s + RecvPacket(Timeout); + if FLastError <> sOK then + Break; + x := 0; + if Length(s) > 0 then + if CorCRLF then + begin + if FLastCR and (s[1] = LF) then + Delete(s, 1, 1); + if FLastLF and (s[1] = CR) then + Delete(s, 1, 1); + FLastCR := False; + FLastLF := False; + t := ''; + x := PosCRLF(s, t); + tl := system.Length(t); + if t = CR then + FLastCR := True; + if t = LF then + FLastLF := True; + end + else + begin + x := pos(Terminator, s); + tl := l; + end; + if (FMaxLineLength <> 0) and (system.Length(s) > FMaxLineLength) then + begin + SetSynaError(ErrMaxBuffer); + Break; + end; + if x > 0 then + Break; + if not FInterPacketTimeout then + begin + Timeout := Timeout - integer(TickDelta(ti, GetTick)); + if Timeout <= 0 then + begin + SetSynaError(ErrTimeout); + Break; + end; + end; + until False; + if x > 0 then + begin + Result := Copy(s, 1, x - 1); + System.Delete(s, 1, x + tl - 1); + end; + FBuffer := s; + ExceptCheck; +end; + + +function TBlockSerial.RecvString(Timeout: Integer): AnsiString; +var + s: AnsiString; +begin + Result := ''; + s := RecvTerminated(Timeout, #13 + #10); + if FLastError = sOK then + Result := s; +end; + +function TBlockSerial.RecvInteger(Timeout: Integer): Integer; +var + s: AnsiString; +begin + Result := 0; + s := RecvBufferStr(4, Timeout); + if FLastError = 0 then + Result := (ord(s[1]) + ord(s[2]) * 256) + (ord(s[3]) + ord(s[4]) * 256) * 65536; +end; + +function TBlockSerial.RecvBlock(Timeout: Integer): AnsiString; +var + x: integer; +begin + Result := ''; + x := RecvInteger(Timeout); + if FLastError = 0 then + Result := RecvBufferStr(x, Timeout); +end; + +procedure TBlockSerial.RecvStreamRaw(const Stream: TStream; Timeout: Integer); +var + s: AnsiString; +begin + repeat + s := RecvPacket(Timeout); + if FLastError = 0 then + WriteStrToStream(Stream, s); + until FLastError <> 0; +end; + +procedure TBlockSerial.RecvStreamSize(const Stream: TStream; Timeout: Integer; Size: Integer); +var + s: AnsiString; + n: integer; +begin + for n := 1 to (Size div cSerialChunk) do + begin + s := RecvBufferStr(cSerialChunk, Timeout); + if FLastError <> 0 then + Exit; + Stream.Write(PAnsichar(s)^, cSerialChunk); + end; + n := Size mod cSerialChunk; + if n > 0 then + begin + s := RecvBufferStr(n, Timeout); + if FLastError <> 0 then + Exit; + Stream.Write(PAnsichar(s)^, n); + end; +end; + +procedure TBlockSerial.RecvStreamIndy(const Stream: TStream; Timeout: Integer); +var + x: integer; +begin + x := RecvInteger(Timeout); + x := SwapBytes(x); + if FLastError = 0 then + RecvStreamSize(Stream, Timeout, x); +end; + +procedure TBlockSerial.RecvStream(const Stream: TStream; Timeout: Integer); +var + x: integer; +begin + x := RecvInteger(Timeout); + if FLastError = 0 then + RecvStreamSize(Stream, Timeout, x); +end; + +{$IFNDEF MSWINDOWS} +function TBlockSerial.WaitingData: integer; +begin +{$IFNDEF FPC} + serialcheck(ioctl(FHandle, FIONREAD, @result)); +{$ELSE} + serialcheck(fpIoctl(FHandle, FIONREAD, @result)); +{$ENDIF} + if FLastError <> 0 then + Result := 0; + ExceptCheck; +end; +{$ELSE} +function TBlockSerial.WaitingData: integer; +var + stat: TComStat; + err: DWORD; +begin + if ClearCommError(FHandle, err, @stat) then + begin + SetSynaError(sOK); + Result := stat.cbInQue; + end + else + begin + SerialCheck(sErr); + Result := 0; + end; + ExceptCheck; +end; +{$ENDIF} + +function TBlockSerial.WaitingDataEx: integer; +begin + if FBuffer <> '' then + Result := Length(FBuffer) + else + Result := Waitingdata; +end; + +{$IFNDEF MSWINDOWS} +function TBlockSerial.SendingData: integer; +begin + SetSynaError(sOK); + Result := 0; +end; +{$ELSE} +function TBlockSerial.SendingData: integer; +var + stat: TComStat; + err: DWORD; +begin + SetSynaError(sOK); + if not ClearCommError(FHandle, err, @stat) then + serialcheck(sErr); + ExceptCheck; + result := stat.cbOutQue; +end; +{$ENDIF} + +{$IFNDEF MSWINDOWS} +procedure TBlockSerial.DcbToTermios(const dcb: TDCB; var term: termios); +var + n: integer; + x: cardinal; +begin + //others + cfmakeraw(term); + term.c_cflag := term.c_cflag or CREAD; + term.c_cflag := term.c_cflag or CLOCAL; + term.c_cflag := term.c_cflag or HUPCL; + //hardware handshake + if (dcb.flags and dcb_RtsControlHandshake) > 0 then + term.c_cflag := term.c_cflag or CRTSCTS + else + term.c_cflag := term.c_cflag and (not CRTSCTS); + //software handshake + if (dcb.flags and dcb_OutX) > 0 then + term.c_iflag := term.c_iflag or IXON or IXOFF or IXANY + else + term.c_iflag := term.c_iflag and (not (IXON or IXOFF or IXANY)); + //size of byte + term.c_cflag := term.c_cflag and (not CSIZE); + case dcb.bytesize of + 5: + term.c_cflag := term.c_cflag or CS5; + 6: + term.c_cflag := term.c_cflag or CS6; + 7: +{$IFDEF FPC} + term.c_cflag := term.c_cflag or CS7; +{$ELSE} + term.c_cflag := term.c_cflag or CS7fix; +{$ENDIF} + 8: + term.c_cflag := term.c_cflag or CS8; + end; + //parity + if (dcb.flags and dcb_ParityCheck) > 0 then + term.c_cflag := term.c_cflag or PARENB + else + term.c_cflag := term.c_cflag and (not PARENB); + case dcb.parity of + 1: //'O' + term.c_cflag := term.c_cflag or PARODD; + 2: //'E' + term.c_cflag := term.c_cflag and (not PARODD); + end; + //stop bits + if dcb.stopbits > 0 then + term.c_cflag := term.c_cflag or CSTOPB + else + term.c_cflag := term.c_cflag and (not CSTOPB); + //set baudrate; + x := 0; + for n := 0 to Maxrates do + if rates[n, 0] = dcb.BaudRate then + begin + x := rates[n, 1]; + break; + end; + cfsetospeed(term, x); + cfsetispeed(term, x); +end; + +procedure TBlockSerial.TermiosToDcb(const term: termios; var dcb: TDCB); +var + n: integer; + x: cardinal; +begin + //set baudrate; + dcb.baudrate := 0; + {$IFDEF FPC} + //why FPC not have cfgetospeed??? + x := term.c_oflag and $0F; + {$ELSE} + x := cfgetospeed(term); + {$ENDIF} + for n := 0 to Maxrates do + if rates[n, 1] = x then + begin + dcb.baudrate := rates[n, 0]; + break; + end; + //hardware handshake + if (term.c_cflag and CRTSCTS) > 0 then + dcb.flags := dcb.flags or dcb_RtsControlHandshake or dcb_OutxCtsFlow + else + dcb.flags := dcb.flags and (not (dcb_RtsControlHandshake or dcb_OutxCtsFlow)); + //software handshake + if (term.c_cflag and IXOFF) > 0 then + dcb.flags := dcb.flags or dcb_OutX or dcb_InX + else + dcb.flags := dcb.flags and (not (dcb_OutX or dcb_InX)); + //size of byte + case term.c_cflag and CSIZE of + CS5: + dcb.bytesize := 5; + CS6: + dcb.bytesize := 6; + CS7fix: + dcb.bytesize := 7; + CS8: + dcb.bytesize := 8; + end; + //parity + if (term.c_cflag and PARENB) > 0 then + dcb.flags := dcb.flags or dcb_ParityCheck + else + dcb.flags := dcb.flags and (not dcb_ParityCheck); + dcb.parity := 0; + if (term.c_cflag and PARODD) > 0 then + dcb.parity := 1 + else + dcb.parity := 2; + //stop bits + if (term.c_cflag and CSTOPB) > 0 then + dcb.stopbits := 2 + else + dcb.stopbits := 0; +end; +{$ENDIF} + +{$IFNDEF MSWINDOWS} +procedure TBlockSerial.SetCommState; +begin + DcbToTermios(dcb, termiosstruc); + SerialCheck(tcsetattr(FHandle, TCSANOW, termiosstruc)); + ExceptCheck; +end; +{$ELSE} +procedure TBlockSerial.SetCommState; +begin + SetSynaError(sOK); + if not windows.SetCommState(Fhandle, dcb) then + SerialCheck(sErr); + ExceptCheck; +end; +{$ENDIF} + +{$IFNDEF MSWINDOWS} +procedure TBlockSerial.GetCommState; +begin + SerialCheck(tcgetattr(FHandle, termiosstruc)); + ExceptCheck; + TermiostoDCB(termiosstruc, dcb); +end; +{$ELSE} +procedure TBlockSerial.GetCommState; +begin + SetSynaError(sOK); + if not windows.GetCommState(Fhandle, dcb) then + SerialCheck(sErr); + ExceptCheck; +end; +{$ENDIF} + +procedure TBlockSerial.SetSizeRecvBuffer(size: integer); +begin +{$IFDEF MSWINDOWS} + SetupComm(Fhandle, size, 0); + GetCommState; + dcb.XonLim := size div 4; + dcb.XoffLim := size div 4; + SetCommState; +{$ENDIF} + FRecvBuffer := size; +end; + +function TBlockSerial.GetDSR: Boolean; +begin + ModemStatus; +{$IFNDEF MSWINDOWS} + Result := (FModemWord and TIOCM_DSR) > 0; +{$ELSE} + Result := (FModemWord and MS_DSR_ON) > 0; +{$ENDIF} +end; + +procedure TBlockSerial.SetDTRF(Value: Boolean); +begin +{$IFNDEF MSWINDOWS} + ModemStatus; + if Value then + FModemWord := FModemWord or TIOCM_DTR + else + FModemWord := FModemWord and not TIOCM_DTR; + {$IFNDEF FPC} + ioctl(FHandle, TIOCMSET, @FModemWord); + {$ELSE} + fpioctl(FHandle, TIOCMSET, @FModemWord); + {$ENDIF} +{$ELSE} + if Value then + EscapeCommFunction(FHandle, SETDTR) + else + EscapeCommFunction(FHandle, CLRDTR); +{$ENDIF} +end; + +function TBlockSerial.GetCTS: Boolean; +begin + ModemStatus; +{$IFNDEF MSWINDOWS} + Result := (FModemWord and TIOCM_CTS) > 0; +{$ELSE} + Result := (FModemWord and MS_CTS_ON) > 0; +{$ENDIF} +end; + +procedure TBlockSerial.SetRTSF(Value: Boolean); +begin +{$IFNDEF MSWINDOWS} + ModemStatus; + if Value then + FModemWord := FModemWord or TIOCM_RTS + else + FModemWord := FModemWord and not TIOCM_RTS; + {$IFNDEF FPC} + ioctl(FHandle, TIOCMSET, @FModemWord); + {$ELSE} + fpioctl(FHandle, TIOCMSET, @FModemWord); + {$ENDIF} +{$ELSE} + if Value then + EscapeCommFunction(FHandle, SETRTS) + else + EscapeCommFunction(FHandle, CLRRTS); +{$ENDIF} +end; + +function TBlockSerial.GetCarrier: Boolean; +begin + ModemStatus; +{$IFNDEF MSWINDOWS} + Result := (FModemWord and TIOCM_CAR) > 0; +{$ELSE} + Result := (FModemWord and MS_RLSD_ON) > 0; +{$ENDIF} +end; + +function TBlockSerial.GetRing: Boolean; +begin + ModemStatus; +{$IFNDEF MSWINDOWS} + Result := (FModemWord and TIOCM_RNG) > 0; +{$ELSE} + Result := (FModemWord and MS_RING_ON) > 0; +{$ENDIF} +end; + +{$IFDEF MSWINDOWS} +function TBlockSerial.CanEvent(Event: dword; Timeout: integer): boolean; +var + ex: DWord; + y: Integer; + Overlapped: TOverlapped; +begin + FillChar(Overlapped, Sizeof(Overlapped), 0); + Overlapped.hEvent := CreateEvent(nil, True, False, nil); + try + SetCommMask(FHandle, Event); + SetSynaError(sOK); + if (Event = EV_RXCHAR) and (Waitingdata > 0) then + Result := True + else + begin + y := 0; + if not WaitCommEvent(FHandle, ex, @Overlapped) then + y := GetLastError; + if y = ERROR_IO_PENDING then + begin + //timedout + WaitForSingleObject(Overlapped.hEvent, Timeout); + SetCommMask(FHandle, 0); + GetOverlappedResult(FHandle, Overlapped, DWord(y), True); + end; + Result := (ex and Event) = Event; + end; + finally + SetCommMask(FHandle, 0); + CloseHandle(Overlapped.hEvent); + end; +end; +{$ENDIF} + +{$IFNDEF MSWINDOWS} +function TBlockSerial.CanRead(Timeout: integer): boolean; +var + FDSet: TFDSet; + TimeVal: PTimeVal; + TimeV: TTimeVal; + x: Integer; +begin + TimeV.tv_usec := (Timeout mod 1000) * 1000; + TimeV.tv_sec := Timeout div 1000; + TimeVal := @TimeV; + if Timeout = -1 then + TimeVal := nil; + {$IFNDEF FPC} + FD_ZERO(FDSet); + FD_SET(FHandle, FDSet); + x := Select(FHandle + 1, @FDSet, nil, nil, TimeVal); + {$ELSE} + fpFD_ZERO(FDSet); + fpFD_SET(FHandle, FDSet); + x := fpSelect(FHandle + 1, @FDSet, nil, nil, TimeVal); + {$ENDIF} + SerialCheck(x); + if FLastError <> sOK then + x := 0; + Result := x > 0; + ExceptCheck; + if Result then + DoStatus(HR_CanRead, ''); +end; +{$ELSE} +function TBlockSerial.CanRead(Timeout: integer): boolean; +begin + Result := WaitingData > 0; + if not Result then + Result := CanEvent(EV_RXCHAR, Timeout) or (WaitingData > 0); + //check WaitingData again due some broken virtual ports + if Result then + DoStatus(HR_CanRead, ''); +end; +{$ENDIF} + +{$IFNDEF MSWINDOWS} +function TBlockSerial.CanWrite(Timeout: integer): boolean; +var + FDSet: TFDSet; + TimeVal: PTimeVal; + TimeV: TTimeVal; + x: Integer; +begin + TimeV.tv_usec := (Timeout mod 1000) * 1000; + TimeV.tv_sec := Timeout div 1000; + TimeVal := @TimeV; + if Timeout = -1 then + TimeVal := nil; + {$IFNDEF FPC} + FD_ZERO(FDSet); + FD_SET(FHandle, FDSet); + x := Select(FHandle + 1, nil, @FDSet, nil, TimeVal); + {$ELSE} + fpFD_ZERO(FDSet); + fpFD_SET(FHandle, FDSet); + x := fpSelect(FHandle + 1, nil, @FDSet, nil, TimeVal); + {$ENDIF} + SerialCheck(x); + if FLastError <> sOK then + x := 0; + Result := x > 0; + ExceptCheck; + if Result then + DoStatus(HR_CanWrite, ''); +end; +{$ELSE} +function TBlockSerial.CanWrite(Timeout: integer): boolean; +var + t: LongWord; +begin + Result := SendingData = 0; + if not Result then + Result := CanEvent(EV_TXEMPTY, Timeout); + if Result and (Win32Platform <> VER_PLATFORM_WIN32_NT) then + begin + t := GetTick; + while not ReadTxEmpty(FPortAddr) do + begin + if TickDelta(t, GetTick) > 255 then + Break; + Sleep(0); + end; + end; + if Result then + DoStatus(HR_CanWrite, ''); +end; +{$ENDIF} + +function TBlockSerial.CanReadEx(Timeout: integer): boolean; +begin + if Fbuffer <> '' then + Result := True + else + Result := CanRead(Timeout); +end; + +procedure TBlockSerial.EnableRTSToggle(Value: boolean); +begin + SetSynaError(sOK); +{$IFNDEF MSWINDOWS} + FRTSToggle := Value; + if Value then + RTS:=False; +{$ELSE} + if Win32Platform = VER_PLATFORM_WIN32_NT then + begin + GetCommState; + if value then + dcb.Flags := dcb.Flags or dcb_RtsControlToggle + else + dcb.flags := dcb.flags and (not dcb_RtsControlToggle); + SetCommState; + end + else + begin + FRTSToggle := Value; + if Value then + RTS:=False; + end; +{$ENDIF} +end; + +procedure TBlockSerial.Flush; +begin +{$IFNDEF MSWINDOWS} + SerialCheck(tcdrain(FHandle)); +{$ELSE} + SetSynaError(sOK); + if not Flushfilebuffers(FHandle) then + SerialCheck(sErr); +{$ENDIF} + ExceptCheck; +end; + +{$IFNDEF MSWINDOWS} +procedure TBlockSerial.Purge; +begin + {$IFNDEF FPC} + SerialCheck(ioctl(FHandle, TCFLSH, TCIOFLUSH)); + {$ELSE} + {$IFDEF DARWIN} + SerialCheck(fpioctl(FHandle, TCIOflush, TCIOFLUSH)); + {$ELSE} + SerialCheck(fpioctl(FHandle, TCFLSH, Pointer(PtrInt(TCIOFLUSH)))); + {$ENDIF} + {$ENDIF} + FBuffer := ''; + ExceptCheck; +end; +{$ELSE} +procedure TBlockSerial.Purge; +var + x: integer; +begin + SetSynaError(sOK); + x := PURGE_TXABORT or PURGE_TXCLEAR or PURGE_RXABORT or PURGE_RXCLEAR; + if not PurgeComm(FHandle, x) then + SerialCheck(sErr); + FBuffer := ''; + ExceptCheck; +end; +{$ENDIF} + +function TBlockSerial.ModemStatus: integer; +begin + Result := 0; +{$IFNDEF MSWINDOWS} + {$IFNDEF FPC} + SerialCheck(ioctl(FHandle, TIOCMGET, @Result)); + {$ELSE} + SerialCheck(fpioctl(FHandle, TIOCMGET, @Result)); + {$ENDIF} +{$ELSE} + SetSynaError(sOK); + if not GetCommModemStatus(FHandle, dword(Result)) then + SerialCheck(sErr); +{$ENDIF} + ExceptCheck; + FModemWord := Result; +end; + +procedure TBlockSerial.SetBreak(Duration: integer); +begin +{$IFNDEF MSWINDOWS} + SerialCheck(tcsendbreak(FHandle, Duration)); +{$ELSE} + SetCommBreak(FHandle); + Sleep(Duration); + SetSynaError(sOK); + if not ClearCommBreak(FHandle) then + SerialCheck(sErr); +{$ENDIF} +end; + +{$IFDEF MSWINDOWS} +procedure TBlockSerial.DecodeCommError(Error: DWord); +begin + if (Error and DWord(CE_FRAME)) > 1 then + FLastError := ErrFrame; + if (Error and DWord(CE_OVERRUN)) > 1 then + FLastError := ErrOverrun; + if (Error and DWord(CE_RXOVER)) > 1 then + FLastError := ErrRxOver; + if (Error and DWord(CE_RXPARITY)) > 1 then + FLastError := ErrRxParity; + if (Error and DWord(CE_TXFULL)) > 1 then + FLastError := ErrTxFull; +end; +{$ENDIF} + +//HGJ +function TBlockSerial.PreTestFailing: Boolean; +begin + if not FInstanceActive then + begin + RaiseSynaError(ErrPortNotOpen); + result:= true; + Exit; + end; + Result := not TestCtrlLine; + if result then + RaiseSynaError(ErrNoDeviceAnswer) +end; + +function TBlockSerial.TestCtrlLine: Boolean; +begin + result := ((not FTestDSR) or DSR) and ((not FTestCTS) or CTS); +end; + +function TBlockSerial.ATCommand(value: AnsiString): AnsiString; +var + s: AnsiString; + ConvSave: Boolean; +begin + result := ''; + FAtResult := False; + ConvSave := FConvertLineEnd; + try + FConvertLineEnd := True; + SendString(value + #$0D); + repeat + s := RecvString(FAtTimeout); + if s <> Value then + result := result + s + CRLF; + if s = 'OK' then + begin + FAtResult := True; + break; + end; + if s = 'ERROR' then + break; + until FLastError <> sOK; + finally + FConvertLineEnd := Convsave; + end; +end; + + +function TBlockSerial.ATConnect(value: AnsiString): AnsiString; +var + s: AnsiString; + ConvSave: Boolean; +begin + result := ''; + FAtResult := False; + ConvSave := FConvertLineEnd; + try + FConvertLineEnd := True; + SendString(value + #$0D); + repeat + s := RecvString(90 * FAtTimeout); + if s <> Value then + result := result + s + CRLF; + if s = 'NO CARRIER' then + break; + if s = 'ERROR' then + break; + if s = 'BUSY' then + break; + if s = 'NO DIALTONE' then + break; + if Pos('CONNECT', s) = 1 then + begin + FAtResult := True; + break; + end; + until FLastError <> sOK; + finally + FConvertLineEnd := Convsave; + end; +end; + +function TBlockSerial.SerialCheck(SerialResult: integer): integer; +begin + if SerialResult = integer(INVALID_HANDLE_VALUE) then +{$IFDEF MSWINDOWS} + result := GetLastError +{$ELSE} + {$IFNDEF FPC} + result := GetLastError + {$ELSE} + result := fpGetErrno + {$ENDIF} +{$ENDIF} + else + result := sOK; + FLastError := result; + FLastErrorDesc := GetErrorDesc(FLastError); +end; + +procedure TBlockSerial.ExceptCheck; +var + e: ESynaSerError; + s: string; +begin + if FRaiseExcept and (FLastError <> sOK) then + begin + s := GetErrorDesc(FLastError); + e := ESynaSerError.CreateFmt('Communication error %d: %s', [FLastError, s]); + e.ErrorCode := FLastError; + e.ErrorMessage := s; + raise e; + end; +end; + +procedure TBlockSerial.SetSynaError(ErrNumber: integer); +begin + FLastError := ErrNumber; + FLastErrorDesc := GetErrorDesc(FLastError); +end; + +procedure TBlockSerial.RaiseSynaError(ErrNumber: integer); +begin + SetSynaError(ErrNumber); + ExceptCheck; +end; + +procedure TBlockSerial.DoStatus(Reason: THookSerialReason; const Value: string); +begin + if assigned(OnStatus) then + OnStatus(Self, Reason, Value); +end; + +{======================================================================} + +class function TBlockSerial.GetErrorDesc(ErrorCode: integer): string; +begin + Result:= ''; + case ErrorCode of + sOK: Result := 'OK'; + ErrAlreadyOwned: Result := 'Port owned by other process';{HGJ} + ErrAlreadyInUse: Result := 'Instance already in use'; {HGJ} + ErrWrongParameter: Result := 'Wrong parameter at call'; {HGJ} + ErrPortNotOpen: Result := 'Instance not yet connected'; {HGJ} + ErrNoDeviceAnswer: Result := 'No device answer detected'; {HGJ} + ErrMaxBuffer: Result := 'Maximal buffer length exceeded'; + ErrTimeout: Result := 'Timeout during operation'; + ErrNotRead: Result := 'Reading of data failed'; + ErrFrame: Result := 'Receive framing error'; + ErrOverrun: Result := 'Receive Overrun Error'; + ErrRxOver: Result := 'Receive Queue overflow'; + ErrRxParity: Result := 'Receive Parity Error'; + ErrTxFull: Result := 'Tranceive Queue is full'; + end; + if Result = '' then + begin + Result := SysErrorMessage(ErrorCode); + end; +end; + + +{---------- cpom Comport Ownership Manager Routines ------------- + by Hans-Georg Joepgen of Stuttgart, Germany. + Copyright (c) 2002, by Hans-Georg Joepgen + + Stefan Krauss of Stuttgart, Germany, contributed literature and Internet + research results, invaluable advice and excellent answers to the Comport + Ownership Manager. +} + +{$IFDEF UNIX} + +function TBlockSerial.LockfileName: String; +var + s: string; +begin + s := SeparateRight(FDevice, '/dev/'); + result := LockfileDirectory + '/LCK..' + s; +end; + +procedure TBlockSerial.CreateLockfile(PidNr: integer); +var + f: TextFile; + s: string; +begin + // Create content for file + s := IntToStr(PidNr); + while length(s) < 10 do + s := ' ' + s; + // Create file + try + AssignFile(f, LockfileName); + try + Rewrite(f); + writeln(f, s); + finally + CloseFile(f); + end; + // Allow all users to enjoy the benefits of cpom + s := 'chmod a+rw ' + LockfileName; +{$IFNDEF FPC} + FileSetReadOnly( LockfileName, False ) ; + // Libc.system(pchar(s)); +{$ELSE} + fpSystem(s); +{$ENDIF} + except + // not raise exception, if you not have write permission for lock. + on Exception do + ; + end; +end; + +function TBlockSerial.ReadLockfile: integer; +{Returns PID from Lockfile. Lockfile must exist.} +var + f: TextFile; + s: string; +begin + AssignFile(f, LockfileName); + Reset(f); + try + readln(f, s); + finally + CloseFile(f); + end; + Result := StrToIntDef(s, -1) +end; + +function TBlockSerial.cpomComportAccessible: boolean; +var + MyPid: integer; + Filename: string; +begin + Filename := LockfileName; + {$IFNDEF FPC} + MyPid := Libc.getpid; + {$ELSE} + MyPid := fpGetPid; + {$ENDIF} + // Make sure, the Lock Files Directory exists. We need it. + if not DirectoryExists(LockfileDirectory) then + CreateDir(LockfileDirectory); + // Check the Lockfile + if not FileExists (Filename) then + begin // comport is not locked. Lock it for us. + CreateLockfile(MyPid); + result := true; + exit; // done. + end; + // Is port owned by orphan? Then it's time for error recovery. + //FPC forgot to add getsid.. :-( + {$IFNDEF FPC} + if Libc.getsid(ReadLockfile) = -1 then + begin // Lockfile was left from former desaster + DeleteFile(Filename); // error recovery + CreateLockfile(MyPid); + result := true; + exit; + end; + {$ENDIF} + result := false // Sorry, port is owned by living PID and locked +end; + +procedure TBlockSerial.cpomReleaseComport; +begin + DeleteFile(LockfileName); +end; + +{$ENDIF} +{----------------------------------------------------------------} + +{$IFDEF MSWINDOWS} +function GetSerialPortNames: string; +var + reg: TRegistry; + l, v: TStringList; + n: integer; +begin + l := TStringList.Create; + v := TStringList.Create; + reg := TRegistry.Create; + try +{$IFNDEF VER100} +{$IFNDEF VER120} + reg.Access := KEY_READ; +{$ENDIF} +{$ENDIF} + reg.RootKey := HKEY_LOCAL_MACHINE; + reg.OpenKey('\HARDWARE\DEVICEMAP\SERIALCOMM', false); + reg.GetValueNames(l); + for n := 0 to l.Count - 1 do + v.Add(reg.ReadString(l[n])); + Result := v.CommaText; + finally + reg.Free; + l.Free; + v.Free; + end; +end; +{$ENDIF} +{$IFNDEF MSWINDOWS} +function GetSerialPortNames: string; +var + Index: Integer; + Data: string; + TmpPorts: String; + sr : TSearchRec; +begin + try + TmpPorts := ''; + if FindFirst('/dev/ttyS*', $FFFFFFFF, sr) = 0 then + begin + repeat + if (sr.Attr and $FFFFFFFF) = Sr.Attr then + begin + data := sr.Name; + index := length(data); + while (index > 1) and (data[index] <> '/') do + index := index - 1; + TmpPorts := TmpPorts + ' ' + copy(data, 1, index + 1); + end; + until FindNext(sr) <> 0; + end; + FindClose(sr); + finally + Result:=TmpPorts; + end; +end; +{$ENDIF} + +end. diff --git a/synapse/synautil.pas b/synapse/synautil.pas new file mode 100644 index 0000000..7b564f7 --- /dev/null +++ b/synapse/synautil.pas @@ -0,0 +1,2065 @@ +{==============================================================================| +| Project : Ararat Synapse | 004.015.000 | +|==============================================================================| +| Content: support procedures and functions | +|==============================================================================| +| 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) 1999-2012. | +| Portions created by Hernan Sanchez are Copyright (c) 2000. | +| Portions created by Petr Fejfar are Copyright (c)2011-2012. | +| 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(Support procedures and functions)} + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$Q-} +{$R-} +{$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} + {$WARN SUSPICIOUS_TYPECAST OFF} +{$ENDIF} + +unit synautil; + +interface + +uses +{$IFDEF MSWINDOWS} + Windows, +{$ELSE} + {$IFDEF FPC} + UnixUtil, Unix, BaseUnix, + {$ELSE} + Libc, + {$ENDIF} +{$ENDIF} +{$IFDEF CIL} + System.IO, +{$ENDIF} + SysUtils, Classes, SynaFpc; + +{$IFDEF VER100} +type + int64 = integer; +{$ENDIF} + +{:Return your timezone bias from UTC time in minutes.} +function TimeZoneBias: integer; + +{:Return your timezone bias from UTC time in string representation like "+0200".} +function TimeZone: string; + +{:Returns current time in format defined in RFC-822. Useful for SMTP messages, + but other protocols use this time format as well. Results contains the timezone + specification. Four digit year is used to break any Y2K concerns. (Example + 'Fri, 15 Oct 1999 21:14:56 +0200')} +function Rfc822DateTime(t: TDateTime): string; + +{:Returns date and time in format defined in C compilers in format "mmm dd hh:nn:ss"} +function CDateTime(t: TDateTime): string; + +{:Returns date and time in format defined in format 'yymmdd hhnnss'} +function SimpleDateTime(t: TDateTime): string; + +{:Returns date and time in format defined in ANSI C compilers in format + "ddd mmm d hh:nn:ss yyyy" } +function AnsiCDateTime(t: TDateTime): string; + +{:Decode three-letter string with name of month to their month number. If string + not match any month name, then is returned 0. For parsing are used predefined + names for English, French and German and names from system locale too.} +function GetMonthNumber(Value: String): integer; + +{:Return decoded time from given string. Time must be witch separator ':'. You + can use "hh:mm" or "hh:mm:ss".} +function GetTimeFromStr(Value: string): TDateTime; + +{:Decode string in format "m-d-y" to TDateTime type.} +function GetDateMDYFromStr(Value: string): TDateTime; + +{:Decode various string representations of date and time to Tdatetime type. + This function do all timezone corrections too! This function can decode lot of + formats like: + @longcode(# + ddd, d mmm yyyy hh:mm:ss + ddd, d mmm yy hh:mm:ss + ddd, mmm d yyyy hh:mm:ss + ddd mmm dd hh:mm:ss yyyy #) + +and more with lot of modifications, include: +@longcode(# +Sun, 06 Nov 1994 08:49:37 GMT ; RFC 822, updated by RFC 1123 +Sunday, 06-Nov-94 08:49:37 GMT ; RFC 850, obsoleted by RFC 1036 +Sun Nov 6 08:49:37 1994 ; ANSI C's asctime() Format +#) +Timezone corrections known lot of symbolic timezone names (like CEST, EDT, etc.) +or numeric representation (like +0200). By convention defined in RFC timezone + +0000 is GMT and -0000 is current your system timezone.} +function DecodeRfcDateTime(Value: string): TDateTime; + +{:Return current system date and time in UTC timezone.} +function GetUTTime: TDateTime; + +{:Set Newdt as current system date and time in UTC timezone. This function work + only if you have administrator rights!} +function SetUTTime(Newdt: TDateTime): Boolean; + +{:Return current value of system timer with precizion 1 millisecond. Good for + measure time difference.} +function GetTick: LongWord; + +{:Return difference between two timestamps. It working fine only for differences + smaller then maxint. (difference must be smaller then 24 days.)} +function TickDelta(TickOld, TickNew: LongWord): LongWord; + +{:Return two characters, which ordinal values represents the value in byte + format. (High-endian)} +function CodeInt(Value: Word): Ansistring; + +{:Decodes two characters located at "Index" offset position of the "Value" + string to Word values.} +function DecodeInt(const Value: Ansistring; Index: Integer): Word; + +{:Return four characters, which ordinal values represents the value in byte + format. (High-endian)} +function CodeLongInt(Value: LongInt): Ansistring; + +{:Decodes four characters located at "Index" offset position of the "Value" + string to LongInt values.} +function DecodeLongInt(const Value: Ansistring; Index: Integer): LongInt; + +{:Dump binary buffer stored in a string to a result string.} +function DumpStr(const Buffer: Ansistring): string; + +{:Dump binary buffer stored in a string to a result string. All bytes with code + of character is written as character, not as hexadecimal value.} +function DumpExStr(const Buffer: Ansistring): string; + +{:Dump binary buffer stored in a string to a file with DumpFile filename.} +procedure Dump(const Buffer: AnsiString; DumpFile: string); + +{:Dump binary buffer stored in a string to a file with DumpFile filename. All + bytes with code of character is written as character, not as hexadecimal value.} +procedure DumpEx(const Buffer: AnsiString; DumpFile: string); + +{:Like TrimLeft, but remove only spaces, not control characters!} +function TrimSPLeft(const S: string): string; + +{:Like TrimRight, but remove only spaces, not control characters!} +function TrimSPRight(const S: string): string; + +{:Like Trim, but remove only spaces, not control characters!} +function TrimSP(const S: string): string; + +{:Returns a portion of the "Value" string located to the left of the "Delimiter" + string. If a delimiter is not found, results is original string.} +function SeparateLeft(const Value, Delimiter: string): string; + +{:Returns the portion of the "Value" string located to the right of the + "Delimiter" string. If a delimiter is not found, results is original string.} +function SeparateRight(const Value, Delimiter: string): string; + +{:Returns parameter value from string in format: + parameter1="value1"; parameter2=value2} +function GetParameter(const Value, Parameter: string): string; + +{:parse value string with elements differed by Delimiter into stringlist.} +procedure ParseParametersEx(Value, Delimiter: string; const Parameters: TStrings); + +{:parse value string with elements differed by ';' into stringlist.} +procedure ParseParameters(Value: string; const Parameters: TStrings); + +{:Index of string in stringlist with same beginning as Value is returned.} +function IndexByBegin(Value: string; const List: TStrings): integer; + +{:Returns only the e-mail portion of an address from the full address format. + i.e. returns 'nobody@@somewhere.com' from '"someone" <nobody@@somewhere.com>'} +function GetEmailAddr(const Value: string): string; + +{:Returns only the description part from a full address format. i.e. returns + 'someone' from '"someone" <nobody@@somewhere.com>'} +function GetEmailDesc(Value: string): string; + +{:Returns a string with hexadecimal digits representing the corresponding values + of the bytes found in "Value" string.} +function StrToHex(const Value: Ansistring): string; + +{:Returns a string of binary "Digits" representing "Value".} +function IntToBin(Value: Integer; Digits: Byte): string; + +{:Returns an integer equivalent of the binary string in "Value". + (i.e. ('10001010') returns 138)} +function BinToInt(const Value: string): Integer; + +{:Parses a URL to its various components.} +function ParseURL(URL: string; var Prot, User, Pass, Host, Port, Path, + Para: string): string; + +{:Replaces all "Search" string values found within "Value" string, with the + "Replace" string value.} +function ReplaceString(Value, Search, Replace: AnsiString): AnsiString; + +{:It is like RPos, but search is from specified possition.} +function RPosEx(const Sub, Value: string; From: integer): Integer; + +{:It is like POS function, but from right side of Value string.} +function RPos(const Sub, Value: String): Integer; + +{:Like @link(fetch), but working with binary strings, not with text.} +function FetchBin(var Value: string; const Delimiter: string): string; + +{:Fetch string from left of Value string.} +function Fetch(var Value: string; const Delimiter: string): string; + +{:Fetch string from left of Value string. This function ignore delimitesr inside + quotations.} +function FetchEx(var Value: string; const Delimiter, Quotation: string): string; + +{:If string is binary string (contains non-printable characters), then is + returned true.} +function IsBinaryString(const Value: AnsiString): Boolean; + +{:return position of string terminator in string. If terminator found, then is + returned in terminator parameter. + Possible line terminators are: CRLF, LFCR, CR, LF} +function PosCRLF(const Value: AnsiString; var Terminator: AnsiString): integer; + +{:Delete empty strings from end of stringlist.} +Procedure StringsTrim(const value: TStrings); + +{:Like Pos function, buf from given string possition.} +function PosFrom(const SubStr, Value: String; From: integer): integer; + +{$IFNDEF CIL} +{:Increase pointer by value.} +function IncPoint(const p: pointer; Value: integer): pointer; +{$ENDIF} + +{:Get string between PairBegin and PairEnd. This function respect nesting. + For example: + @longcode(# + Value is: 'Hi! (hello(yes!))' + pairbegin is: '(' + pairend is: ')' + In this case result is: 'hello(yes!)'#)} +function GetBetween(const PairBegin, PairEnd, Value: string): string; + +{:Return count of Chr in Value string.} +function CountOfChar(const Value: string; Chr: char): integer; + +{:Remove quotation from Value string. If Value is not quoted, then return same + string without any modification. } +function UnquoteStr(const Value: string; Quote: Char): string; + +{:Quote Value string. If Value contains some Quote chars, then it is doubled.} +function QuoteStr(const Value: string; Quote: Char): string; + +{:Convert lines in stringlist from 'name: value' form to 'name=value' form.} +procedure HeadersToList(const Value: TStrings); + +{:Convert lines in stringlist from 'name=value' form to 'name: value' form.} +procedure ListToHeaders(const Value: TStrings); + +{:swap bytes in integer.} +function SwapBytes(Value: integer): integer; + +{:read string with requested length form stream.} +function ReadStrFromStream(const Stream: TStream; len: integer): AnsiString; + +{:write string to stream.} +procedure WriteStrToStream(const Stream: TStream; Value: AnsiString); + +{:Return filename of new temporary file in Dir (if empty, then default temporary + directory is used) and with optional filename prefix.} +function GetTempFile(const Dir, prefix: AnsiString): AnsiString; + +{:Return padded string. If length is greater, string is truncated. If length is + smaller, string is padded by Pad character.} +function PadString(const Value: AnsiString; len: integer; Pad: AnsiChar): AnsiString; + +{:XOR each byte in the strings} +function XorString(Indata1, Indata2: AnsiString): AnsiString; + +{:Read header from "Value" stringlist beginning at "Index" position. If header + is Splitted into multiple lines, then this procedure de-split it into one line.} +function NormalizeHeader(Value: TStrings; var Index: Integer): string; + +{pf} +{:Search for one of line terminators CR, LF or NUL. Return position of the + line beginning and length of text.} +procedure SearchForLineBreak(var APtr:PANSIChar; AEtx:PANSIChar; out ABol:PANSIChar; out ALength:integer); +{:Skip both line terminators CR LF (if any). Move APtr position forward.} +procedure SkipLineBreak(var APtr:PANSIChar; AEtx:PANSIChar); +{:Skip all blank lines in a buffer starting at APtr and move APtr position forward.} +procedure SkipNullLines (var APtr:PANSIChar; AEtx:PANSIChar); +{:Copy all lines from a buffer starting at APtr to ALines until empty line + or end of the buffer is reached. Move APtr position forward).} +procedure CopyLinesFromStreamUntilNullLine(var APtr:PANSIChar; AEtx:PANSIChar; ALines:TStrings); +{:Copy all lines from a buffer starting at APtr to ALines until ABoundary + or end of the buffer is reached. Move APtr position forward).} +procedure CopyLinesFromStreamUntilBoundary(var APtr:PANSIChar; AEtx:PANSIChar; ALines:TStrings; const ABoundary:ANSIString); +{:Search ABoundary in a buffer starting at APtr. + Return beginning of the ABoundary. Move APtr forward behind a trailing CRLF if any).} +function SearchForBoundary (var APtr:PANSIChar; AEtx:PANSIChar; const ABoundary:ANSIString): PANSIChar; +{:Compare a text at position ABOL with ABoundary and return position behind the + match (including a trailing CRLF if any).} +function MatchBoundary (ABOL,AETX:PANSIChar; const ABoundary:ANSIString): PANSIChar; +{:Compare a text at position ABOL with ABoundary + the last boundary suffix + and return position behind the match (including a trailing CRLF if any).} +function MatchLastBoundary (ABOL,AETX:PANSIChar; const ABoundary:ANSIString): PANSIChar; +{:Copy data from a buffer starting at position APtr and delimited by AEtx + position into ANSIString.} +function BuildStringFromBuffer (AStx,AEtx:PANSIChar): ANSIString; +{/pf} + +var + {:can be used for your own months strings for @link(getmonthnumber)} + CustomMonthNames: array[1..12] of string; + +implementation + +{==============================================================================} + +const + MyDayNames: array[1..7] of AnsiString = + ('Sun', 'Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat'); +var + MyMonthNames: array[0..6, 1..12] of String = + ( + ('Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', //rewrited by system locales + 'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec'), + ('Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', //English + 'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec'), + ('jan', 'fv', 'mar', 'avr', 'mai', 'jun', //French + 'jul', 'ao', 'sep', 'oct', 'nov', 'dc'), + ('jan', 'fev', 'mar', 'avr', 'mai', 'jun', //French#2 + 'jul', 'aou', 'sep', 'oct', 'nov', 'dec'), + ('Jan', 'Feb', 'Mar', 'Apr', 'Mai', 'Jun', //German + 'Jul', 'Aug', 'Sep', 'Okt', 'Nov', 'Dez'), + ('Jan', 'Feb', 'Mr', 'Apr', 'Mai', 'Jun', //German#2 + 'Jul', 'Aug', 'Sep', 'Okt', 'Nov', 'Dez'), + ('Led', 'no', 'Be', 'Dub', 'Kv', 'en', //Czech + 'ec', 'Srp', 'Z', 'j', 'Lis', 'Pro') + ); + + +{==============================================================================} + +function TimeZoneBias: integer; +{$IFNDEF MSWINDOWS} +{$IFNDEF FPC} +var + t: TTime_T; + UT: TUnixTime; +begin + __time(@T); + localtime_r(@T, UT); + Result := ut.__tm_gmtoff div 60; +{$ELSE} +begin + Result := TZSeconds div 60; +{$ENDIF} +{$ELSE} +var + zoneinfo: TTimeZoneInformation; + bias: Integer; +begin + case GetTimeZoneInformation(Zoneinfo) of + 2: + bias := zoneinfo.Bias + zoneinfo.DaylightBias; + 1: + bias := zoneinfo.Bias + zoneinfo.StandardBias; + else + bias := zoneinfo.Bias; + end; + Result := bias * (-1); +{$ENDIF} +end; + +{==============================================================================} + +function TimeZone: string; +var + bias: Integer; + h, m: Integer; +begin + bias := TimeZoneBias; + if bias >= 0 then + Result := '+' + else + Result := '-'; + bias := Abs(bias); + h := bias div 60; + m := bias mod 60; + Result := Result + Format('%.2d%.2d', [h, m]); +end; + +{==============================================================================} + +function Rfc822DateTime(t: TDateTime): string; +var + wYear, wMonth, wDay: word; +begin + DecodeDate(t, wYear, wMonth, wDay); + Result := Format('%s, %d %s %s %s', [MyDayNames[DayOfWeek(t)], wDay, + MyMonthNames[1, wMonth], FormatDateTime('yyyy hh":"nn":"ss', t), TimeZone]); +end; + +{==============================================================================} + +function CDateTime(t: TDateTime): string; +var + wYear, wMonth, wDay: word; +begin + DecodeDate(t, wYear, wMonth, wDay); + Result:= Format('%s %2d %s', [MyMonthNames[1, wMonth], wDay, + FormatDateTime('hh":"nn":"ss', t)]); +end; + +{==============================================================================} + +function SimpleDateTime(t: TDateTime): string; +begin + Result := FormatDateTime('yymmdd hhnnss', t); +end; + +{==============================================================================} + +function AnsiCDateTime(t: TDateTime): string; +var + wYear, wMonth, wDay: word; +begin + DecodeDate(t, wYear, wMonth, wDay); + Result := Format('%s %s %d %s', [MyDayNames[DayOfWeek(t)], MyMonthNames[1, wMonth], + wDay, FormatDateTime('hh":"nn":"ss yyyy ', t)]); +end; + +{==============================================================================} + +function DecodeTimeZone(Value: string; var Zone: integer): Boolean; +var + x: integer; + zh, zm: integer; + s: string; +begin + Result := false; + s := Value; + if (Pos('+', s) = 1) or (Pos('-',s) = 1) then + begin + if s = '-0000' then + Zone := TimeZoneBias + else + if Length(s) > 4 then + begin + zh := StrToIntdef(s[2] + s[3], 0); + zm := StrToIntdef(s[4] + s[5], 0); + zone := zh * 60 + zm; + if s[1] = '-' then + zone := zone * (-1); + end; + Result := True; + end + else + begin + x := 32767; + if s = 'NZDT' then x := 13; + if s = 'IDLE' then x := 12; + if s = 'NZST' then x := 12; + if s = 'NZT' then x := 12; + if s = 'EADT' then x := 11; + if s = 'GST' then x := 10; + if s = 'JST' then x := 9; + if s = 'CCT' then x := 8; + if s = 'WADT' then x := 8; + if s = 'WAST' then x := 7; + if s = 'ZP6' then x := 6; + if s = 'ZP5' then x := 5; + if s = 'ZP4' then x := 4; + if s = 'BT' then x := 3; + if s = 'EET' then x := 2; + if s = 'MEST' then x := 2; + if s = 'MESZ' then x := 2; + if s = 'SST' then x := 2; + if s = 'FST' then x := 2; + if s = 'CEST' then x := 2; + if s = 'CET' then x := 1; + if s = 'FWT' then x := 1; + if s = 'MET' then x := 1; + if s = 'MEWT' then x := 1; + if s = 'SWT' then x := 1; + if s = 'UT' then x := 0; + if s = 'UTC' then x := 0; + if s = 'GMT' then x := 0; + if s = 'WET' then x := 0; + if s = 'WAT' then x := -1; + if s = 'BST' then x := -1; + if s = 'AT' then x := -2; + if s = 'ADT' then x := -3; + if s = 'AST' then x := -4; + if s = 'EDT' then x := -4; + if s = 'EST' then x := -5; + if s = 'CDT' then x := -5; + if s = 'CST' then x := -6; + if s = 'MDT' then x := -6; + if s = 'MST' then x := -7; + if s = 'PDT' then x := -7; + if s = 'PST' then x := -8; + if s = 'YDT' then x := -8; + if s = 'YST' then x := -9; + if s = 'HDT' then x := -9; + if s = 'AHST' then x := -10; + if s = 'CAT' then x := -10; + if s = 'HST' then x := -10; + if s = 'EAST' then x := -10; + if s = 'NT' then x := -11; + if s = 'IDLW' then x := -12; + if x <> 32767 then + begin + zone := x * 60; + Result := True; + end; + end; +end; + +{==============================================================================} + +function GetMonthNumber(Value: String): integer; +var + n: integer; + function TestMonth(Value: String; Index: Integer): Boolean; + var + n: integer; + begin + Result := False; + for n := 0 to 6 do + if Value = AnsiUppercase(MyMonthNames[n, Index]) then + begin + Result := True; + Break; + end; + end; +begin + Result := 0; + Value := AnsiUppercase(Value); + for n := 1 to 12 do + if TestMonth(Value, n) or (Value = AnsiUppercase(CustomMonthNames[n])) then + begin + Result := n; + Break; + end; +end; + +{==============================================================================} + +function GetTimeFromStr(Value: string): TDateTime; +var + x: integer; +begin + x := rpos(':', Value); + if (x > 0) and ((Length(Value) - x) > 2) then + Value := Copy(Value, 1, x + 2); + Value := ReplaceString(Value, ':', TimeSeparator); + Result := -1; + try + Result := StrToTime(Value); + except + on Exception do ; + end; +end; + +{==============================================================================} + +function GetDateMDYFromStr(Value: string): TDateTime; +var + wYear, wMonth, wDay: word; + s: string; +begin + Result := 0; + s := Fetch(Value, '-'); + wMonth := StrToIntDef(s, 12); + s := Fetch(Value, '-'); + wDay := StrToIntDef(s, 30); + wYear := StrToIntDef(Value, 1899); + if wYear < 1000 then + if (wYear > 99) then + wYear := wYear + 1900 + else + if wYear > 50 then + wYear := wYear + 1900 + else + wYear := wYear + 2000; + try + Result := EncodeDate(wYear, wMonth, wDay); + except + on Exception do ; + end; +end; + +{==============================================================================} + +function DecodeRfcDateTime(Value: string): TDateTime; +var + day, month, year: Word; + zone: integer; + x, y: integer; + s: string; + t: TDateTime; +begin +// ddd, d mmm yyyy hh:mm:ss +// ddd, d mmm yy hh:mm:ss +// ddd, mmm d yyyy hh:mm:ss +// ddd mmm dd hh:mm:ss yyyy +// Sun, 06 Nov 1994 08:49:37 GMT ; RFC 822, updated by RFC 1123 +// Sunday, 06-Nov-94 08:49:37 GMT ; RFC 850, obsoleted by RFC 1036 +// Sun Nov 6 08:49:37 1994 ; ANSI C's asctime() Format + + Result := 0; + if Value = '' then + Exit; + day := 0; + month := 0; + year := 0; + zone := 0; + Value := ReplaceString(Value, ' -', ' #'); + Value := ReplaceString(Value, '-', ' '); + Value := ReplaceString(Value, ' #', ' -'); + while Value <> '' do + begin + s := Fetch(Value, ' '); + s := uppercase(s); + // timezone + if DecodetimeZone(s, x) then + begin + zone := x; + continue; + end; + x := StrToIntDef(s, 0); + // day or year + if x > 0 then + if (x < 32) and (day = 0) then + begin + day := x; + continue; + end + else + begin + if (year = 0) and ((month > 0) or (x > 12)) then + begin + year := x; + if year < 32 then + year := year + 2000; + if year < 1000 then + year := year + 1900; + continue; + end; + end; + // time + if rpos(':', s) > Pos(':', s) then + begin + t := GetTimeFromStr(s); + if t <> -1 then + Result := t; + continue; + end; + //timezone daylight saving time + if s = 'DST' then + begin + zone := zone + 60; + continue; + end; + // month + y := GetMonthNumber(s); + if (y > 0) and (month = 0) then + month := y; + end; + if year = 0 then + year := 1980; + if month < 1 then + month := 1; + if month > 12 then + month := 12; + if day < 1 then + day := 1; + x := MonthDays[IsLeapYear(year), month]; + if day > x then + day := x; + Result := Result + Encodedate(year, month, day); + zone := zone - TimeZoneBias; + x := zone div 1440; + Result := Result - x; + zone := zone mod 1440; + t := EncodeTime(Abs(zone) div 60, Abs(zone) mod 60, 0, 0); + if zone < 0 then + t := 0 - t; + Result := Result - t; +end; + +{==============================================================================} + +function GetUTTime: TDateTime; +{$IFDEF MSWINDOWS} +{$IFNDEF FPC} +var + st: TSystemTime; +begin + GetSystemTime(st); + result := SystemTimeToDateTime(st); +{$ELSE} +var + st: SysUtils.TSystemTime; + stw: Windows.TSystemTime; +begin + GetSystemTime(stw); + st.Year := stw.wYear; + st.Month := stw.wMonth; + st.Day := stw.wDay; + st.Hour := stw.wHour; + st.Minute := stw.wMinute; + st.Second := stw.wSecond; + st.Millisecond := stw.wMilliseconds; + result := SystemTimeToDateTime(st); +{$ENDIF} +{$ELSE} +{$IFNDEF FPC} +var + TV: TTimeVal; +begin + gettimeofday(TV, nil); + Result := UnixDateDelta + (TV.tv_sec + TV.tv_usec / 1000000) / 86400; +{$ELSE} +var + TV: TimeVal; +begin + fpgettimeofday(@TV, nil); + Result := UnixDateDelta + (TV.tv_sec + TV.tv_usec / 1000000) / 86400; +{$ENDIF} +{$ENDIF} +end; + +{==============================================================================} + +function SetUTTime(Newdt: TDateTime): Boolean; +{$IFDEF MSWINDOWS} +{$IFNDEF FPC} +var + st: TSystemTime; +begin + DateTimeToSystemTime(newdt,st); + Result := SetSystemTime(st); +{$ELSE} +var + st: SysUtils.TSystemTime; + stw: Windows.TSystemTime; +begin + DateTimeToSystemTime(newdt,st); + stw.wYear := st.Year; + stw.wMonth := st.Month; + stw.wDay := st.Day; + stw.wHour := st.Hour; + stw.wMinute := st.Minute; + stw.wSecond := st.Second; + stw.wMilliseconds := st.Millisecond; + Result := SetSystemTime(stw); +{$ENDIF} +{$ELSE} +{$IFNDEF FPC} +var + TV: TTimeVal; + d: double; + TZ: Ttimezone; + PZ: PTimeZone; +begin + TZ.tz_minuteswest := 0; + TZ.tz_dsttime := 0; + PZ := @TZ; + gettimeofday(TV, PZ); + d := (newdt - UnixDateDelta) * 86400; + TV.tv_sec := trunc(d); + TV.tv_usec := trunc(frac(d) * 1000000); + Result := settimeofday(TV, TZ) <> -1; +{$ELSE} +var + TV: TimeVal; + d: double; +begin + d := (newdt - UnixDateDelta) * 86400; + TV.tv_sec := trunc(d); + TV.tv_usec := trunc(frac(d) * 1000000); + Result := fpsettimeofday(@TV, nil) <> -1; +{$ENDIF} +{$ENDIF} +end; + +{==============================================================================} + +{$IFNDEF MSWINDOWS} +function GetTick: LongWord; +var + Stamp: TTimeStamp; +begin + Stamp := DateTimeToTimeStamp(Now); + Result := Stamp.Time; +end; +{$ELSE} +function GetTick: LongWord; +var + tick, freq: TLargeInteger; +{$IFDEF VER100} + x: TLargeInteger; +{$ENDIF} +begin + if Windows.QueryPerformanceFrequency(freq) then + begin + Windows.QueryPerformanceCounter(tick); +{$IFDEF VER100} + x.QuadPart := (tick.QuadPart / freq.QuadPart) * 1000; + Result := x.LowPart; +{$ELSE} + Result := Trunc((tick / freq) * 1000) and High(LongWord) +{$ENDIF} + end + else + Result := Windows.GetTickCount; +end; +{$ENDIF} + +{==============================================================================} + +function TickDelta(TickOld, TickNew: LongWord): LongWord; +begin +//if DWord is signed type (older Deplhi), +// then it not work properly on differencies larger then maxint! + Result := 0; + if TickOld <> TickNew then + begin + if TickNew < TickOld then + begin + TickNew := TickNew + LongWord(MaxInt) + 1; + TickOld := TickOld + LongWord(MaxInt) + 1; + end; + Result := TickNew - TickOld; + if TickNew < TickOld then + if Result > 0 then + Result := 0 - Result; + end; +end; + +{==============================================================================} + +function CodeInt(Value: Word): Ansistring; +begin + setlength(result, 2); + result[1] := AnsiChar(Value div 256); + result[2] := AnsiChar(Value mod 256); +// Result := AnsiChar(Value div 256) + AnsiChar(Value mod 256) +end; + +{==============================================================================} + +function DecodeInt(const Value: Ansistring; Index: Integer): Word; +var + x, y: Byte; +begin + if Length(Value) > Index then + x := Ord(Value[Index]) + else + x := 0; + if Length(Value) >= (Index + 1) then + y := Ord(Value[Index + 1]) + else + y := 0; + Result := x * 256 + y; +end; + +{==============================================================================} + +function CodeLongInt(Value: Longint): Ansistring; +var + x, y: word; +begin + // this is fix for negative numbers on systems where longint = integer + x := (Value shr 16) and integer($ffff); + y := Value and integer($ffff); + setlength(result, 4); + result[1] := AnsiChar(x div 256); + result[2] := AnsiChar(x mod 256); + result[3] := AnsiChar(y div 256); + result[4] := AnsiChar(y mod 256); +end; + +{==============================================================================} + +function DecodeLongInt(const Value: Ansistring; Index: Integer): LongInt; +var + x, y: Byte; + xl, yl: Byte; +begin + if Length(Value) > Index then + x := Ord(Value[Index]) + else + x := 0; + if Length(Value) >= (Index + 1) then + y := Ord(Value[Index + 1]) + else + y := 0; + if Length(Value) >= (Index + 2) then + xl := Ord(Value[Index + 2]) + else + xl := 0; + if Length(Value) >= (Index + 3) then + yl := Ord(Value[Index + 3]) + else + yl := 0; + Result := ((x * 256 + y) * 65536) + (xl * 256 + yl); +end; + +{==============================================================================} + +function DumpStr(const Buffer: Ansistring): string; +var + n: Integer; +begin + Result := ''; + for n := 1 to Length(Buffer) do + Result := Result + ' +#$' + IntToHex(Ord(Buffer[n]), 2); +end; + +{==============================================================================} + +function DumpExStr(const Buffer: Ansistring): string; +var + n: Integer; + x: Byte; +begin + Result := ''; + for n := 1 to Length(Buffer) do + begin + x := Ord(Buffer[n]); + if x in [65..90, 97..122] then + Result := Result + ' +''' + char(x) + '''' + else + Result := Result + ' +#$' + IntToHex(Ord(Buffer[n]), 2); + end; +end; + +{==============================================================================} + +procedure Dump(const Buffer: AnsiString; DumpFile: string); +var + f: Text; +begin + AssignFile(f, DumpFile); + if FileExists(DumpFile) then + DeleteFile(DumpFile); + Rewrite(f); + try + Writeln(f, DumpStr(Buffer)); + finally + CloseFile(f); + end; +end; + +{==============================================================================} + +procedure DumpEx(const Buffer: AnsiString; DumpFile: string); +var + f: Text; +begin + AssignFile(f, DumpFile); + if FileExists(DumpFile) then + DeleteFile(DumpFile); + Rewrite(f); + try + Writeln(f, DumpExStr(Buffer)); + finally + CloseFile(f); + end; +end; + +{==============================================================================} + +function TrimSPLeft(const S: string): string; +var + I, L: Integer; +begin + Result := ''; + if S = '' then + Exit; + L := Length(S); + I := 1; + while (I <= L) and (S[I] = ' ') do + Inc(I); + Result := Copy(S, I, Maxint); +end; + +{==============================================================================} + +function TrimSPRight(const S: string): string; +var + I: Integer; +begin + Result := ''; + if S = '' then + Exit; + I := Length(S); + while (I > 0) and (S[I] = ' ') do + Dec(I); + Result := Copy(S, 1, I); +end; + +{==============================================================================} + +function TrimSP(const S: string): string; +begin + Result := TrimSPLeft(s); + Result := TrimSPRight(Result); +end; + +{==============================================================================} + +function SeparateLeft(const Value, Delimiter: string): string; +var + x: Integer; +begin + x := Pos(Delimiter, Value); + if x < 1 then + Result := Value + else + Result := Copy(Value, 1, x - 1); +end; + +{==============================================================================} + +function SeparateRight(const Value, Delimiter: string): string; +var + x: Integer; +begin + x := Pos(Delimiter, Value); + if x > 0 then + x := x + Length(Delimiter) - 1; + Result := Copy(Value, x + 1, Length(Value) - x); +end; + +{==============================================================================} + +function GetParameter(const Value, Parameter: string): string; +var + s: string; + v: string; +begin + Result := ''; + v := Value; + while v <> '' do + begin + s := Trim(FetchEx(v, ';', '"')); + if Pos(Uppercase(parameter), Uppercase(s)) = 1 then + begin + Delete(s, 1, Length(Parameter)); + s := Trim(s); + if s = '' then + Break; + if s[1] = '=' then + begin + Result := Trim(SeparateRight(s, '=')); + Result := UnquoteStr(Result, '"'); + break; + end; + end; + end; +end; + +{==============================================================================} + +procedure ParseParametersEx(Value, Delimiter: string; const Parameters: TStrings); +var + s: string; +begin + Parameters.Clear; + while Value <> '' do + begin + s := Trim(FetchEx(Value, Delimiter, '"')); + Parameters.Add(s); + end; +end; + +{==============================================================================} + +procedure ParseParameters(Value: string; const Parameters: TStrings); +begin + ParseParametersEx(Value, ';', Parameters); +end; + +{==============================================================================} + +function IndexByBegin(Value: string; const List: TStrings): integer; +var + n: integer; + s: string; +begin + Result := -1; + Value := uppercase(Value); + for n := 0 to List.Count -1 do + begin + s := UpperCase(List[n]); + if Pos(Value, s) = 1 then + begin + Result := n; + Break; + end; + end; +end; + +{==============================================================================} + +function GetEmailAddr(const Value: string): string; +var + s: string; +begin + s := SeparateRight(Value, '<'); + s := SeparateLeft(s, '>'); + Result := Trim(s); +end; + +{==============================================================================} + +function GetEmailDesc(Value: string): string; +var + s: string; +begin + Value := Trim(Value); + s := SeparateRight(Value, '"'); + if s <> Value then + s := SeparateLeft(s, '"') + else + begin + s := SeparateLeft(Value, '<'); + if s = Value then + begin + s := SeparateRight(Value, '('); + if s <> Value then + s := SeparateLeft(s, ')') + else + s := ''; + end; + end; + Result := Trim(s); +end; + +{==============================================================================} + +function StrToHex(const Value: Ansistring): string; +var + n: Integer; +begin + Result := ''; + for n := 1 to Length(Value) do + Result := Result + IntToHex(Byte(Value[n]), 2); + Result := LowerCase(Result); +end; + +{==============================================================================} + +function IntToBin(Value: Integer; Digits: Byte): string; +var + x, y, n: Integer; +begin + Result := ''; + x := Value; + repeat + y := x mod 2; + x := x div 2; + if y > 0 then + Result := '1' + Result + else + Result := '0' + Result; + until x = 0; + x := Length(Result); + for n := x to Digits - 1 do + Result := '0' + Result; +end; + +{==============================================================================} + +function BinToInt(const Value: string): Integer; +var + n: Integer; +begin + Result := 0; + for n := 1 to Length(Value) do + begin + if Value[n] = '0' then + Result := Result * 2 + else + if Value[n] = '1' then + Result := Result * 2 + 1 + else + Break; + end; +end; + +{==============================================================================} + +function ParseURL(URL: string; var Prot, User, Pass, Host, Port, Path, + Para: string): string; +var + x, y: Integer; + sURL: string; + s: string; + s1, s2: string; +begin + Prot := 'http'; + User := ''; + Pass := ''; + Port := '80'; + Para := ''; + + x := Pos('://', URL); + if x > 0 then + begin + Prot := SeparateLeft(URL, '://'); + sURL := SeparateRight(URL, '://'); + end + else + sURL := URL; + if UpperCase(Prot) = 'HTTPS' then + Port := '443'; + if UpperCase(Prot) = 'FTP' then + Port := '21'; + x := Pos('@', sURL); + y := Pos('/', sURL); + if (x > 0) and ((x < y) or (y < 1))then + begin + s := SeparateLeft(sURL, '@'); + sURL := SeparateRight(sURL, '@'); + x := Pos(':', s); + if x > 0 then + begin + User := SeparateLeft(s, ':'); + Pass := SeparateRight(s, ':'); + end + else + User := s; + end; + x := Pos('/', sURL); + if x > 0 then + begin + s1 := SeparateLeft(sURL, '/'); + s2 := SeparateRight(sURL, '/'); + end + else + begin + s1 := sURL; + s2 := ''; + end; + if Pos('[', s1) = 1 then + begin + Host := Separateleft(s1, ']'); + Delete(Host, 1, 1); + s1 := SeparateRight(s1, ']'); + if Pos(':', s1) = 1 then + Port := SeparateRight(s1, ':'); + end + else + begin + x := Pos(':', s1); + if x > 0 then + begin + Host := SeparateLeft(s1, ':'); + Port := SeparateRight(s1, ':'); + end + else + Host := s1; + end; + Result := '/' + s2; + x := Pos('?', s2); + if x > 0 then + begin + Path := '/' + SeparateLeft(s2, '?'); + Para := SeparateRight(s2, '?'); + end + else + Path := '/' + s2; + if Host = '' then + Host := 'localhost'; +end; + +{==============================================================================} + +function ReplaceString(Value, Search, Replace: AnsiString): AnsiString; +var + x, l, ls, lr: Integer; +begin + if (Value = '') or (Search = '') then + begin + Result := Value; + Exit; + end; + ls := Length(Search); + lr := Length(Replace); + Result := ''; + x := Pos(Search, Value); + while x > 0 do + begin + {$IFNDEF CIL} + l := Length(Result); + SetLength(Result, l + x - 1); + Move(Pointer(Value)^, Pointer(@Result[l + 1])^, x - 1); + {$ELSE} + Result:=Result+Copy(Value,1,x-1); + {$ENDIF} + {$IFNDEF CIL} + l := Length(Result); + SetLength(Result, l + lr); + Move(Pointer(Replace)^, Pointer(@Result[l + 1])^, lr); + {$ELSE} + Result:=Result+Replace; + {$ENDIF} + Delete(Value, 1, x - 1 + ls); + x := Pos(Search, Value); + end; + Result := Result + Value; +end; + +{==============================================================================} + +function RPosEx(const Sub, Value: string; From: integer): Integer; +var + n: Integer; + l: Integer; +begin + result := 0; + l := Length(Sub); + for n := From - l + 1 downto 1 do + begin + if Copy(Value, n, l) = Sub then + begin + result := n; + break; + end; + end; +end; + +{==============================================================================} + +function RPos(const Sub, Value: String): Integer; +begin + Result := RPosEx(Sub, Value, Length(Value)); +end; + +{==============================================================================} + +function FetchBin(var Value: string; const Delimiter: string): string; +var + s: string; +begin + Result := SeparateLeft(Value, Delimiter); + s := SeparateRight(Value, Delimiter); + if s = Value then + Value := '' + else + Value := s; +end; + +{==============================================================================} + +function Fetch(var Value: string; const Delimiter: string): string; +begin + Result := FetchBin(Value, Delimiter); + Result := TrimSP(Result); + Value := TrimSP(Value); +end; + +{==============================================================================} + +function FetchEx(var Value: string; const Delimiter, Quotation: string): string; +var + b: Boolean; +begin + Result := ''; + b := False; + while Length(Value) > 0 do + begin + if b then + begin + if Pos(Quotation, Value) = 1 then + b := False; + Result := Result + Value[1]; + Delete(Value, 1, 1); + end + else + begin + if Pos(Delimiter, Value) = 1 then + begin + Delete(Value, 1, Length(delimiter)); + break; + end; + b := Pos(Quotation, Value) = 1; + Result := Result + Value[1]; + Delete(Value, 1, 1); + end; + end; +end; + +{==============================================================================} + +function IsBinaryString(const Value: AnsiString): Boolean; +var + n: integer; +begin + Result := False; + for n := 1 to Length(Value) do + if Value[n] in [#0..#8, #10..#31] then + //ignore null-terminated strings + if not ((n = Length(value)) and (Value[n] = AnsiChar(#0))) then + begin + Result := True; + Break; + end; +end; + +{==============================================================================} + +function PosCRLF(const Value: AnsiString; var Terminator: AnsiString): integer; +var + n, l: integer; +begin + Result := -1; + Terminator := ''; + l := length(value); + for n := 1 to l do + if value[n] in [#$0d, #$0a] then + begin + Result := n; + Terminator := Value[n]; + if n <> l then + case value[n] of + #$0d: + if value[n + 1] = #$0a then + Terminator := #$0d + #$0a; + #$0a: + if value[n + 1] = #$0d then + Terminator := #$0a + #$0d; + end; + Break; + end; +end; + +{==============================================================================} + +Procedure StringsTrim(const Value: TStrings); +var + n: integer; +begin + for n := Value.Count - 1 downto 0 do + if Value[n] = '' then + Value.Delete(n) + else + Break; +end; + +{==============================================================================} + +function PosFrom(const SubStr, Value: String; From: integer): integer; +var + ls,lv: integer; +begin + Result := 0; + ls := Length(SubStr); + lv := Length(Value); + if (ls = 0) or (lv = 0) then + Exit; + if From < 1 then + From := 1; + while (ls + from - 1) <= (lv) do + begin + {$IFNDEF CIL} + if CompareMem(@SubStr[1],@Value[from],ls) then + {$ELSE} + if SubStr = copy(Value, from, ls) then + {$ENDIF} + begin + result := from; + break; + end + else + inc(from); + end; +end; + +{==============================================================================} + +{$IFNDEF CIL} +function IncPoint(const p: pointer; Value: integer): pointer; +begin + Result := PAnsiChar(p) + Value; +end; +{$ENDIF} + +{==============================================================================} +//improved by 'DoggyDawg' +function GetBetween(const PairBegin, PairEnd, Value: string): string; +var + n: integer; + x: integer; + s: string; + lenBegin: integer; + lenEnd: integer; + str: string; + max: integer; +begin + lenBegin := Length(PairBegin); + lenEnd := Length(PairEnd); + n := Length(Value); + if (Value = PairBegin + PairEnd) then + begin + Result := '';//nothing between + exit; + end; + if (n < lenBegin + lenEnd) then + begin + Result := Value; + exit; + end; + s := SeparateRight(Value, PairBegin); + if (s = Value) then + begin + Result := Value; + exit; + end; + n := Pos(PairEnd, s); + if (n = 0) then + begin + Result := Value; + exit; + end; + Result := ''; + x := 1; + max := Length(s) - lenEnd + 1; + for n := 1 to max do + begin + str := copy(s, n, lenEnd); + if (str = PairEnd) then + begin + Dec(x); + if (x <= 0) then + Break; + end; + str := copy(s, n, lenBegin); + if (str = PairBegin) then + Inc(x); + Result := Result + s[n]; + end; +end; + +{==============================================================================} + +function CountOfChar(const Value: string; Chr: char): integer; +var + n: integer; +begin + Result := 0; + for n := 1 to Length(Value) do + if Value[n] = chr then + Inc(Result); +end; + +{==============================================================================} +// ! do not use AnsiExtractQuotedStr, it's very buggy and can crash application! +function UnquoteStr(const Value: string; Quote: Char): string; +var + n: integer; + inq, dq: Boolean; + c, cn: char; +begin + Result := ''; + if Value = '' then + Exit; + if Value = Quote + Quote then + Exit; + inq := False; + dq := False; + for n := 1 to Length(Value) do + begin + c := Value[n]; + if n <> Length(Value) then + cn := Value[n + 1] + else + cn := #0; + if c = quote then + if dq then + dq := False + else + if not inq then + inq := True + else + if cn = quote then + begin + Result := Result + Quote; + dq := True; + end + else + inq := False + else + Result := Result + c; + end; +end; + +{==============================================================================} + +function QuoteStr(const Value: string; Quote: Char): string; +var + n: integer; +begin + Result := ''; + for n := 1 to length(value) do + begin + Result := result + Value[n]; + if value[n] = Quote then + Result := Result + Quote; + end; + Result := Quote + Result + Quote; +end; + +{==============================================================================} + +procedure HeadersToList(const Value: TStrings); +var + n, x, y: integer; + s: string; +begin + for n := 0 to Value.Count -1 do + begin + s := Value[n]; + x := Pos(':', s); + if x > 0 then + begin + y:= Pos('=',s); + if not ((y > 0) and (y < x)) then + begin + s[x] := '='; + Value[n] := s; + end; + end; + end; +end; + +{==============================================================================} + +procedure ListToHeaders(const Value: TStrings); +var + n, x: integer; + s: string; +begin + for n := 0 to Value.Count -1 do + begin + s := Value[n]; + x := Pos('=', s); + if x > 0 then + begin + s[x] := ':'; + Value[n] := s; + end; + end; +end; + +{==============================================================================} + +function SwapBytes(Value: integer): integer; +var + s: AnsiString; + x, y, xl, yl: Byte; +begin + s := CodeLongInt(Value); + x := Ord(s[4]); + y := Ord(s[3]); + xl := Ord(s[2]); + yl := Ord(s[1]); + Result := ((x * 256 + y) * 65536) + (xl * 256 + yl); +end; + +{==============================================================================} + +function ReadStrFromStream(const Stream: TStream; len: integer): AnsiString; +var + x: integer; +{$IFDEF CIL} + buf: Array of Byte; +{$ENDIF} +begin +{$IFDEF CIL} + Setlength(buf, Len); + x := Stream.read(buf, Len); + SetLength(buf, x); + Result := StringOf(Buf); +{$ELSE} + Setlength(Result, Len); + x := Stream.read(PAnsiChar(Result)^, Len); + SetLength(Result, x); +{$ENDIF} +end; + +{==============================================================================} + +procedure WriteStrToStream(const Stream: TStream; Value: AnsiString); +{$IFDEF CIL} +var + buf: Array of Byte; +{$ENDIF} +begin +{$IFDEF CIL} + buf := BytesOf(Value); + Stream.Write(buf,length(Value)); +{$ELSE} + Stream.Write(PAnsiChar(Value)^, Length(Value)); +{$ENDIF} +end; + +{==============================================================================} +function GetTempFile(const Dir, prefix: AnsiString): AnsiString; +{$IFNDEF FPC} +{$IFDEF MSWINDOWS} +var + Path: AnsiString; + x: integer; +{$ENDIF} +{$ENDIF} +begin +{$IFDEF FPC} + Result := GetTempFileName(Dir, Prefix); +{$ELSE} + {$IFNDEF MSWINDOWS} + Result := tempnam(Pointer(Dir), Pointer(prefix)); + {$ELSE} + {$IFDEF CIL} + Result := System.IO.Path.GetTempFileName; + {$ELSE} + if Dir = '' then + begin + SetLength(Path, MAX_PATH); + x := GetTempPath(Length(Path), PChar(Path)); + SetLength(Path, x); + end + else + Path := Dir; + x := Length(Path); + if Path[x] <> '\' then + Path := Path + '\'; + SetLength(Result, MAX_PATH + 1); + GetTempFileName(PChar(Path), PChar(Prefix), 0, PChar(Result)); + Result := PChar(Result); + SetFileattributes(PChar(Result), GetFileAttributes(PChar(Result)) or FILE_ATTRIBUTE_TEMPORARY); + {$ENDIF} + {$ENDIF} +{$ENDIF} +end; + +{==============================================================================} + +function PadString(const Value: AnsiString; len: integer; Pad: AnsiChar): AnsiString; +begin + if length(value) >= len then + Result := Copy(value, 1, len) + else + Result := Value + StringOfChar(Pad, len - length(value)); +end; + +{==============================================================================} + +function XorString(Indata1, Indata2: AnsiString): AnsiString; +var + i: integer; +begin + Indata2 := PadString(Indata2, length(Indata1), #0); + Result := ''; + for i := 1 to length(Indata1) do + Result := Result + AnsiChar(ord(Indata1[i]) xor ord(Indata2[i])); +end; + +{==============================================================================} + +function NormalizeHeader(Value: TStrings; var Index: Integer): string; +var + s, t: string; + n: Integer; +begin + s := Value[Index]; + Inc(Index); + if s <> '' then + while (Value.Count - 1) > Index do + begin + t := Value[Index]; + if t = '' then + Break; + for n := 1 to Length(t) do + if t[n] = #9 then + t[n] := ' '; + if not(AnsiChar(t[1]) in [' ', '"', ':', '=']) then + Break + else + begin + s := s + ' ' + Trim(t); + Inc(Index); + end; + end; + Result := TrimRight(s); +end; + +{==============================================================================} + +{pf} +procedure SearchForLineBreak(var APtr:PANSIChar; AEtx:PANSIChar; out ABol:PANSIChar; out ALength:integer); +begin + ABol := APtr; + while (APtr<AEtx) and not (APtr^ in [#0,#10,#13]) do + inc(APtr); + ALength := APtr-ABol; +end; +{/pf} + +{pf} +procedure SkipLineBreak(var APtr:PANSIChar; AEtx:PANSIChar); +begin + if (APtr<AEtx) and (APtr^=#13) then + inc(APtr); + if (APtr<AEtx) and (APtr^=#10) then + inc(APtr); +end; +{/pf} + +{pf} +procedure SkipNullLines(var APtr:PANSIChar; AEtx:PANSIChar); +var + bol: PANSIChar; + lng: integer; +begin + while (APtr<AEtx) do + begin + SearchForLineBreak(APtr,AEtx,bol,lng); + SkipLineBreak(APtr,AEtx); + if lng>0 then + begin + APtr := bol; + Break; + end; + end; +end; +{/pf} + +{pf} +procedure CopyLinesFromStreamUntilNullLine(var APtr:PANSIChar; AEtx:PANSIChar; ALines:TStrings); +var + bol: PANSIChar; + lng: integer; + s: ANSIString; +begin + // Copying until body separator will be reached + while (APtr<AEtx) and (APtr^<>#0) do + begin + SearchForLineBreak(APtr,AEtx,bol,lng); + SkipLineBreak(APtr,AEtx); + if lng=0 then + Break; + SetString(s,bol,lng); + ALines.Add(s); + end; +end; +{/pf} + +{pf} +procedure CopyLinesFromStreamUntilBoundary(var APtr:PANSIChar; AEtx:PANSIChar; ALines:TStrings; const ABoundary:ANSIString); +var + bol: PANSIChar; + lng: integer; + s: ANSIString; + BackStop: ANSIString; + eob1: PANSIChar; + eob2: PANSIChar; +begin + BackStop := '--'+ABoundary; + eob2 := nil; + // Copying until Boundary will be reached + while (APtr<AEtx) do + begin + SearchForLineBreak(APtr,AEtx,bol,lng); + SkipLineBreak(APtr,AEtx); + eob1 := MatchBoundary(bol,APtr,ABoundary); + if Assigned(eob1) then + eob2 := MatchLastBoundary(bol,AEtx,ABoundary); + if Assigned(eob2) then + begin + APtr := eob2; + Break; + end + else if Assigned(eob1) then + begin + APtr := eob1; + Break; + end + else + begin + SetString(s,bol,lng); + ALines.Add(s); + end; + end; +end; +{/pf} + +{pf} +function SearchForBoundary(var APtr:PANSIChar; AEtx:PANSIChar; const ABoundary:ANSIString): PANSIChar; +var + eob: PANSIChar; + Step: integer; +begin + Result := nil; + // Moving Aptr position forward until boundary will be reached + while (APtr<AEtx) do + begin + if strlcomp(APtr,#13#10'--',4)=0 then + begin + eob := MatchBoundary(APtr,AEtx,ABoundary); + Step := 4; + end + else if strlcomp(APtr,'--',2)=0 then + begin + eob := MatchBoundary(APtr,AEtx,ABoundary); + Step := 2; + end + else + begin + eob := nil; + Step := 1; + end; + if Assigned(eob) then + begin + Result := APtr; // boundary beginning + APtr := eob; // boundary end + exit; + end + else + inc(APtr,Step); + end; +end; +{/pf} + +{pf} +function MatchBoundary(ABol,AEtx:PANSIChar; const ABoundary:ANSIString): PANSIChar; +var + MatchPos: PANSIChar; + Lng: integer; +begin + Result := nil; + MatchPos := ABol; + Lng := length(ABoundary); + if (MatchPos+2+Lng)>AETX then + exit; + if strlcomp(MatchPos,#13#10,2)=0 then + inc(MatchPos,2); + if (MatchPos+2+Lng)>AETX then + exit; + if strlcomp(MatchPos,'--',2)<>0 then + exit; + inc(MatchPos,2); + if strlcomp(MatchPos,PANSIChar(ABoundary),Lng)<>0 then + exit; + inc(MatchPos,Lng); + if ((MatchPos+2)<=AEtx) and (strlcomp(MatchPos,#13#10,2)=0) then + inc(MatchPos,2); + Result := MatchPos; +end; +{/pf} + +{pf} +function MatchLastBoundary(ABOL,AETX:PANSIChar; const ABoundary:ANSIString): PANSIChar; +var + MatchPos: PANSIChar; +begin + Result := nil; + MatchPos := MatchBoundary(ABOL,AETX,ABoundary); + if not Assigned(MatchPos) then + exit; + if strlcomp(MatchPos,'--',2)<>0 then + exit; + inc(MatchPos,2); + if (MatchPos+2<=AEtx) and (strlcomp(MatchPos,#13#10,2)=0) then + inc(MatchPos,2); + Result := MatchPos; +end; +{/pf} + +{pf} +function BuildStringFromBuffer(AStx,AEtx:PANSIChar): ANSIString; +var + lng: integer; +begin + Lng := 0; + if Assigned(AStx) and Assigned(AEtx) then + begin + Lng := AEtx-AStx; + if Lng<0 then + Lng := 0; + end; + SetString(Result,AStx,lng); +end; +{/pf} + + + + +{==============================================================================} +var + n: integer; +begin + for n := 1 to 12 do + begin + CustomMonthNames[n] := ShortMonthNames[n]; + MyMonthNames[0, n] := ShortMonthNames[n]; + end; +end. diff --git a/synapse/synsock.pas b/synapse/synsock.pas new file mode 100644 index 0000000..8ed9e5b --- /dev/null +++ b/synapse/synsock.pas @@ -0,0 +1,77 @@ +{==============================================================================| +| Project : Ararat Synapse | 005.002.001 | +|==============================================================================| +| Content: Socket Independent Platform Layer | +|==============================================================================| +| 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)2001-2011. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +{:@exclude} + +unit synsock; + +{$MINENUMSIZE 4} + +//old Delphi does not have MSWINDOWS define. +{$IFDEF WIN32} + {$IFNDEF MSWINDOWS} + {$DEFINE MSWINDOWS} + {$ENDIF} +{$ENDIF} + +{$IFDEF CIL} + {$I ssdotnet.inc} +{$ELSE} + {$IFDEF MSWINDOWS} + {$I sswin32.inc} + {$ELSE} + {$IFDEF WINCE} + {$I sswin32.inc} //not complete yet! + {$ELSE} + {$IFDEF FPC} + {$I ssfpc.inc} + {$ELSE} + {$I sslinux.inc} + {$ENDIF} + {$ENDIF} + {$ENDIF} +{$ENDIF} + +end. + diff --git a/synapse/tlntsend.pas b/synapse/tlntsend.pas new file mode 100644 index 0000000..557266c --- /dev/null +++ b/synapse/tlntsend.pas @@ -0,0 +1,364 @@ +{==============================================================================| +| Project : Ararat Synapse | 001.003.001 | +|==============================================================================| +| Content: TELNET and SSH2 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)2002-2010. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +{:@abstract(Telnet script client) + +Used RFC: RFC-854 +} + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$H+} + +{$IFDEF UNICODE} + {$WARN IMPLICIT_STRING_CAST OFF} + {$WARN IMPLICIT_STRING_CAST_LOSS OFF} +{$ENDIF} + +unit tlntsend; + +interface + +uses + SysUtils, Classes, + blcksock, synautil; + +const + cTelnetProtocol = '23'; + cSSHProtocol = '22'; + + TLNT_EOR = #239; + TLNT_SE = #240; + TLNT_NOP = #241; + TLNT_DATA_MARK = #242; + TLNT_BREAK = #243; + TLNT_IP = #244; + TLNT_AO = #245; + TLNT_AYT = #246; + TLNT_EC = #247; + TLNT_EL = #248; + TLNT_GA = #249; + TLNT_SB = #250; + TLNT_WILL = #251; + TLNT_WONT = #252; + TLNT_DO = #253; + TLNT_DONT = #254; + TLNT_IAC = #255; + +type + {:@abstract(State of telnet protocol). Used internaly by TTelnetSend.} + TTelnetState =(tsDATA, tsIAC, tsIAC_SB, tsIAC_WILL, tsIAC_DO, tsIAC_WONT, + tsIAC_DONT, tsIAC_SBIAC, tsIAC_SBDATA, tsSBDATA_IAC); + + {:@abstract(Class with implementation of Telnet/SSH script client.) + + Note: Are you missing properties for specify server address and port? Look to + parent @link(TSynaClient) too!} + TTelnetSend = class(TSynaClient) + private + FSock: TTCPBlockSocket; + FBuffer: Ansistring; + FState: TTelnetState; + FSessionLog: Ansistring; + FSubNeg: Ansistring; + FSubType: Ansichar; + FTermType: Ansistring; + function Connect: Boolean; + function Negotiate(const Buf: Ansistring): Ansistring; + procedure FilterHook(Sender: TObject; var Value: AnsiString); + public + constructor Create; + destructor Destroy; override; + + {:Connects to Telnet server.} + function Login: Boolean; + + {:Connects to SSH2 server and login by Username and Password properties. + + You must use some of SSL plugins with SSH support. For exammple CryptLib.} + function SSHLogin: Boolean; + + {:Logout from telnet server.} + procedure Logout; + + {:Send this data to telnet server.} + procedure Send(const Value: string); + + {:Reading data from telnet server until Value is readed. If it is not readed + until timeout, result is @false. Otherwise result is @true.} + function WaitFor(const Value: string): Boolean; + + {:Read data terminated by terminator from telnet server.} + function RecvTerminated(const Terminator: string): string; + + {:Read string from telnet server.} + function RecvString: string; + published + {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.} + property Sock: TTCPBlockSocket read FSock; + + {:all readed datas in this session (from connect) is stored in this large + string.} + property SessionLog: Ansistring read FSessionLog write FSessionLog; + + {:Terminal type indentification. By default is 'SYNAPSE'.} + property TermType: Ansistring read FTermType write FTermType; + end; + +implementation + +constructor TTelnetSend.Create; +begin + inherited Create; + FSock := TTCPBlockSocket.Create; + FSock.Owner := self; + FSock.OnReadFilter := FilterHook; + FTimeout := 60000; + FTargetPort := cTelnetProtocol; + FSubNeg := ''; + FSubType := #0; + FTermType := 'SYNAPSE'; +end; + +destructor TTelnetSend.Destroy; +begin + FSock.Free; + inherited Destroy; +end; + +function TTelnetSend.Connect: Boolean; +begin + // Do not call this function! It is calling by LOGIN method! + FBuffer := ''; + FSessionLog := ''; + FState := tsDATA; + FSock.CloseSocket; + FSock.LineBuffer := ''; + FSock.Bind(FIPInterface, cAnyPort); + FSock.Connect(FTargetHost, FTargetPort); + Result := FSock.LastError = 0; +end; + +function TTelnetSend.RecvTerminated(const Terminator: string): string; +begin + Result := FSock.RecvTerminated(FTimeout, Terminator); +end; + +function TTelnetSend.RecvString: string; +begin + Result := FSock.RecvTerminated(FTimeout, CRLF); +end; + +function TTelnetSend.WaitFor(const Value: string): Boolean; +begin + Result := FSock.RecvTerminated(FTimeout, Value) <> ''; +end; + +procedure TTelnetSend.FilterHook(Sender: TObject; var Value: AnsiString); +begin + Value := Negotiate(Value); + FSessionLog := FSessionLog + Value; +end; + +function TTelnetSend.Negotiate(const Buf: Ansistring): Ansistring; +var + n: integer; + c: Ansichar; + Reply: Ansistring; + SubReply: Ansistring; +begin + Result := ''; + for n := 1 to Length(Buf) do + begin + c := Buf[n]; + Reply := ''; + case FState of + tsData: + if c = TLNT_IAC then + FState := tsIAC + else + Result := Result + c; + + tsIAC: + case c of + TLNT_IAC: + begin + FState := tsData; + Result := Result + TLNT_IAC; + end; + TLNT_WILL: + FState := tsIAC_WILL; + TLNT_WONT: + FState := tsIAC_WONT; + TLNT_DONT: + FState := tsIAC_DONT; + TLNT_DO: + FState := tsIAC_DO; + TLNT_EOR: + FState := tsDATA; + TLNT_SB: + begin + FState := tsIAC_SB; + FSubType := #0; + FSubNeg := ''; + end; + else + FState := tsData; + end; + + tsIAC_WILL: + begin + case c of + #3: //suppress GA + Reply := TLNT_DO; + else + Reply := TLNT_DONT; + end; + FState := tsData; + end; + + tsIAC_WONT: + begin + Reply := TLNT_DONT; + FState := tsData; + end; + + tsIAC_DO: + begin + case c of + #24: //termtype + Reply := TLNT_WILL; + else + Reply := TLNT_WONT; + end; + FState := tsData; + end; + + tsIAC_DONT: + begin + Reply := TLNT_WONT; + FState := tsData; + end; + + tsIAC_SB: + begin + FSubType := c; + FState := tsIAC_SBDATA; + end; + + tsIAC_SBDATA: + begin + if c = TLNT_IAC then + FState := tsSBDATA_IAC + else + FSubNeg := FSubNeg + c; + end; + + tsSBDATA_IAC: + case c of + TLNT_IAC: + begin + FState := tsIAC_SBDATA; + FSubNeg := FSubNeg + c; + end; + TLNT_SE: + begin + SubReply := ''; + case FSubType of + #24: //termtype + begin + if (FSubNeg <> '') and (FSubNeg[1] = #1) then + SubReply := #0 + FTermType; + end; + end; + Sock.SendString(TLNT_IAC + TLNT_SB + FSubType + SubReply + TLNT_IAC + TLNT_SE); + FState := tsDATA; + end; + else + FState := tsDATA; + end; + + else + FState := tsData; + end; + if Reply <> '' then + Sock.SendString(TLNT_IAC + Reply + c); + end; + +end; + +procedure TTelnetSend.Send(const Value: string); +begin + Sock.SendString(ReplaceString(Value, TLNT_IAC, TLNT_IAC + TLNT_IAC)); +end; + +function TTelnetSend.Login: Boolean; +begin + Result := False; + if not Connect then + Exit; + Result := True; +end; + +function TTelnetSend.SSHLogin: Boolean; +begin + Result := False; + if Connect then + begin + FSock.SSL.SSLType := LT_SSHv2; + FSock.SSL.Username := FUsername; + FSock.SSL.Password := FPassword; + FSock.SSLDoConnect; + Result := FSock.LastError = 0; + end; +end; + +procedure TTelnetSend.Logout; +begin + FSock.CloseSocket; +end; + + +end.