diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..f288702
--- /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/README.md b/README.md
index 0df2fea..d1a626b 100644
--- a/README.md
+++ b/README.md
@@ -1,3 +1,17 @@
-
Cross Codebot
+# Codebot Cross Platform Library
-This is the Cross Codebot repository.
+This is the official git repository for the Codebot Cross library. It contains the source and assets code for three Free Pascal packges.
+
+The official landing page for the library with detailed information, including installation, documentation, and examples about this library is [located here](https://cross.codebot.org).
+
+## Package Codebot
+
+The Codebot package defines types and routines for general purpose use. These include items such as string and file system handling, collections, advanced graphics contexts, networks sockets, animation, and much more.
+
+## Package Codebot Control
+
+The Codebot Controls package defines classs and routines related to visual controls. Many of these controls are original, unique, and all make use of the advanced ISurface cross platform drawing context provided by the Codebot package. Some of the controls in this pake include TContentGrid, TIndeterminateProgress, THuePicker and more. Custom forms and custom IDE designers are also included in this package.
+
+## Package Codebot Rendering
+
+The Codebot Rendering package provides a organzied and easy to use class library for working with OpenGL ES, shader programming, vertex, render, and pixels buffers, as well as input processing.
diff --git a/assets/shaders/colorvertexbuffer b/assets/shaders/colorvertexbuffer
new file mode 100644
index 0000000..58cd2ef
--- /dev/null
+++ b/assets/shaders/colorvertexbuffer
@@ -0,0 +1,12 @@
+uniform mat4 projection;
+uniform mat4 modelview;
+
+attribute vec3 xyz;
+attribute vec2 uv;
+
+varying vec2 coord;
+
+void main() {
+ coord = uv;
+ gl_Position = vec4(projection * modelview * xyz, 1.0);
+}
diff --git a/assets/shaders/colorvertexbuffer.frag b/assets/shaders/colorvertexbuffer.frag
new file mode 100644
index 0000000..a1ccf9e
--- /dev/null
+++ b/assets/shaders/colorvertexbuffer.frag
@@ -0,0 +1,5 @@
+varying vec4 color;
+
+void main() {
+ gl_FragColor = color;
+}
diff --git a/assets/shaders/colorvertexbuffer.vert b/assets/shaders/colorvertexbuffer.vert
new file mode 100644
index 0000000..6aa7804
--- /dev/null
+++ b/assets/shaders/colorvertexbuffer.vert
@@ -0,0 +1,12 @@
+uniform mat4 projection;
+uniform mat4 modelview;
+
+attribute vec3 xyz;
+attribute vec4 rgba;
+
+varying vec4 color;
+
+void main() {
+ color = rgba;
+ gl_Position = projection * modelview * vec4(xyz, 1.0);
+}
diff --git a/assets/shaders/texvertexbuffer b/assets/shaders/texvertexbuffer
new file mode 100644
index 0000000..58cd2ef
--- /dev/null
+++ b/assets/shaders/texvertexbuffer
@@ -0,0 +1,12 @@
+uniform mat4 projection;
+uniform mat4 modelview;
+
+attribute vec3 xyz;
+attribute vec2 uv;
+
+varying vec2 coord;
+
+void main() {
+ coord = uv;
+ gl_Position = vec4(projection * modelview * xyz, 1.0);
+}
diff --git a/assets/shaders/texvertexbuffer.frag b/assets/shaders/texvertexbuffer.frag
new file mode 100644
index 0000000..a311b2e
--- /dev/null
+++ b/assets/shaders/texvertexbuffer.frag
@@ -0,0 +1,7 @@
+uniform sampler2D tex;
+
+varying vec2 coord;
+
+void main() {
+ gl_FragColor = texture2D(tex, coord);
+}
diff --git a/assets/shaders/texvertexbuffer.vert b/assets/shaders/texvertexbuffer.vert
new file mode 100644
index 0000000..350b5a2
--- /dev/null
+++ b/assets/shaders/texvertexbuffer.vert
@@ -0,0 +1,12 @@
+uniform mat4 projection;
+uniform mat4 modelview;
+
+attribute vec3 xyz;
+attribute vec2 uv;
+
+varying vec2 coord;
+
+void main() {
+ coord = uv;
+ gl_Position = projection * modelview * vec4(xyz, 1.0);
+}
diff --git a/assets/textures/grimnight.jpg b/assets/textures/grimnight.jpg
new file mode 100644
index 0000000..eadac55
Binary files /dev/null and b/assets/textures/grimnight.jpg differ
diff --git a/assets/textures/interstellar.jpg b/assets/textures/interstellar.jpg
new file mode 100644
index 0000000..20da72c
Binary files /dev/null and b/assets/textures/interstellar.jpg differ
diff --git a/assets/textures/orangesky.jpg b/assets/textures/orangesky.jpg
new file mode 100644
index 0000000..d16db1d
Binary files /dev/null and b/assets/textures/orangesky.jpg differ
diff --git a/assets/textures/skybox.jpg b/assets/textures/skybox.jpg
new file mode 100644
index 0000000..db6ac5b
Binary files /dev/null and b/assets/textures/skybox.jpg differ
diff --git a/assets/textures/violentdays.jpg b/assets/textures/violentdays.jpg
new file mode 100644
index 0000000..d73f9d2
Binary files /dev/null and b/assets/textures/violentdays.jpg differ
diff --git a/examples/clock/clock.lpi b/examples/clock/clock.lpi
index a96dbd0..e628800 100644
--- a/examples/clock/clock.lpi
+++ b/examples/clock/clock.lpi
@@ -1,30 +1,54 @@
-
+
+
+
+
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
-
+
+
+
+
@@ -42,7 +66,7 @@
-
+
diff --git a/examples/clock/clock.lpr b/examples/clock/clock.lpr
index d9b11cc..36b898d 100644
--- a/examples/clock/clock.lpr
+++ b/examples/clock/clock.lpr
@@ -15,7 +15,7 @@
begin
RequireDerivedFormResource := True;
Application.Initialize;
- Application.CreateForm(TForm1, Form1);
+ Application.CreateForm(TClockWidget, ClockWidget);
Application.Run;
end.
diff --git a/examples/clock/clock.lps b/examples/clock/clock.lps
index d2624ae..f45b6f1 100644
--- a/examples/clock/clock.lps
+++ b/examples/clock/clock.lps
@@ -1,9 +1,9 @@
-
+
-
+
@@ -11,19 +11,19 @@
-
+
-
+
-
-
-
+
+
+
@@ -36,10 +36,12 @@
-
-
-
-
+
+
+
+
+
+
@@ -57,74 +59,171 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
+
-
+
+
-
+
-
+
-
+
-
+
-
-
+
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/examples/clock/clock.res b/examples/clock/clock.res
index e1df0e9..0ad004b 100644
Binary files a/examples/clock/clock.res and b/examples/clock/clock.res differ
diff --git a/examples/clock/main.lfm b/examples/clock/main.lfm
index a19a912..b52c8f5 100644
--- a/examples/clock/main.lfm
+++ b/examples/clock/main.lfm
@@ -1,24 +1,84 @@
-object Form1: TForm1
- Left = 489
- Height = 45
- Top = 402
- Width = 216
- Caption = 'Form1'
- ClientHeight = 45
- ClientWidth = 216
- OnCloseQuery = FormCloseQuery
- OnShow = FormShow
- LCLVersion = '1.5'
- object ScaleBar: TSlideBar
- Left = 8
- Height = 26
- Top = 8
- Width = 200
- Kind = sbHorizontal
- Max = 2
- Min = 0.5
- Position = 1
- Step = 0.25
- OnChange = ScaleBarChange
+object ClockWidget: TClockWidget
+ Left = 750
+ Height = 234
+ Top = 375
+ Width = 278
+ ClientHeight = 234
+ ClientWidth = 278
+ OnClick = FormClick
+ OnCreate = FormCreate
+ object CloseButton: TThinButton
+ Left = 242
+ Height = 32
+ Top = 3
+ Width = 32
+ Anchors = [akTop, akRight]
+ Caption = 'CloseButton'
+ Down = False
+ Images = Images
+ ImageIndex = 0
+ OnClick = CloseButtonClick
+ end
+ object Images: TImageStrip
+ Left = 208
+ Top = 79
+ Data = {
+ 89504E470D0A1A0A0000000D4948445200000020000000200806000000737A7A
+ F40000000473424954080808087C086488000006AE49444154588595574D681C
+ C9157EAF7EBAA77F661AADE2F54F82C82CB2E3350932269215899043ACC81092
+ 4B40E8A09C65B4189F968D65C8C197F8A4B0160474307220D8302043D81C0216
+ 098EE510708C03BB64054644169664AFB35ECDAE35A3D14CD597837A46DD3DE3
+ D8FBA098E9EA57EFFBFA7BEF757531BDB971E2973373C8FCDAAF1BF4753E4C44
+ 8288643C04338B240100360636F1B03121B445FC1A04443C34336BADB5144238
+ D6DA2E000700E49819CCFC9552EA3300957ABDDE30C6D401D489A81E1379A522
+ FF8F802422C5CCAEE7799A880ED46AB51F03F801801E222A10911B07AF30F3E7
+ CCFCA952EAAF8EE37C5CABD5AA8D46A362ADAD115123A1C86B8D63704F29D51D
+ 86615129F53E33FF9B88CAB42F6BA75123A2E752CA8FC2301C0982A0A8943A40
+ 445E1CF34D524E92887CADF5DB9EE79D1642FC89D2F97CD3B1EDBAEE078542E1
+ B8D6FA2011F99D48C80EE08ED63A2FA53C5EABD56601FC28B9C8F33C8AA2888E
+ 1D3B46A74E9DA29E9E1E32C690B5B63562D3C69833C618E1FBFEA7D6DA86B5B6
+ 998A8E2688C8554A75E772B9D3CCFC20F944F97C1E23232328954AD8D9D941D6
+ 969797313D3D8DDEDEDEAC12466BFD613E9FFFAE52EA1BB45737220BCE44A488
+ A81086613196BD15A4582C627E7EBE0DB493ADAEAE62626222458299B772B9DC
+ 852008DE61E6888874361582883CDFF7BB9552EF27735E2C1671F7EE5DACADAD
+ 61616101E572F995E00F1F3EC4D2D212B6B6B6303535952221A5FC47100467B4
+ D64768AF285B2A30EDB55BC1F7FDE371B5B7649F9F9FC7DADA1A4E9E3C89288A
+ D0DFDF8FCDCDCD36F01B376EA050282097CB616E6E0ED56A154343432912B95C
+ EE579EE71D27A228569C9B045CC771BAA494EF51A2D546464600000B0B0B88A2
+ A815687070101B1B1B2DF052A994021A1F1F47A552C1CACA4A6A5E29F5972008
+ 8699F940B2160411F99EE71D1442FCA1E9EC791E4AA51200A05C2EA3BFBF3F15
+ 6C7474141B1B1BB879F366566A944A251863608CC1D8D858B216B60B85C2CF94
+ 523DB4D7968268AFF542C7718E33F3DF9ACEDDDDDDA96ADFDCDCC4E0E0600A6C
+ 606000CCDCBAF67D1FB3B3B3B0D60200ACB5B875EB566A4D1886E75CD7ED25A2
+ 30C6DECBBFD6FA87CCFCAFA6635F5F5F5B9E373636303A3ADAF1C5E3791EAE5E
+ BDDAB13D337E573CCF7BB759078288889919402ECE0B11111D397224DBAA74F8
+ F0619A9F9FA7818181B67B172F5EA4F3E7CFB7CD6BADC9F7FDD6B5B5362F8468
+ BD11F75B614FCAD65BAA56ABB5052322BA73E70EDDBF7FBF6D7E6161819E3D7B
+ D6360F807677775BD7CC6C0024BF29483273E438CE6966BE4FB1543D3D3D6D72
+ 66AB3D3B868787B1BEBE9E5AF3E0C183948FEFFBBF4EA680282E42DFF78B4288
+ 3F371DF3F93C9697975B81AE5FBFDE96F3CB972FA3AFAF2F357FE6CC193C7EFC
+ B8558457AE5C49DD8FA2E897AEEB1E25A27C8CBDDF8652CADFD2DE960AA514A6
+ A7A70100F7EEDD83E779A96A6F16DCD3A74F313C3C9C02B970E10276767650AD
+ 5671F4E8D1648BAE160A859F4A29536DD8DA845CD7FD39113D6F2EE8EDEDC5EA
+ EA2A9696965A04A494989D9D4DC9BCBEBE8EB367CFB680262727010033333329
+ 62AEEBFE3E0CC341667E9B889C641D28662EE4F3F9A294F2A3E4A289890994CB
+ 65CCCDCD617C7C1CA552A9D5E75912972E5DC2E4E4249E3C7982C5C5458461D8
+ 8A2384781186E1A4E779DF49E6BF6982883CC7710E8561384244DB4912535353
+ A856ABA8542A30C6B481376D77771700B0B8B88843870EA59EDE719C9B51140D
+ 29A50E536633224A6C484110145DD7FD205BE14343435859598131A6A302D65A
+ 54AB55CCCCCCA49E3C4EDB275114FDC2F7FDDE783B4E6D444915B494B2100441
+ 77A55239DF6834CE65998E8D8DD1F8F8389D387182B4D60480CAE532DDBE7D9B
+ AE5DBB468F1E3D4ABA9310622D0882DF0821EEBC7CF9F2B931E6655CE814134C
+ 9924224F6B7D308AA2EF69AD3F64E6ADAC1ACDE1FB3E9452AF7C2F48293FC9E7
+ F3E7BABABADE8DBF0B9BD27312306BD65A6B003472B9DC3211AD12D15B00BE95
+ 75ACD7EBC96FC0E4537FA1B5FE631004BF63E67F6E6F6FBFA8D7EB5FD1DE39C1
+ 247D3B7D26374F418E522A705DB74044EF1863BEDF68347E628C390DC0EFB08E
+ A4948F955277B4D67F97527E5CAFD73FABD56A5BC6986D22DAA50E6783577DA7
+ 37492866CE29A502A5544108D12D84780BC0378D31DFB6D6E699D90821FEABB5
+ FE0F8017D6DACF8D315FD4EBF52F8D311500B5047847A0575973C390B457B50E
+ 333B524A4F4AE930B36EEE6A001AD6DA46A3D1A8596B7712A049C9DB0AEE7504
+ B244528753DA3F6430ED9FFF0CED1FC3927277047F53025922D9FF49806417BC
+ 91FD0F7C1582302F59C1650000000049454E44AE426082
+ }
end
end
diff --git a/examples/clock/main.pas b/examples/clock/main.pas
index 1c88183..14f6626 100644
--- a/examples/clock/main.pas
+++ b/examples/clock/main.pas
@@ -5,38 +5,43 @@
interface
uses
- Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs,
+ Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, LCLIntf,
+ LCLType, Buttons,
Codebot.System,
Codebot.Graphics,
Codebot.Graphics.Types,
Codebot.Geometry,
- Codebot.Controls.Scrolling,
- Codebot.Controls.Sliders,
- Codebot.Animation;
+ Codebot.Forms.Widget,
+ Codebot.Animation,
+ Codebot.Controls.Buttons;
-{ TForm1 }
+{ TClockWidget }
type
- TForm1 = class(TForm)
- ScaleBar: TSlideBar;
- procedure FormCloseQuery(Sender: TObject; var CanClose: boolean);
- procedure FormShow(Sender: TObject);
- procedure ScaleBarChange(Sender: TObject);
+ TClockWidget = class(TWidget)
+ Images: TImageStrip;
+ CloseButton: TThinButton;
+ procedure FormClick(Sender: TObject);
+ procedure FormCreate(Sender: TObject);
+ procedure CloseButtonClick(Sender: TObject);
private
- FSplash: ISplash;
- FClock: IBitmap;
- FTimer: TAnimationTimer;
- procedure Tick(Sender: TObject);
+ procedure ClockTick(Sender: TObject);
+ protected
+ FBitmap: IBitmap;
+ FClose: IBitmap;
+ FMoused: Boolean;
+ FMouseOpacity: Float;
+ procedure Render; override;
end;
var
- Form1: TForm1;
+ ClockWidget: TClockWidget;
implementation
{$R *.lfm}
-{ TForm1 }
+{ TClockWidget }
{ Since we are using vector graphics, we can scale the widget
size using a scaling factor }
@@ -46,10 +51,6 @@ implementation
{ For our example Size always equals Round(Factor * 256) }
Size: Integer;
- { Offsets when moving }
- OffsetX: Integer = 10;
- OffsetY: Integer = 30;
-
procedure DrawClock(Bitmap: IBitmap);
const
{ Define our colors }
@@ -279,7 +280,7 @@ procedure DrawClock(Bitmap: IBitmap);
{ Draw a light reflection above and below the center of the clock face }
- procedure DrawLens(Surface: iSurface);
+ procedure DrawLens(Surface: ISurface);
var
R: TRectF;
C: TColorB;
@@ -329,8 +330,6 @@ procedure DrawClock(Bitmap: IBitmap);
C: TColorB;
G: IGradientBrush;
begin
- { If the scale factor was changed, make the bitmap match }
- Bitmap.SetSize(Size, Size);
Surface := Bitmap.Surface;
{ Erase the last clock }
Surface.Clear(clTransparent);
@@ -401,51 +400,113 @@ procedure DrawClock(Bitmap: IBitmap);
DrawLens(Surface);
end;
-procedure TForm1.FormShow(Sender: TObject);
+procedure TClockWidget.FormClick(Sender: TObject);
+var
+ P: TPointI;
begin
- Sleep(100);
- OnShow := nil;
- { Default the factor to 1 }
- Factor := 1;
- { And Size to 256 * Factor }
- Size := Round(256 * Factor);
- { Here is our widget }
- FSplash := NewSplash;
- { Here is the bitmap which defines the widget size and pixels }
- FClock := FSplash.Bitmap;
- { Draw the clock }
- DrawClock(FClock);
- { Move it to the top right of the screen }
- FSplash.Move(Screen.Width - Size - OffsetX, OffsetY);
- { Show it }
- FSplash.Visible := True;
- { Start a timer to redraw the clock synched with the pc
- refresh rate }
- FTimer := TAnimationTimer.Create(Self);
- FTimer.OnTimer := Tick;
- FTimer.Enabled := True;
+ {P := Mouse.CursorPos;
+ P.Offset(-Left, -Top);
+ if (P.Y < FClose.Height) and (P.X > Width - FClose.Width) then
+ Close;}
end;
-procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: boolean);
+procedure TClockWidget.FormCreate(Sender: TObject);
+var
+ Stream: TStream;
begin
- FTimer.Enabled := False;
+ EdgeSizable := [esNW, esSE, esSW];
+ Width := 220;
+ Height := Width;
+ AspectRatio := 1;
+ OnTick := ClockTick;
+ FBitmap := NewBitmap(Size, Size);
+ {FClose := NewBitmap;
+ Stream := TResourceStream.Create(HInstance, 'CLOSE', RT_RCDATA);
+ try
+ // FClose.LoadFromStream(Stream);
+ finally
+ Stream.Free;
+ end;}
end;
-procedure TForm1.Tick(Sender: TObject);
+procedure TClockWidget.ClockTick(Sender: TObject);
+begin
+ if not Dragged then
+ Invalidate
+ else if Sized then
+ Invalidate;
+end;
+
+procedure TClockWidget.Render;
+var
+ PriorMoused: Boolean;
+ Alpha: Float;
+ P: TPointI;
+ B: IGradientBrush;
+ R: TRectI;
begin
- { At the screen refresh rate interval, draw a new clock }
- DrawClock(FClock);
- { And update the widget }
- FSplash.Update;
+ R := BoundsRect;
+ P := Mouse.CursorPos;
+ PriorMoused := FMoused;
+ FMoused := R.Contains(P);
+ if FMoused <> PriorMoused then
+ if FMoused then
+ Animator.Animate(FMouseOpacity, 1)
+ else
+ Animator.Animate(FMouseOpacity, 0);
+ Alpha := FMouseOpacity;
+ if Sized then
+ begin
+ R := ClientRect;
+ B := NewBrush(R.TopLeft, R.BottomLeft);
+ B.AddStop(Rgba(clHighlight, 0.3), 0);
+ B.AddStop(Rgba(clHighlight, 0.2), 0.66);
+ B.AddStop(Rgba(clHighlight, 0.1), 1);
+ Surface.FillRect(B ,R);
+ {R := FClose.ClientRect;
+ R.X := Width - R.Width - 4;
+ R.Y := 4;
+ FClose.Surface.CopyTo(FClose.ClientRect, Surface, R, $FF);}
+ end
+ else if FMoused or Animator.Animated then
+ begin
+ R := ClientRect;
+ B := NewBrush(R.TopLeft, R.BottomLeft);
+ B.AddStop(TColorB($A7B2B6).Fade(Alpha), 0);
+ B.AddStop(TColorB($D8E9EC).Fade(Alpha), 0.4);
+ B.AddStop(TColorB($A7B2B6).Fade(Alpha), 1);
+ Surface.RoundRectangle(R, 8);
+ Surface.Fill(B, True);
+ Surface.Stroke(NewPen(TColorB($9D9E9E).Fade(Alpha), 1));
+ CloseButton.Visible := True;
+ end;
+ if Sized then
+ begin
+ R := ClientRect;
+ R.Inflate(-4, -4);
+ Surface.Ellipse(R);
+ Surface.Fill(NewBrush(Rgba(clHighlight, 0.5)), True);
+ end
+ else
+ begin
+ Size := Width;
+ Factor := Width / 256;
+ FBitmap.SetSize(Size, Size);
+ DrawClock(FBitmap);
+ FBitmap.Surface.CopyTo(FBitmap.ClientRect, Surface, FBitmap.ClientRect);
+ R := CloseButton.ClientRect;
+ R.X := Width - R.Width - 4;
+ R.Y := 4;
+ if Alpha = 0 then
+ CloseButton.Visible := False
+ else
+ CloseButton.Visible := True;
+ end;
end;
-procedure TForm1.ScaleBarChange(Sender: TObject);
+procedure TClockWidget.CloseButtonClick(Sender: TObject);
begin
- { Scale the clock using a slider }
- Factor := ScaleBar.Position;
- Size := Round(256 * Factor);
- { And reposition it }
- FSplash.Move(Screen.Width - Size - OffsetX, OffsetY);
+ Close;
end;
end.
diff --git a/examples/hilite/hilite.lpi b/examples/hilite/hilite.lpi
deleted file mode 100644
index c886005..0000000
--- a/examples/hilite/hilite.lpi
+++ /dev/null
@@ -1,301 +0,0 @@
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
diff --git a/examples/hilite/hilite.lpr b/examples/hilite/hilite.lpr
deleted file mode 100644
index 058fae5..0000000
--- a/examples/hilite/hilite.lpr
+++ /dev/null
@@ -1,21 +0,0 @@
- program hilite;
-
-{$mode delphi}
-
-uses
- {$IFDEF UNIX}{$IFDEF UseCThreads}
- cthreads,
- {$ENDIF}{$ENDIF}
- Interfaces, // this includes the LCL widgetset
- Forms, Main
- { you can add units after this };
-
-{$R *.res}
-
-begin
- RequireDerivedFormResource := True;
- Application.Initialize;
- Application.CreateForm(THighlightForm, HighlightForm);
- Application.Run;
-end.
-
diff --git a/examples/hilite/hilite.lps b/examples/hilite/hilite.lps
deleted file mode 100644
index a9c2af5..0000000
--- a/examples/hilite/hilite.lps
+++ /dev/null
@@ -1,207 +0,0 @@
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
diff --git a/examples/hilite/hilite.res b/examples/hilite/hilite.res
deleted file mode 100644
index e1df0e9..0000000
Binary files a/examples/hilite/hilite.res and /dev/null differ
diff --git a/examples/hilite/main.lfm b/examples/hilite/main.lfm
deleted file mode 100644
index 30e482a..0000000
--- a/examples/hilite/main.lfm
+++ /dev/null
@@ -1,275 +0,0 @@
-object HighlightForm: THighlightForm
- Left = 228
- Height = 411
- Top = 110
- Width = 654
- Caption = 'Demo'
- ClientHeight = 411
- ClientWidth = 654
- OnCreate = FormCreate
- Position = poDesktopCenter
- LCLVersion = '1.5'
- Options = [boReanchor, boBannerShadow, boFooterShadow, boFooterGrip]
- Logo.Data = {
- 89504E470D0A1A0A0000000D4948445200000040000000400806000000AA6971
- DE0000000473424954080808087C0864880000069F49444154789CED9BBB6F1B
- D91587BF73EFBC380F92222959B2BDAEDC05768C0502D7298318C8A670933A48
- 99FF23F90F52A549B569923A85AB0DA02DE30041D419D63A80654994F8E6CCDC
- 9362289B92B9F6C26B48A4C4AFE10CE7CEC53D3F9ED710778415274D48D39434
- 0C09AD110B503A2D271326FD3EFDFE80FE87EE97CB59E6E7A7D9A0D9694B27CB
- C89258922892C85A2A014ACAF158C783A10E7A3D7A6F0EF54DF784EEA279BCCB
- 5DF68FC7F3F06EEF707BB3239BAD0DD36AD4A591A6924691449EADEC294A8AF1
- 58C7FDBEF64F4EF5A4D1708D83377AF0EA7FBC2A0A8A73F35D8D199F4610107C
- 7147BED8D9969DAD4DB3D5E998CE46D36C64A9C96A35A9F9BEF80079AEF968A4
- A35EDFF58EBBEE384B25AB45AEE67BEABFFC4E5F4EA74CCFE61480388E5B4F9F
- 3EFDD383070F7E2D52C5D1B221A2D4B363B2E49424E991D486C4B511513421F4
- A7787E81B50E80B23414B9C7240F188F4386A31A8351CC609071DAAF97DFFC73
- FF6F5F7FFDD7DF0D87C3230FE0F1E3C7BF7DF4E8D1574F9E3CB1B55AED4A0DFD
- 3E8C1CE099EFB0E615D6BCC69A438C1C61CD292260C4815402A006A701AA09A5
- ABE3B445E9DA946E8BE1A86D9D0B7FF5E2C5E36F9F3D7BF6470FE0EEDDBB5F3E
- 7CF8D0BB7FFF3EFF7D71C0645A7C682D978EC884D07609BC2E81EDE2DB2E3E87
- F8DE11C80922A012230400A84C1186282354728A52C94B8B4AC4DDBB77F8E9C3
- 3BDEEEB7B77FF6ECD95C0E30C600F0FB3FFCFD6AACFC00EDFA093BED37ECB48F
- D86975B9D53A656BA3C766734018648869634C1D24AA6ED031CE9DA2EE90C974
- 9F83EE31AF8F5FF3FAF825BFF9E50E4130248D27012C4882591C5EAE753F804E
- 43E9341CAD7AC94696B3914D69D527846186B5DB18B385312DC4C400A81BE2DC
- 11CEF98402ADFA88BC08C98B1CB48767478461EE8920EF09902E99009E2D6866
- 504F957AECC892922CCE49A2026B9B18DBC1981D8CB78D481D00D553A4081171
- 086392A84716E78C260530C4980941505ADFC75F204070D9367E90D077648990
- D620A929715812850E636344528CA944B0F636C66C02E0DC0168010C50D7C5D8
- 982874C491039D60A4C0F39C097C82A5F7805A3825A959E2C8100686C037F89E
- C3488831212211C6248834117B0F00D11C630E5117614C081AE07B137C5F0087
- 88C30812040B04A827CB2540E81724514014F884BE87672D460C225AB9B89420
- 2550800E667715202522E56C8C62C4E05BCB59F7AF542DF3D27B8067210C237C
- 3FC27A01627C141F98208C8111B85390D768392BDF7A547DC76836668A122212
- 807838E7E19CE83467BAF45540C4230A52023FC633312235546BD5AFAD7DD02E
- 68843A87BE7DDEE9831ECEAEF5410B549B88D48008A705796ECB3C277F4F8066
- 165194EE72ADFC08815FC7F34E31B60F9252EA90BC1C636D17344055C18DCEF5
- 01AA5DD0374097BC4C2935C1981424A12C0B26135B1405C539015495AF7EFE93
- 2B30F123E86DD03668035C8A680D08410F2A77971264587D07C004B4077A0292
- 52AB6DB2C1362A775032CA32673CF60B986B8454F5DCE772D1049A081BC00065
- 3C2B7320720C7A3C33D6AF866B0E38903ACA066807A40D6C002DA6F994FE309C
- C2854E505597540001B6AAB897095054B95C2D4A0492C29C2848024440063440
- 3AA86C826C021DA6C504551416B4C2CB29004082B285684E55C42C48009A0083
- 59B63F7B88F32A6148401A400B6513740B31B728CBA3B7B3AED41F22C8168A22
- 6A51098104A101F451A6403E1BE7030190A252A772FD362AB710D902FEF376CA
- 7339607943609E2D546A5522D414A5873000A620EF3C00029404340369A2720B
- C8DEB3718542609E1425063942B4873204A6CC8740E501312A19D0023554A173
- 9E1549828B10A08DD2A672FD2A3956785425D19FB37971955B510FB888C7E274
- F6715B56D8033E8D8BF6992B5AC7D2B0229DE0E7E57BABC04D0C816B92043F9D
- 156C847E1CD7A411FA7CDCF81CB02E836707EB32C8CD0C8175123C3B5897C1B9
- 0137897515983FB9292130CFBA0C5EBC70DD05F86019BCF1022C1A70DD595781
- F99375082C1870DD59B7C28B06DC24D639E0E285EB2E009CB7F1C697C1B50057
- BD80ABE64C80957D7BEC47E00381991DACD65EA1CF8307A4677B498C73D5EED0
- 388EAF725197C2CC560B841EC0FEFEFEBFF6F6F69E6C6F6F7BD75D80C160C0DE
- DE5EB9BFBFFF6FA8DC20DFDDDDFDF3BD7BF7BE2CCBF217C698A57C6DEE73A1AA
- EEF9F3E7FFD8DDDDFD0B909F253F0BCC36E012528545402590E55DB25C35714A
- AA8D428E6A0755CEBB1D5513607C31FB1BDE37FEEC2D0361350570CCDE8FE09D
- 086F7755FE90F2376FFCAA95CB790F58B388FF0302F53E33AD9AF65800000000
- 49454E44AE426082
- }
- Logo.Data = {
- 89504E470D0A1A0A0000000D4948445200000040000000400806000000AA6971
- DE0000000473424954080808087C0864880000069F49444154789CED9BBB6F1B
- D91587BF73EFBC380F92222959B2BDAEDC05768C0502D7298318C8A670933A48
- 99FF23F90F52A549B569923A85AB0DA02DE30041D419D63A80654994F8E6CCDC
- 9362289B92B9F6C26B48A4C4AFE10CE7CEC53D3F9ED710778415274D48D39434
- 0C09AD110B503A2D271326FD3EFDFE80FE87EE97CB59E6E7A7D9A0D9694B27CB
- C89258922892C85A2A014ACAF158C783A10E7A3D7A6F0EF54DF784EEA279BCCB
- 5DF68FC7F3F06EEF707BB3239BAD0DD36AD4A591A6924691449EADEC294A8AF1
- 58C7FDBEF64F4EF5A4D1708D83377AF0EA7FBC2A0A8A73F35D8D199F4610107C
- 7147BED8D9969DAD4DB3D5E998CE46D36C64A9C96A35A9F9BEF80079AEF968A4
- A35EDFF58EBBEE384B25AB45AEE67BEABFFC4E5F4EA74CCFE61480388E5B4F9F
- 3EFDD383070F7E2D52C5D1B221A2D4B363B2E49424E991D486C4B511513421F4
- A7787E81B50E80B23414B9C7240F188F4386A31A8351CC609071DAAF97DFFC73
- FF6F5F7FFDD7DF0D87C3230FE0F1E3C7BF7DF4E8D1574F9E3CB1B55AED4A0DFD
- 3E8C1CE099EFB0E615D6BCC69A438C1C61CD292260C4815402A006A701AA09A5
- ABE3B445E9DA946E8BE1A86D9D0B7FF5E2C5E36F9F3D7BF6470FE0EEDDBB5F3E
- 7CF8D0BB7FFF3EFF7D71C0645A7C682D978EC884D07609BC2E81EDE2DB2E3E87
- F8DE11C80922A012230400A84C1186282354728A52C94B8B4AC4DDBB77F8E9C3
- 3BDEEEB7B77FF6ECD95C0E30C600F0FB3FFCFD6AACFC00EDFA093BED37ECB48F
- D86975B9D53A656BA3C766734018648869634C1D24AA6ED031CE9DA2EE90C974
- 9F83EE31AF8F5FF3FAF825BFF9E50E4130248D27012C4882591C5EAE753F804E
- 43E9341CAD7AC94696B3914D69D527846186B5DB18B385312DC4C400A81BE2DC
- 11CEF98402ADFA88BC08C98B1CB48767478461EE8920EF09902E99009E2D6866
- 504F957AECC892922CCE49A2026B9B18DBC1981D8CB78D481D00D553A4081171
- 086392A84716E78C260530C4980941505ADFC75F204070D9367E90D077648990
- D620A929715812850E636344528CA944B0F636C66C02E0DC0168010C50D7C5D8
- 982874C491039D60A4C0F39C097C82A5F7805A3825A959E2C8100686C037F89E
- C3488831212211C6248834117B0F00D11C630E5117614C081AE07B137C5F0087
- 88C30812040B04A827CB2540E81724514014F884BE87672D460C225AB9B89420
- 2550800E667715202522E56C8C62C4E05BCB59F7AF542DF3D27B8067210C237C
- 3FC27A01627C141F98208C8111B85390D768392BDF7A547DC76836668A122212
- 807838E7E19CE83467BAF45540C4230A52023FC633312235546BD5AFAD7DD02E
- 68843A87BE7DDEE9831ECEAEF5410B549B88D48008A705796ECB3C277F4F8066
- 165194EE72ADFC08815FC7F34E31B60F9252EA90BC1C636D17344055C18DCEF5
- 01AA5DD0374097BC4C2935C1981424A12C0B26135B1405C539015495AF7EFE93
- 2B30F123E86DD03668035C8A680D08410F2A77971264587D07C004B4077A0292
- 52AB6DB2C1362A775032CA32673CF60B986B8454F5DCE772D1049A081BC00065
- 3C2B7320720C7A3C33D6AF866B0E38903ACA066807A40D6C002DA6F994FE309C
- C2854E505597540001B6AAB897095054B95C2D4A0492C29C2848024440063440
- 3AA86C826C021DA6C504551416B4C2CB29004082B285684E55C42C48009A0083
- 59B63F7B88F32A6148401A400B6513740B31B728CBA3B7B3AED41F22C8168A22
- 6A51098104A101F451A6403E1BE7030190A252A772FD362AB710D902FEF376CA
- 7339607943609E2D546A5522D414A5873000A620EF3C00029404340369A2720B
- C8DEB3718542609E1425063942B4873204A6CC8740E501312A19D0023554A173
- 9E1549828B10A08DD2A672FD2A3956785425D19FB37971955B510FB888C7E274
- F6715B56D8033E8D8BF6992B5AC7D2B0229DE0E7E57BABC04D0C816B92043F9D
- 156C847E1CD7A411FA7CDCF81CB02E836707EB32C8CD0C8175123C3B5897C1B9
- 0137897515983FB9292130CFBA0C5EBC70DD05F86019BCF1022C1A70DD595781
- F99375082C1870DD59B7C28B06DC24D639E0E285EB2E009CB7F1C697C1B50057
- BD80ABE64C80957D7BEC47E00381991DACD65EA1CF8307A4677B498C73D5EED0
- 388EAF725197C2CC560B841EC0FEFEFEBFF6F6F69E6C6F6F7BD75D80C160C0DE
- DE5EB9BFBFFF6FA8DC20DFDDDDFDF3BD7BF7BE2CCBF217C698A57C6DEE73A1AA
- EEF9F3E7FFD8DDDDFD0B909F253F0BCC36E012528545402590E55DB25C35714A
- AA8D428E6A0755CEBB1D5513607C31FB1BDE37FEEC2D0361350570CCDE8FE09D
- 086F7755FE90F2376FFCAA95CB790F58B388FF0302F53E33AD9AF65800000000
- 49454E44AE426082
- }
- Banner.Color = clNone
- Banner.ColorBalance = 0.5
- Banner.Height = 80
- Banner.ImageBalance = 0.5
- Title.ParentFont = False
- Title.Font.Height = 20
- Title.Font.Style = [fsBold]
- Title.Text = 'Highlight Controls Demo'
- Title.X = 0
- Title.Y = 0
- TitleSub.ParentFont = True
- TitleSub.Text = 'This programs demonstration how you can highlight controls'
- TitleSub.X = 0
- TitleSub.Y = 0
- object OptionBox: TCheckBox
- Left = 8
- Height = 24
- Top = 265
- Width = 192
- Anchors = [akLeft, akBottom]
- Caption = 'Show control highlighter'
- OnChange = OptionBoxChange
- OnEnter = ButtonClick
- TabOrder = 0
- end
- object CloseButton: TButton
- Left = 253
- Height = 25
- Top = 264
- Width = 75
- Anchors = [akRight, akBottom]
- Caption = 'Close'
- OnEnter = ButtonClick
- TabOrder = 1
- end
- object BrushList: TDetailsList
- Left = 8
- Height = 160
- Top = 88
- Width = 320
- Columns = <
- item
- Caption = 'Pattern'
- Tag = 1
- end
- item
- Caption = 'Brush Name'
- Tag = 0
- Width = 150
- end>
- Anchors = [akTop, akLeft, akRight, akBottom]
- BorderStyle = bsSingle
- DesktopFont = True
- HotTrack = False
- ItemHeight = 50
- MultiSelect = False
- ParentColor = False
- TabOrder = 2
- TabStop = True
- OnDrawItem = BrushListDrawItem
- OnEnter = ButtonClick
- end
- object PasteButton: TThinButton
- Left = 264
- Height = 32
- Top = 48
- Width = 32
- Anchors = [akTop, akRight]
- Down = False
- Images = ImageStrip
- ImageIndex = 0
- OnClick = ButtonClick
- end
- object ClearButton: TThinButton
- Left = 296
- Height = 32
- Top = 48
- Width = 32
- Anchors = [akTop, akRight]
- Down = False
- Images = ImageStrip
- ImageIndex = 1
- OnClick = ButtonClick
- end
- object ImageStrip: TImageStrip
- left = 392
- top = 168
- Data = {
- 89504E470D0A1A0A0000000D494844520000002C000000160806000000BB657E
- CA0000000473424954080808087C0864880000069E494441544889B5976B6C54
- C715C7FF3373F7EEE3EEDAC6C68F7A713014DB6A484C128C93B88EEC98002686
- 262529098DDA223E347D055AA56D6812D448A964483112A9D2C64451A5A81FF2
- 509C10B9A136B13151942024A2601B702ACCA3B1C136B0B6D76BEFEEDD3B73FA
- 61F71AAFBD8B9BA09ED5E8CEEE9C73E73767FE7346CB7003DBF8BD865D0D1B1F
- 7C5E08A1DBBF4929CDF75A0E3ED776A87DEF8D62BFA97106B1A942DBB76A29FF
- 91C695D1DE4B2FB6F5C83FFD4FC17BF7ED899DBFD04F232343D3EDFCF97EDADB
- B427FAFF800580ADF739FEF1E6B3774D1E79FD49BA74B4919AB63822BA06C31E
- D7ECCEBDB76637FCEEB1B2E66C9FE6070104C2918920C6C647B1604136841090
- 5262F0F20082A1A07E78F7DD0400448440480EEE7BF7EC93C7FBC6FF7933B085
- 59285FB9CCFB7D9F7F85E7E3C3EFA3C8FF532882199308CF017EFA0725CD2B2A
- AAFD190B8B118A487CDA17C0D4D0182CCB42FFB9B3504A827301A524A6429318
- C9AF475559260C17C7D8950BFE1D96D5FC44DFC9453703BC6995DE7477EDC3AE
- E1C1B3B8AB5860ECDA653A35885622A839C0591EE6F72D5C8CA991D3D8DD3A85
- CD9B1FC78E07CBE0D0B4392FDEB1FDD7E83B731ABBDF7C07CF6EF02073E13264
- 7AC87F33B07919285B96AF552DBBED1E5EE42F009C0FE1ADD75E88749C8A35CD
- F49BA6915202446050C8F344F0EA8103F34EF29D4227185C00281E7F1356B994
- FF6479458D83910577F612B4B5344F75F484F77F15C08994C04A4A000400D85C
- E946D4D4319F397511EF1025E2BFBE691A1C9685585589635B5979B5837107FE
- D3DF43A77A7B063E3C29FF38C7DFEE48690114974AA6D7F9F56625F58D337CFC
- C3ACD189492DC8272987BB7A108E2C47E7077F0FBFD6157B542AC4D2032B0922
- 4AF9D201F7771162D929C79452A02982BBB609AD358A8808DDDDBD479EDBB9AB
- 6E3ED8977635BE61187718FE626984C75BA01943B836BC1F19CBF919B31523A9
- 62524A62B6855836D6D4AD9F6FFE698B44A2F7CFE7A33BE05C98F3E562CB5AA9
- C6AF2EE1C0EF81480086F703D4ADED5A71A8BCAF6FFD13E365D74629097CCEA1
- 4B65B1587C67429313504A412909693FA5052965BC290B4B6E298169DEF85EA9
- BC53ABDDFF62C6DBB905E70D44FFC283E13C686215C0AA01DA0A322BC4F6E71F
- 7F6436EC2CE0EB1A9E6DA6690200A266046DFF6A079182228A3F158114812051
- 535B93E49FCAAA2AB4357FDB93F35EC9EDBF34941983EE32119DBC0C539DC457
- 83BD703BD6211666D6B1CFADCE54F14919A63492B80E1CC5FD75350018880884
- 3834294A643EBE60339A1AB8BA525BF74A634E4BE98AED1E5D7741B27310C209
- A7C7078FE684D7E7C2B98B9FA0FBF48181740B4ED6701A49D8004A4A747CD409
- 8081315BF1140F2342DD0375490B9C69F7ACD456BFD298DD525AFE94470881F0
- 782F9C1E1F002032198491990B4D63585A9C8BE18B5CCC0B7C230DDB005229AC
- 7EA00E8C3170CE13E0F136D3A2B3802BEFD46A5F7D69C1C1D2DB7FE589450398
- 0AFC1B6E5F0138D7108B4C4129CB4E1B1817703890B6AE266B18A9356C0308CE
- D1D979049C7130CEC11903180703C000ACAD5F97B440005859AEDDD7FCE7ACD6
- D2DB7E6E8482FD3027BF84E15B02A73B03440AC1D101181979096F02631A1C1A
- A5BDB5AE4B22518793729CF862030821505F5F0FC1058410E05C80739EC836A6
- EBB8EDEF7631E3AF8DDEF7172D5E6D5CB932609A13C7594EF6AD0EB7371B440A
- 23973E05995E38F37DB0AC3034DD879819406014C3F301332965FC0081CDA916
- 3600E31C1F1DEE88430A0EC10536346C0017028C31D0AC43178ED0E42FFE107A
- E8F57D6DED4666B923AF688B2658009AC670B1BFC314E0BAE1F5817181D1E16E
- E42E7A1813A35FC8F6AEC821003E0056A24DDF781A000EC0333685A14B17CE14
- 7CEB96B2E9C364A7D9066000D6AE5B032134684240080D60004B7C28A1E59992
- 38D16D7DF6B367423F7CE1B7BD7BCD48A8B0B874A3FBD2D06513CCADEBCE42E8
- 4626A415C1D8B53ECA2BF2B2ABC33D91A3C7CC2E00CE041B4F4C1D03405A62A0
- E08D8F432F2B79F069AF1ECB89EF2C4D4BC42C790600909F5B986EA700000262
- 0E30001C3B611DADDF12A8ADAD0A36EC7CEAC2CE82FCAC7CAFAF480ABD50E846
- 09C68343D29BD32094E2B06283DA17A7ACCFD3CD619F1757620BDC00E69494AD
- DB7EFC765E7EDE1DA41488287E69D87D4509ED26FA4AE1CAD5ABC7DE79EBDDEA
- 59F3B8134DAFB9575BBBA6C6B5BEECDB8E327F012B72BB94C7E52437007C7682
- BAB6FD26B809D7E590240936EBA5C9F569C698A609E7F4814C5DFDC81E915246
- D37AC54DCC688C31B0C4BF0ABB49A42959FF056529315FF01288700000000049
- 454E44AE426082
- }
- end
-end
diff --git a/examples/hilite/main.pas b/examples/hilite/main.pas
deleted file mode 100644
index 4f7bd74..0000000
--- a/examples/hilite/main.pas
+++ /dev/null
@@ -1,91 +0,0 @@
-unit Main;
-
-{$mode delphi}
-
-interface
-
-uses
- Classes, SysUtils, Graphics, Controls, Forms, StdCtrls,
- Codebot.System,
- Codebot.Graphics,
- Codebot.Graphics.Types,
- Codebot.Controls.Banner,
- Codebot.Controls.Scrolling,
- Codebot.Controls.Buttons,
- Codebot.Controls.Highlighter;
-
-{ THighlightForm }
-
-type
- THighlightForm = class(TBannerForm)
- CloseButton: TButton;
- OptionBox: TCheckBox;
- BrushList: TDetailsList;
- ImageStrip: TImageStrip;
- PasteButton: TThinButton;
- ClearButton: TThinButton;
- procedure BrushListDrawItem(Sender: TObject; Surface: ISurface;
- Index: Integer; Rect: TRectI; State: TDrawState);
- procedure FormCreate(Sender: TObject);
- procedure OptionBoxChange(Sender: TObject);
- procedure ButtonClick(Sender: TObject);
- private
- FHighlight: TControlHighlighter;
- FBrushes: StringArray;
- public
- { public declarations }
- end;
-
-var
- HighlightForm: THighlightForm;
-
-implementation
-
-{$R *.lfm}
-
-{ THighlightForm }
-
-procedure THighlightForm.FormCreate(Sender: TObject);
-var
- S: string;
-begin
- FHighlight := TControlHighlighter.Create(Self);
- for S in EnumBrushStyles do
- FBrushes.Push(S);
- BrushList.Count := FBrushes.Length;
-end;
-
-procedure THighlightForm.BrushListDrawItem(Sender: TObject;
- Surface: ISurface; Index: Integer; Rect: TRectI; State: TDrawState);
-var
- R: TRectI;
- B: IBrush;
-begin
- FillRectColor(Surface, Rect, clWindow);
- if Index = BrushList.ItemIndex then
- FillRectSelected(Surface, Rect, 4);
- R := Rect;
- R.Right := BrushList.GetColumnRect(0).Right;
- R.Inflate(-8, -8);
- Surface.StrokeRect(NewPen(clBlack, 1), R);
- B := StrToBrush(FBrushes[Index], clBlack, clTransparent);
- B.Matrix.Rotate(Pi / 4);
- Surface.FillRect(B, R);
- R := Rect;
- R.Left := BrushList.GetColumnRect(1).Left;
- R.Inflate(-4, -4);
- Surface.TextOut(Theme.Font, FBrushes[Index], R, drLeft);
-end;
-
-procedure THighlightForm.OptionBoxChange(Sender: TObject);
-begin
- FHighlight.Visible := OptionBox.Checked;
-end;
-
-procedure THighlightForm.ButtonClick(Sender: TObject);
-begin
- FHighlight.Control := Sender as TControl;
-end;
-
-end.
-
diff --git a/examples/pandrag/main.pas b/examples/pandrag/main.pas
index 03e327f..0f569cc 100644
--- a/examples/pandrag/main.pas
+++ b/examples/pandrag/main.pas
@@ -5,7 +5,7 @@
interface
uses
- Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, Types,
+ Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, Types,
Codebot.System,
Codebot.Graphics,
Codebot.Graphics.Types;
@@ -13,23 +13,23 @@ interface
{ TForm1 }
type
- TForm1 = class(TForm)
- procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
- Shift: TShiftState; X, Y: Integer);
- procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
- procedure FormMouseUp(Sender: TObject; Button: TMouseButton;
- Shift: TShiftState; X, Y: Integer);
- procedure FormMouseWheel(Sender: TObject; Shift: TShiftState;
- WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean);
- procedure FormPaint(Sender: TObject);
- private
- { private declarations }
- public
- { public declarations }
- end;
+ TForm1 = class(TForm)
+ procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
+ Shift: TShiftState; X, Y: Integer);
+ procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
+ procedure FormMouseUp(Sender: TObject; Button: TMouseButton;
+ Shift: TShiftState; X, Y: Integer);
+ procedure FormMouseWheel(Sender: TObject; Shift: TShiftState;
+ WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean);
+ procedure FormPaint(Sender: TObject);
+ private
+ { private declarations }
+ public
+ { public declarations }
+ end;
var
- Form1: TForm1;
+ Form1: TForm1;
implementation
diff --git a/examples/pandrag/pandrag.lps b/examples/pandrag/pandrag.lps
index a3ed7d5..da3d155 100644
--- a/examples/pandrag/pandrag.lps
+++ b/examples/pandrag/pandrag.lps
@@ -22,8 +22,8 @@
-
-
+
+
@@ -70,15 +70,13 @@
-
-
+
-
-
+
@@ -101,27 +99,30 @@
-
+
-
+
-
-
+
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/examples/pandrag/pandrag.res b/examples/pandrag/pandrag.res
index e66ecf8..e1df0e9 100644
Binary files a/examples/pandrag/pandrag.res and b/examples/pandrag/pandrag.res differ
diff --git a/extra/colorsensor.pas b/extra/colorsensor.pas
new file mode 100644
index 0000000..6dce761
--- /dev/null
+++ b/extra/colorsensor.pas
@@ -0,0 +1,299 @@
+unit ColorSensor;
+
+{$mode delphi}
+
+interface
+
+uses
+ Classes, Graphics, Controls, ExtCtrls,
+ Codebot.System,
+ Codebot.Graphics.Types,
+ Codebot.Controls.Extras,
+ Codebot.Networking,
+ Codebot.Text.Xml;
+
+{ TColorSensor }
+
+type
+ TSensorGain = (Gain1, Gain4, Gain16, Gain60);
+
+ TColorErrorEvent = procedure(Sender: TObject; const ErrorMsg: string) of object;
+ TColorReadEvent = procedure(Sender: TObject; const Color: TColorF) of object;
+
+ TColorSensor = class(TComponent)
+ private
+ FIsCapturing: Boolean;
+ FOutput: TShape;
+ FProgress: TIndeterminateProgress;
+ FServer: string;
+ FSuccess: Boolean;
+ FGain: TSensorGain;
+ FIntegrationTime: Single;
+ FErrorMsg: string;
+ FColor: TColorF;
+ FOnError: TColorErrorEvent;
+ FOnRead: TColorReadEvent;
+ procedure SetIsCapturing(Value: Boolean);
+ procedure SetOutput(Value: TShape);
+ procedure SetProgress(Value: TIndeterminateProgress);
+ procedure SyncError;
+ procedure SyncRead;
+ procedure SetIntegrationTime(Value: Single);
+ procedure UpdateControls;
+ protected
+ procedure Notification(AComponent: TComponent; Operation: TOperation); override;
+ procedure Execute(Thread: TSimpleThread);
+ procedure DoError(const ErrorMsg: string); virtual;
+ procedure DoRead(const Color: TColorF); virtual;
+ public
+ constructor Create(AOwner: TComponent); override;
+ destructor Destroy; override;
+ procedure Capture;
+ published
+ property Output: TShape read FOutput write SetOutput;
+ property Progress: TIndeterminateProgress read FProgress write SetProgress;
+ property IsCapturing: Boolean read FIsCapturing write SetIsCapturing;
+ property Server: string read FServer write FServer;
+ property Gain: TSensorGain read FGain write FGain;
+ property IntegrationTime: Single read FIntegrationTime write SetIntegrationTime;
+ property OnError: TColorErrorEvent read FOnError write FOnError;
+ property OnRead: TColorReadEvent read FOnRead write FOnRead;
+ end;
+
+implementation
+
+{ TColorSensor }
+
+constructor TColorSensor.Create(AOwner: TComponent);
+begin
+ inherited Create(AOwner);
+ IntegrationTime := 100;
+ Gain := Gain4;
+end;
+
+destructor TColorSensor.Destroy;
+begin
+ Output := nil;
+ inherited Destroy;
+end;
+
+procedure TColorSensor.Notification(AComponent: TComponent;
+ Operation: TOperation);
+begin
+ inherited Notification(AComponent, Operation);
+ if Operation = opRemove then
+ begin
+ if AComponent = FOutput then
+ FOutput := nil
+ else if AComponent = FProgress then
+ FProgress := nil;
+ end;
+end;
+
+procedure TColorSensor.SyncError;
+begin
+ FIsCapturing := False;
+ FSuccess := False;
+ UpdateControls;
+ DoError(FErrorMsg);
+end;
+
+procedure TColorSensor.SyncRead;
+begin
+ FIsCapturing := False;
+ FSuccess := True;
+ UpdateControls;
+ DoRead(FColor);
+end;
+
+procedure TColorSensor.DoError(const ErrorMsg: string);
+begin
+ if Assigned(FOnError) then
+ FOnError(Self, ErrorMsg);
+ FIsCapturing := False;
+end;
+
+procedure TColorSensor.DoRead(const Color: TColorF);
+begin
+ if Assigned(FOnRead) then
+ FOnRead(Self, Color);
+ FIsCapturing := False;
+end;
+
+procedure TColorSensor.Execute(Thread: TSimpleThread);
+const
+ SensorPort = 7050;
+ GainValues: array[TSensorGain] of string = ('1', '4', '16', '60');
+var
+ Client: TSocket;
+ Values: StringArray;
+ S: string;
+begin
+ Client := TSocket.Create;
+ try
+ if not Client.Connect(FServer, SensorPort) then
+ begin
+ FErrorMsg := 'Could not connect to server: ' + FServer;
+ Thread.Synchronize(SyncError);
+ Exit;
+ end;
+ Client.Write('[color] ' + FloatToStr(FIntegrationTime) + ' ' + GainValues[FGain]);
+ Client.Read(S);
+ if S = '' then
+ begin
+ FErrorMsg := 'No response received from sensor';
+ Thread.Synchronize(SyncError);
+ Exit;
+ end;
+ if not S.BeginsWith('[r g b]') then
+ begin
+ FErrorMsg := 'Unknown response from sensor';
+ Thread.Synchronize(SyncError);
+ Exit;
+ end;
+ S := S.Replace('[r g b]', '').Trim;
+ Values := S.Split(' ');
+ if Values.Length <> 3 then
+ begin
+ FErrorMsg := 'No values received from sensor';
+ Thread.Synchronize(SyncError);
+ Exit;
+ end;
+ FColor.Red := StrToFloatDef(Values[0], -1);
+ FColor.Green := StrToFloatDef(Values[1], -1);
+ FColor.Blue := StrToFloatDef(Values[2] , -1);
+ FColor.Alpha := 1;
+ if (FColor.Red < 0) or (FColor.Green < 0) or (FColor.Blue < 0) then
+ begin
+ FErrorMsg := 'Invalid color values received from sensor: ' + S;
+ Thread.Synchronize(SyncError);
+ Exit;
+ end;
+ if (FColor.Red > 1) or (FColor.Green > 1) or (FColor.Blue > 1) then
+ begin
+ FErrorMsg := 'Invalid color values received from sensor: ' + S;
+ Thread.Synchronize(SyncError);
+ Exit;
+ end;
+ Thread.Synchronize(SyncRead);
+ finally
+ Client.Free;
+ end;
+end;
+
+procedure TColorSensor.Capture;
+begin
+ if FIsCapturing then
+ begin
+ DoError('Capture already in progress');
+ Exit;
+ end;
+ FSuccess := False;
+ FIsCapturing := True;
+ UpdateControls;
+ TSimpleThread.Create(Execute);
+end;
+
+procedure TColorSensor.SetIntegrationTime(Value: Single);
+const
+ MinTime = 2.4;
+ MaxTime = 614.4;
+begin
+ if Value < MinTime then
+ Value := MinTime
+ else if Value > MaxTime then
+ Value := MaxTime;
+ FIntegrationTime := Value;
+end;
+
+procedure TColorSensor.SetOutput(Value: TShape);
+begin
+ if FOutput <> Value then
+ begin
+ if FOutput <> nil then
+ FOutput.RemoveFreeNotification(Self);
+ FOutput := Value;
+ if FOutput <> nil then
+ FOutput.FreeNotification(Self);
+ UpdateControls;
+ end;
+end;
+
+procedure TColorSensor.SetProgress(Value: TIndeterminateProgress);
+begin
+ if FProgress <> Value then
+ begin
+ if FProgress <> nil then
+ FProgress.RemoveFreeNotification(Self);
+ FProgress := Value;
+ if FProgress <> nil then
+ FProgress.FreeNotification(Self);
+ UpdateControls;
+ end;
+end;
+
+procedure TColorSensor.SetIsCapturing(Value: Boolean);
+begin
+ if not FIsCapturing then
+ if Value then
+ Capture;
+end;
+
+procedure TColorSensor.UpdateControls;
+begin
+ if FIsCapturing then
+ begin
+ if FOutput <> nil then
+ begin
+ FOutput.Brush.Style := bsClear;
+ FOutput.Visible := False;
+ end;
+ if FProgress <> nil then
+ begin
+ FProgress.Status := psBusy;
+ FProgress.Caption := 'Retrieving color data from ' + FServer;
+ end;
+ end
+ else if FErrorMsg <> '' then
+ begin
+ if FOutput <> nil then
+ begin
+ FOutput.Brush.Style := bsClear;
+ FOutput.Visible := False;
+ end;
+ if FProgress <> nil then
+ begin
+ FProgress.Status := psError;
+ FProgress.Caption := FErrorMsg;
+ end;
+ end
+ else if FSuccess then
+ begin
+ if FOutput <> nil then
+ begin
+ FOutput.Brush.Style := bsSolid;
+ FOutput.Brush.Color := FColor.Color;
+ FOutput.Visible := True;
+ end;
+ if FProgress <> nil then
+ begin
+ FProgress.Status := psReady;
+ FProgress.Caption := 'Successfully retrieved color data';
+ end;
+ end
+ else
+ begin
+ if FOutput <> nil then
+ begin
+ FOutput.Brush.Style := bsClear;
+ FOutput.Visible := False;
+ end;
+ if FProgress <> nil then
+ begin
+ FProgress.Status := psReady;
+ FProgress.Caption := 'Ready to retrieve color data';
+ end;
+ end;
+end;
+
+end.
diff --git a/git-commit.bat b/git-commit.bat
deleted file mode 100644
index 98e7d16..0000000
--- a/git-commit.bat
+++ /dev/null
@@ -1,16 +0,0 @@
-@echo off
-if [%1]==[] goto usage
-
-@echo on
-git add -u
-git commit -m %1
-git push
-
-@echo off
-goto finish
-
-:usage
-
-echo usage: git-commit.bat "Your commit message"
-
-:finish
diff --git a/git-commit.sh b/git-commit.sh
deleted file mode 100755
index 1ba7e97..0000000
--- a/git-commit.sh
+++ /dev/null
@@ -1,11 +0,0 @@
-#!/bin/sh
-
-if [ $# -eq 0 ]
- then
- echo "Please provide a commit message"
- exit 0
-fi
-
-git add -u
-git commit -m "$1"
-git push
diff --git a/git-ignore-elf.sh b/git-ignore-elf.sh
deleted file mode 100755
index 27a2823..0000000
--- a/git-ignore-elf.sh
+++ /dev/null
@@ -1,14 +0,0 @@
-#!/bin/sh
-set -eu
-cd "$(git rev-parse --show-toplevel)"
-file=.gitignore
-new=$file.new.$$
-(
-if [ -e "$file" ]; then
- cat "$file"
-fi
-find . -name .git -prune -o -type f ! -name '*.o' ! -name '*.so' \
- -print0 | xargs -0 file | grep ': *ELF ' | sed 's/:.*//' |
-sed 's,^./,,'
-) | perl -ne 'print if !$already{$_}++' >"$new"
-mv "$new" "$file"
diff --git a/libs/i386-win32/libeay32.dll b/libs/i386-win32/libeay32.dll
deleted file mode 100644
index 33084d5..0000000
Binary files a/libs/i386-win32/libeay32.dll and /dev/null differ
diff --git a/libs/i386-win32/libssl32.dll b/libs/i386-win32/libssl32.dll
deleted file mode 100644
index a30ff0e..0000000
Binary files a/libs/i386-win32/libssl32.dll and /dev/null differ
diff --git a/palette/TExternalCommand.bmp b/palette/TExternalCommand.bmp
new file mode 100644
index 0000000..e26669c
Binary files /dev/null and b/palette/TExternalCommand.bmp differ
diff --git a/palette/TTextStorage.bmp b/palette/TTextStorage.bmp
new file mode 100644
index 0000000..69e0f7c
Binary files /dev/null and b/palette/TTextStorage.bmp differ
diff --git a/palette/make b/palette/make
new file mode 100755
index 0000000..8ae2e78
--- /dev/null
+++ b/palette/make
@@ -0,0 +1,18 @@
+#!/bin/bash
+../../../lazarus/tools/lazres ../source/codebot_controls_design/palette_icons.res \
+ TImageStrip.bmp \
+ TRenderImage.bmp \
+ TRenderBox.bmp \
+ TSlideBar.bmp \
+ TThinButton.bmp \
+ TIndeterminateProgress.bmp \
+ THuePicker.bmp \
+ TSaturationPicker.bmp \
+ TBanner.bmp \
+ TContentGrid.bmp \
+ TSizingPanel.bmp \
+ THeaderBar.bmp \
+ TDrawList.bmp \
+ TDrawTextList.bmp \
+ TDetailsList.bmp \
+ TExternalCommand.bmp
diff --git a/palette/make.bat b/palette/make.bat
index 2a069f3..672531a 100644
--- a/palette/make.bat
+++ b/palette/make.bat
@@ -13,4 +13,5 @@ TSizingPanel.bmp ^
THeaderBar.bmp ^
TDrawList.bmp ^
TDrawTextList.bmp ^
-TDetailsList.bmp
\ No newline at end of file
+TDetailsList.bmp ^
+TExternalCommand.bmp
diff --git a/source/codebot.animation.pas b/source/codebot.animation.pas
deleted file mode 100644
index c2e7e8d..0000000
--- a/source/codebot.animation.pas
+++ /dev/null
@@ -1,647 +0,0 @@
-(********************************************************)
-(* *)
-(* Codebot Pascal Library *)
-(* http://cross.codebot.org *)
-(* Modified March 2015 *)
-(* *)
-(********************************************************)
-
-{ }
-unit Codebot.Animation;
-
-{$i codebot.inc}
-
-interface
-
-uses
- SysUtils, Classes,
- Codebot.System,
- Codebot.Collections;
-
-{ TEasing is the function prototype for change over time [group animation]
- See also
-
-
- External: Easing functions on easings.net }
-
-type
- TEasing = function(Percent: Float): Float;
-
-{ TEasingDefaults provides some default easing functions which conform to
- the [group animation]
- See also
-
-
- External: Easing functions on easings.net }
-
- TEasingDefaults = record
- public
- { The default easing function with no interpolation }
- class function Linear(Percent: Float): Float; static;
- { Slow, fast, then slow }
- class function Easy(Percent: Float): Float; static;
- { Real slow, fast, then real slow }
- class function EasySlow(Percent: Float): Float; static;
- { Wind up slow, fast, then overshoot and wind down slow }
- class function Extend(Percent: Float): Float; static;
- { Slow then fast }
- class function Drop(Percent: Float): Float; static;
- { Real slow then fast }
- class function DropSlow(Percent: Float): Float; static;
- { Real slow then fast }
- class function Snap(Percent: Float): Float; static;
- { Slow, fast, then bounce a few times }
- class function Bounce(Percent: Float): Float; static;
- { Slow, fast, then bounce a few more times }
- class function Bouncy(Percent: Float): Float; static;
- { Fast, then rebound slowly down }
- class function Rubber(Percent: Float): Float; static;
- { Fast, then rebound fast }
- class function Spring(Percent: Float): Float; static;
- { Fast, then rebound realy fast }
- class function Boing(Percent: Float): Float; static;
- end;
-
-{ TEasings is a dictionary which stores easings by name [group animation]
- See also
- }
-
- TEasings = class(TDictionary)
- protected
- {doc off}
- function DefaultValue: TEasing; override;
- public
- procedure RegisterDefaults;
- {doc on}
- end;
-
-{ Shortcut to easings key value type }
-
- TEasingKeyValue = TEasings.TKeyValue;
-
-{ Calculates the percent change of an easing, optionally reversing the curve [group animation] }
-function Interpolate(Easing: TEasing; Percent: Float; Reverse: Boolean = False): Float; overload;
-{ Calculates the effect of an easing on values, optionally reversing the curve [group animation] }
-function Interpolate(Easing: TEasing; Percent: Float; Start, Finish: Float; Reverse: Boolean = False): Float; overload;
-{ Provides access to [group animation] }
-function Easings: TEasings;
-
-{ TAnimationTimer is a high performance timer fixed at 30 frames per second [group animation]
- See also
- }
-
-type
- TAnimationTimer = class(TComponent)
- private
- FEnabled: Boolean;
- FOnTimer: TNotifyEvent;
- procedure Timer(Sender: TObject);
- procedure SetEnabled(Value: Boolean);
- public
- { Create a new aniamtion timer }
- constructor Create(AOwner: TComponent); override;
- destructor Destroy; override;
- published
- { Start or stop the timer using enabled }
- property Enabled: Boolean read FEnabled write SetEnabled default False;
- { OnTimer is fired every 1/30 of a second when enabled }
- property OnTimer: TNotifyEvent read FOnTimer write FOnTimer;
- end;
-
-{ TAnimator }
-
- TAnimator = class
- private
- type
- TAnimationItem = record
- Notify: IFloatPropertyNotify;
- Prop: PFloat;
- StartTarget: Float;
- StopTarget: Float;
- StartTime: Double;
- StopTime: Double;
- Easing: TEasing;
- end;
- PAnimationItem = ^TAnimationItem;
-
- TAnimations = TArrayList;
-
- var
- FAnimations: TAnimations;
- FAnimated: Boolean;
- FOnStart: TNotifyDelegate;
- FOnStop: TNotifyDelegate;
- public
- { Animate adds a property to the list of animated items }
- procedure Animate(var Prop: Float; Target: Float; const Easing: string; Duration: Double = 0.25); overload;
- procedure Animate(var Prop: Float; Target: Float; Easing: TEasing = nil; Duration: Double = 0.25); overload;
- procedure Animate(NotifyObject: TObject; var Prop: Float; Target: Float; const Easing: string; Duration: Double = 0.25); overload;
- procedure Animate(NotifyObject: TObject; var Prop: Float; Target: Float; Easing: TEasing = nil; Duration: Double = 0.25); overload;
- { Stop removes a property animation }
- procedure Stop(var Prop: Float);
- { Step causes all animated properties to be evaluated }
- procedure Step;
- { Animated is True is if a property value changed when Step was last invoked }
- property Animated: Boolean read FAnimated;
- { OnStart is invoked if an animated property requires steps }
- property OnStart: TNotifyDelegate read FOnStart;
- { OnStop is when there are no more properties to animate }
- property OnStop: TNotifyDelegate read FOnStop;
- end;
-
-function Animator: TAnimator;
-
-implementation
-
-{ Easings }
-
-var
- InternalEasings: TObject;
-
-function Easings: TEasings;
-begin
- if InternalEasings = nil then
- begin
- InternalEasings := TEasings.Create;
- TEasings(InternalEasings).RegisterDefaults;
- end;
- Result := TEasings(InternalEasings);
-end;
-
-{ TAnimator }
-
-var
- InternalAnimator: TObject;
-
-function Animator: TAnimator;
-begin
- if InternalAnimator = nil then
- InternalAnimator := TAnimator.Create;
- Result := TAnimator(InternalAnimator);
-end;
-
-const
- NegCosPi = 1.61803398874989; { 2 / -Cos(Pi * 1.2) }
-
-class function TEasingDefaults.Linear(Percent: Float): Float;
-begin
- Result := Percent;
-end;
-
-class function TEasingDefaults.Easy(Percent: Float): Float;
-begin
- Result := Percent * Percent * (3 - 2 * Percent);
-end;
-
-class function TEasingDefaults.EasySlow(Percent: Float): Float;
-begin
- Percent := Easy(Percent);
- Result := Percent * Percent * (3 - 2 * Percent);
-end;
-
-class function TEasingDefaults.Extend(Percent: Float): Float;
-begin
- Percent := (Percent * 1.4) - 0.2;
- Result := 0.5 - Cos(Pi * Percent) / NegCosPi;
-end;
-
-class function Power(const Base, Exponent: Float): Float;
-begin
- if Exponent = 0 then
- Result := 1
- else if (Base = 0) and (Exponent > 0) then
- Result := 0
- else
- Result := Exp(Exponent * Ln(Base));
-end;
-
-class function TEasingDefaults.Drop(Percent: Float): Float;
-begin
- Result := Percent * Percent;
-end;
-
-class function TEasingDefaults.DropSlow(Percent: Float): Float;
-begin
- Result := Percent * Percent * Percent * Percent * Percent;
-end;
-
-class function TEasingDefaults.Snap(Percent: Float): Float;
-begin
- Percent := Percent * Percent;
- Percent := (Percent * 1.4) - 0.2;
- Result := 0.5 - Cos(Pi * Percent) / NegCosPi;
-end;
-
-class function TEasingDefaults.Bounce(Percent: Float): Float;
-begin
- if Percent > 0.9 then
- begin
- Result := Percent - 0.95;
- Result := 1 + Result * Result * 20 - (0.05 * 0.05 * 20);
- end
- else if Percent > 0.75 then
- begin
- Result := Percent - 0.825;
- Result := 1 + Result * Result * 16 - (0.075 * 0.075 * 16);
- end
- else if Percent > 0.5 then
- begin
- Result := Percent - 0.625;
- Result := 1 + Result * Result * 12 - (0.125 * 0.125 * 12);
- end
- else
- begin
- Percent := Percent * 2;
- Result := Percent * Percent;
- end;
-end;
-
-class function TEasingDefaults.Bouncy(Percent: Float): Float;
-var
- Scale, Start, Step: Float;
-begin
- Result := 1;
- Scale := 5;
- Start := 0.5;
- Step := 0.2;
- if Percent < Start then
- begin
- Result := Percent / Start;
- Result := Result * Result;
- end
- else
- while Step > 0.01 do
- if Percent < Start + Step then
- begin
- Step := Step / 2;
- Result := (Percent - (Start + Step)) * Scale;
- Result := Result * Result;
- Result := Result + 1 - Power(Step * Scale, 2);
- Break;
- end
- else
- begin
- Start := Start + Step;
- Step := Step * 0.6;
- end;
-end;
-
-class function TEasingDefaults.Rubber(Percent: Float): Float;
-begin
- if Percent > 0.9 then
- begin
- Result := Percent - 0.95;
- Result := 1 - Result * Result * 20 + (0.05 * 0.05 * 20);
- end
- else if Percent > 0.75 then
- begin
- Result := Percent - 0.825;
- Result := 1 + Result * Result * 18 - (0.075 * 0.075 * 18);
- end
- else if Percent > 0.5 then
- begin
- Result := Percent - 0.625;
- Result := 1 - Result * Result * 14 + (0.125 * 0.125 * 14);
- end
- else
- begin
- Percent := Percent * 2;
- Result := Percent * Percent;
- end;
-end;
-
-class function TEasingDefaults.Spring(Percent: Float): Float;
-begin
- Percent := Percent * Percent;
- Result := Sin(PI * Percent * Percent * 10 - PI / 2) / 4;
- Result := Result * (1 - Percent) + 1;
- if Percent < 0.3 then
- Result := Result * Easy(Percent / 0.3);
-end;
-
-class function TEasingDefaults.Boing(Percent: Float): Float;
-begin
- Percent := Power(Percent, 1.5);
- Result := Sin(PI * Power(Percent, 2) * 20 - PI / 2) / 4;
- Result := Result * (1 - Percent) + 1;
- if Percent < 0.2 then
- Result := Result * Easy(Percent / 0.2);
-end;
-
-function TEasings.DefaultValue: TEasing;
-begin
- Result := @TEasingDefaults.Linear;
-end;
-
-function EasingKeyCompare(constref A, B: string): Integer;
-begin
- Result := StrCompare(A, B, True);
-end;
-
-
-procedure TEasings.RegisterDefaults;
-begin
- Comparer := EasingKeyCompare;
- Self['Linear'] := @TEasingDefaults.Linear;
- Self['Easy'] := @TEasingDefaults.Easy;
- Self['EasySlow'] := @TEasingDefaults.EasySlow;
- Self['Extend'] := @TEasingDefaults.Extend;
- Self['Drop'] := @TEasingDefaults.Drop;
- Self['DropSlow'] := @TEasingDefaults.DropSlow;
- Self['Snap'] := @TEasingDefaults.Snap;
- Self['Bounce'] := @TEasingDefaults.Bounce;
- Self['Bouncy'] := @TEasingDefaults.Bouncy;
- Self['Rubber'] := @TEasingDefaults.Rubber;
- Self['Spring'] := @TEasingDefaults.Spring;
- Self['Boing'] := @TEasingDefaults.Boing;
-end;
-
-function Interpolate(Easing: TEasing; Percent: Float; Reverse: Boolean = False): Float;
-begin
- if Percent < 0 then
- Result := 0
- else if Percent > 1 then
- Result := 1
- else if Reverse then
- Result := 1 - Easing(1 - Percent)
- else
- Result := Easing(Percent);
-end;
-
-function Interpolate(Easing: TEasing; Percent: Float; Start, Finish: Float; Reverse: Boolean = False): Float;
-begin
- if Percent < 0 then
- Result := Start
- else if Percent > 1 then
- Result := Finish
- else
- begin
- if Reverse then
- Percent := 1 - Easing(1 - Percent)
- else
- Percent := Easing(Percent);
- Result := Start * (1 - Percent) + Finish * Percent;
- end;
-end;
-
-{ TAnimationThread }
-
-type
- TAnimationThread = class(TThread)
- private
- procedure Animate;
- protected
- procedure Execute; override;
- public
- constructor Create;
- end;
-
-{ TThreadedTimer }
-
- TThreadedTimer = class(TObject)
- private
- FTimerCount: Integer;
- FOnTimer: TNotifyDelegate;
- function GetOnTimer: INotifyDelegate;
- public
- destructor Destroy; override;
- property OnTimer: INotifyDelegate read GetOnTimer;
- procedure Enable;
- procedure Disable;
- end;
-
-{ TThreadedTimer }
-
-var
- InternalThreadedTimer: TObject;
-
-function ThreadedTimer: TThreadedTimer;
-begin
- if InternalThreadedTimer = nil then
- InternalThreadedTimer := TThreadedTimer.Create;
- Result := TThreadedTimer(InternalThreadedTimer);
-end;
-
-var
- InternalThread: TObject;
-
-destructor TThreadedTimer.Destroy;
-begin
- InternalThread := nil;
- inherited Destroy;
-end;
-
-function TThreadedTimer.GetOnTimer: INotifyDelegate;
-begin
- Result := FOnTimer;
-end;
-
-procedure TThreadedTimer.Enable;
-begin
- if InterLockedIncrement(FTimerCount) = 1 then
- TAnimationThread.Create;
-end;
-
-procedure TThreadedTimer.Disable;
-begin
- if InterLockedDecrement(FTimerCount) = 0 then
- InternalThread := nil;
-end;
-
-{ TAnimationThread }
-
-constructor TAnimationThread.Create;
-begin
- InternalThread := Self;
- inherited Create(False);
-end;
-
-procedure TAnimationThread.Animate;
-var
- Event: TNotifyEvent;
-begin
- if InternalThread <> Self then
- Exit;
- if InternalThreadedTimer = nil then
- Exit;
- for Event in TThreadedTimer(InternalThreadedTimer).FOnTimer do
- Event(TThreadedTimer(InternalThreadedTimer));
-end;
-
-procedure TAnimationThread.Execute;
-const
- Delay = 1 / 30;
-var
- A, B: Double;
-begin
- A := TimeQuery;
- FreeOnTerminate := True;
- while InternalThread = Self do
- begin
- Synchronize(Animate);
- if InternalThread <> Self then
- Exit;
- B := TimeQuery - A;
- while B < Delay do
- begin
- B := (Delay - B) * 1000;
- Sleep(Round(B));
- B := TimeQuery - A;
- end;
- A := TimeQuery - (B - Delay);
- end;
-end;
-
-{ TAnimationTimer }
-
-constructor TAnimationTimer.Create(AOwner: TComponent);
-begin
- inherited Create(AOwner);
- ThreadedTimer.OnTimer.Add(Timer);
-end;
-
-destructor TAnimationTimer.Destroy;
-begin
- Enabled := False;
- ThreadedTimer.OnTimer.Remove(Timer);
- inherited Destroy;
-end;
-
-procedure TAnimationTimer.Timer(Sender: TObject);
-begin
- if FEnabled and Assigned(FOnTimer) then
- FOnTimer(Self);
-end;
-
-procedure TAnimationTimer.SetEnabled(Value: Boolean);
-begin
- if FEnabled = Value then Exit;
- FEnabled := Value;
- if csDesigning in ComponentState then Exit;
- if FEnabled then
- ThreadedTimer.Enable
- else
- ThreadedTimer.Disable;
-end;
-
-{ TAnimator }
-
-procedure TAnimator.Animate(var Prop: Float; Target: Float; const Easing: string; Duration: Double = 0.25);
-var
- E: TEasing;
-begin
- E := nil;
- if Easings.KeyExists(Easing) then
- E := Easings[Easing];
- Animate(nil, Prop, Target, E, Duration);
-end;
-
-procedure TAnimator.Animate(var Prop: Float; Target: Float; Easing: TEasing = nil; Duration: Double = 0.25);
-begin
- Animate(nil, Prop, Target, Easing, Duration);
-end;
-
-procedure TAnimator.Animate(NotifyObject: TObject; var Prop: Float; Target: Float;
- const Easing: string; Duration: Double = 0.25);
-var
- E: TEasing;
-begin
- E := nil;
- if Easings.KeyExists(Easing) then
- E := Easings[Easing];
- Animate(NotifyObject, Prop, Target, E, Duration);
-end;
-
-procedure TAnimator.Animate(NotifyObject: TObject; var Prop: Float; Target: Float;
- Easing: TEasing = nil; Duration: Double = 0.25);
-var
- Notify: IFloatPropertyNotify;
- Event: TNotifyEvent;
- Item: TAnimationItem;
-begin
- Stop(Prop);
- if (NotifyObject <> nil) and (NotifyObject is IFloatPropertyNotify) then
- Notify := NotifyObject as IFloatPropertyNotify
- else
- Notify := nil;
- if Duration <= 0 then
- begin
- Prop := Target;
- if Notify <> nil then
- Notify.PropChange(@Prop);
- Exit;
- end;
- Item.Notify := Notify;
- Item.Prop := @Prop;
- Item.StartTarget := Prop;
- Item.StopTarget := Target;
- Item.StartTime := TimeQuery;
- Item.StopTime := Item.StartTime + Duration;
- if @Easing = nil then
- Easing := TEasingDefaults.Easy;
- Item.Easing := Easing;
- if FAnimations.Length = 0 then
- for Event in FOnStart do
- Event(Self);
- FAnimations.Push(Item);
-end;
-
-procedure TAnimator.Stop(var Prop: Float);
-var
- Item: PAnimationItem;
- I: Integer;
-begin
- FAnimated := True;
- for I := FAnimations.Length - 1 downto 0 do
- begin
- Item := @FAnimations.Items[I];
- if Item.Prop = @Prop then
- begin
- if Item.Notify <> nil then
- Item.Notify.PropChange(Item.Prop);
- FAnimations.Delete(I);
- Exit;
- end;
- end;
-end;
-
-procedure TAnimator.Step;
-var
- Event: TNotifyEvent;
- Time: Double;
- Percent: Float;
- Item: PAnimationItem;
- I: Integer;
-begin
- Time := TimeQuery;
- FAnimated := FAnimations.Length > 0;
- if not FAnimated then
- begin
- for Event in FOnStop do
- Event(Self);
- Exit;
- end;
- for I := FAnimations.Length - 1 downto 0 do
- begin
- Item := @FAnimations.Items[I];
- if Time >= Item.StopTime then
- begin
- Item.Prop^ := Item.StopTarget;
- if Item.Notify <> nil then
- Item.Notify.PropChange(Item.Prop);
- FAnimations.Delete(I);
- Continue;
- end;
- Percent := (Time - Item.StartTime) / (Item.StopTime - Item.StartTime);
- Item.Prop^ := Interpolate(Item.Easing, Percent, Item.StartTarget, Item.StopTarget);
- if Item.Notify <> nil then
- Item.Notify.PropChange(Item.Prop);
- end;
-end;
-
-finalization
- InternalThreadedTimer.Free;
- InternalEasings.Free;
- InternalAnimator.Free;
-end.
-
diff --git a/source/codebot.controls.edits.pas b/source/codebot.controls.edits.pas
deleted file mode 100644
index ddd6741..0000000
--- a/source/codebot.controls.edits.pas
+++ /dev/null
@@ -1,76 +0,0 @@
-(********************************************************)
-(* *)
-(* Codebot Pascal Library *)
-(* http://cross.codebot.org *)
-(* Modified March 2015 *)
-(* *)
-(********************************************************)
-
-{ }
-unit Codebot.Controls.Edits;
-
-{$i codebot.inc}
-
-interface
-
-uses
- Classes, SysUtils, Graphics, Controls, StdCtrls,
- Codebot.System,
- Codebot.Graphics,
- Codebot.Graphics.Types,
- Codebot.Controls;
-
-{ TCustomRenderEdit }
-
-type
- TCustomRenderEdit = class(TRenderCustomControl)
- protected
- procedure Render; override;
- public
- constructor Create(AOwner: TComponent); override;
- end;
-
-{ THotShiftState }
-
- {THotkeyName = type string;
- THotkeyValue = type Word;
-
- THotkeyModifiers = set of (ssShift, ssAlt, ssCtrl, ssSuper);
-
- THotkey = class(TComponent)
- public
- constructor Create(AOwner: TComponent); override;
- destructor Destroy; override;
- procedure Clear;
- procedure Apply;
- procedure Cancel;
- property Valid: Boolean read GetValid;
- property Editing: Boolean read GetEditing;
- property KeyValue: THotkeyValue read GetValue write SetValue;
- published
- property AssociateEdit:
- property Active: Boolean read FActive write SetActive;
- property Editing: Boolean read FEditing write SetEditing;
- property KeyName: THotkeyKey string read GetKeyName write SetKeyName;
- property Modifiers: THotkeyModifiers read GetModifiers write SetModifiers;
- property OnExecute: TNotifyEvent read FOnExecute write FOnExecute;
- end;}
-
-implementation
-
-{ TCustomRenderEdit }
-
-constructor TCustomRenderEdit.Create(AOwner: TComponent);
-begin
- inherited Create(AOwner);
- Color := clWhite;
- Width := 100;
- Height := TextHeight + 8;
-end;
-
-procedure TCustomRenderEdit.Render;
-begin
-end;
-
-end.
-
diff --git a/source/codebot.design.imagelisteditor.lfm b/source/codebot.design.imagelisteditor.lfm
deleted file mode 100644
index f22b140..0000000
--- a/source/codebot.design.imagelisteditor.lfm
+++ /dev/null
@@ -1,530 +0,0 @@
-object ImageListEditor: TImageListEditor
- Left = 369
- Height = 393
- Top = 139
- Width = 531
- ClientHeight = 393
- ClientWidth = 531
- Constraints.MinHeight = 393
- Constraints.MinWidth = 531
- KeyPreview = True
- OnCreate = FormCreate
- OnKeyDown = FormKeyDown
- Position = poDesktopCenter
- LCLVersion = '1.5'
- Options = [boReanchor, boBannerShadow, boFooterShadow, boFooterGrip]
- Logo.Data = {
- 89504E470D0A1A0A0000000D4948445200000040000000400806000000AA6971
- DE000000017352474200AECE1CE90000000467414D410000B18F0BFC61050000
- 189049444154785EED5A777854C7B53F73EF166DD7EE4AABB6EA120851842802
- 44111803065C80E0F619B063E3CF26B8C44EE284D8F18B4B623B095F123BC9B3
- 93F8C529CFF14B6C708B63137AEF454854A1DE566D55B6B7FBCEB97B57DA9584
- 4CCB7B7F243F989DB93373E7CEA973CEBD827FE3DFF8D7815C060AA9D90F4EAA
- FF25B07605BC2435AF1DA30B462F7964DDC3DB7372B2CBA4AE1B8AA28913EE7D
- E4D187B7A5A6A5164B5D3704930B61FEB65F834BBAECC75569804A15177FDFAA
- 7BDE1D352A7FDE3DF7DEF57B9EE787A8D4F540AFD7A7DE79D7CAB7C71416CCBB
- 6FD5BDEF721CC74B43D705AD0A0CFFF128FB13CF3399D4D58FAB62C0828537BF
- A8D168D477DCB60C0CF106EBACD9339F92866E086EBD6DC9469D4E27C3F55942
- 82397FFAF49275D2D075E1E935F00B935E4866D27534AE980196244BE18CD2E9
- EB4B6794CA8D46234C2A9EC42F5C74F37F90D4A429D785EC9CAC39138AC6DF53
- 36A74C8E6B42F1C449FCE2A5B7BC82FC4E90A65C13CA26C38A853360554AFE52
- A9271657CC80DB6FBFF5A746A329382A7F34B85C1E9830BE08501BE44B6F5DFC
- 6369CA3583547DE5CA156F59ADD6605AAA15D777C3C4A289B8BE56B960D18217
- A569570D931E92BEBB96BD6D2D5C2998AD33A5DE585C1103929293C6E5E5E72E
- 9C3E6DBADCE7F3832008100C0A306BE66C1939AD8CCC8C19D2D46B026AD66309
- 8909F9B81EEFF17821141220100842C9D4127949C994B55AAD36499A7A5540E2
- FFCB9498A6B5163E88DA2F48BDB1B8220614158DBF5BA954FAD3ADE9E0F707C4
- BE4020009919599064490A7D65E5F237196357E54F2220E2162F59F40332A938
- A50A191B14194C8CCECBCD0374B4FCF809E3564AD3AF184B67C383D327C092C2
- D9CFCA385E89F45F070370334E00269064A2E1F5FA60CEEC323E29C9327ECAD4
- C90F4ADD570532216482A268C24471BD088809740860CD3C1E4F8FD47D454849
- 80ACA7D7B037B227AE01952E1720D889F2BF0E06B4B7B59FF37A3DF2DEDE1E90
- C9064EA65028043A9D1EC68D1DC7D083FF382E2ECE200D5D11C8748A274D5C55
- 3667AE9C348BD623C2A9C8E572686969A669ACADADFDAC78C315803160CF3FCA
- FE684CC85124E7DF0382EF0808A10E1CB90E069C3973F6639BADEDF49EBDBB83
- 4AA5A27F9354C866A74C2E2187A85DB070FEF7A55BBE1464322BEF5CF1EBD494
- D4209916A97C04380671710AD8B56797FFC2858B9F3735361D9386BE14772F82
- A726E4F333C7CCDE2003A10B04EF51EC45E271AFC3E18A18808486367DF0E1D7
- 5A6DAD7C5D7D1D1013228848AD74C64C59E9CC194F582C8963A4A111316D7AC9
- 23168BA5B0AC6CAE8C4E9568A6A2BF81D3A7CBC1E1E8838F367FF2B874CB9722
- 2B150A1FBD93BD9A37652D53AA5341706FC5DE101622FE3A1840A8ABADDB577E
- EAF47BA8057E994C264A89364B20DB1D3DAA008CF1C6D0F215CB7E29768E003A
- DB972E5DFCEAA4E2628E1C1F39D408D0E721530370E4D891E0CE1DBB7FD4D9D9
- 59250D8D08B44CF98BEBD99F8DC963B984ACDB51F20791F62E69F4063080F0E9
- A79F7DD3E170044F959FA4B058EC8B488DCEEE79736F926140336FECD8C265E2
- E06570CB925B5ED1EAB4AAE2E229E27D84C83A1A8D0AF6EDDF17EAEBEB6BDFB1
- 7DE70FC5C12BC00377C0F772D2E5E30A667C0B39D88AB65F2EF6D79DAB80935B
- 5E82968B9F89D78371550CE8EDE96DDAB675FBCB47513A3EBF57945604244593
- C90CB9B979A1652BEE7803B504CF9EA1B05AD3A64C9D3AF9A1B965F3E45EF1CC
- 0F9B108154BFBDBD0DAA6B2E711F6EFEF809BFDF3F2479190E853950B2E63678
- B660FA639C5C190F82673BF686D7D4C59BC06C9D0C6A43BA783D1857C500C2EE
- 5D7B37F6F6F6B6EC3FB03F84AADC2F392A4EA70B66CE98CD19F4FA943965B3BE
- 29DDD20F341B468E2F39293998919E85A6E39546C250ABE360C7AE1D819A9ADA
- 9DA7CB2BFE2A758F087447AA17BEC6FE6C4E2B114C69F351F5F7A3EAF749A318
- 0D26A742FA985BC0905828F5C4E2AA198092F690742E5DAAE2DA3BDAD15B874D
- 8140D2E438062525D3F8F937DFF49CC160B04A43222856484E492EBAE9A69B65
- 7D7DBD31CCC35304CE9C3D033D3D3D6CF3A68FD64BB77C29D6DD09AFA6256B32
- F3A73EC10BC13A10FCE7C203516BA30FC76B72864371D50C2054569CD95C5B53
- BB6BC7CEED01B55A2DF6451E465A4079824EABE33136F889388850A954C6DB6E
- 5BFA938945C59C52A11443DD08C8A972B8930307F707F6EED9FFF3365BDB1969
- 6844508EBF72013C3E66E693BC4CAE84907B573FC18389A7F670B8260610366F
- FEF831BBDDCE9D3F7F16C3598DD41B86C3E1248728C710F6EEECECACD9D4B7E8
- 96052FA3E3D34C9D52228E0F6C5000BD5E0BFB0FEC139C0E67CFD6ADDB5E1017
- F9124472FCC4ECB982DE320D89DF8374BA4482058C5823C4776130D570EE0BE8
- 69AF94EE8CC53533C0D66AAB3878E0E0AFF6EEDF13206748254290CFE783D4D4
- 34484B4D0BAE58B9FC3FD3D252274D9F31ED51727C6EB75B349508E834E9B2DB
- E1DCF973ECE38F3E7D0A1D63AF3434229E5A0D6F24261812B28B1EE604DF4508
- F9AB87104F6D0746AFF696D3E0EE6B92EE8CC5353380B0E58BADCF3B11878F1E
- A2B739526FD81C7A7A7A61DEBCF97C626242E1EA35F7BD6FC1A4292B3307DC6E
- 4FFF1C824EA783ED3BB6061A1B9B0E9D3871F24F62E79760CE6458BEA814568F
- 99F9948CE3303375EF1D4A3CAD8F252D371FC6953D0996EC9BA4BB63715D0C40
- 69DA3FFBDBE71B4E9D3A29385D0EF1188B1046599D8C97D38B0D66329BB2CB66
- 97C9BABBBBA50D86E7E8F53A923C747575F19BDEDFFC28F60F6FA85130EAC142
- 397EEAA8C582D6340E822EB4FB10469294A8896B87890F3363A00DC280CF89C6
- 75318070F8D0915F77B4779CDBB9737B10BD7E7F8448058319983AB5048F2A25
- 545456C4447CE4F8140A05ECDDB73B70E8E0E1B79A9B5B4E4A432362C343EC6D
- A3C9A2B316AE62216F25AA7E43FFF32E473CEA88D81E0ED7CD00B4E7E0A64D1F
- 7EADA9B989AF6FA88B7188F450746CF4E204257D968EB8F0A6B0188DF1E4F8F0
- D4703ABFF87CCBB3D22D230273FCAF9616C1AD634A9F9431C183AA7F6880C8E1
- 88C7E275BBC0D5D30CBECB64D4D7CD0042F5A59A9D78347EB07DC7363F9DE71C
- 9E69910D50A89B93930B89891628AF080B998E4ED28ED315E5C2A79F7CF60CCE
- 8904ED9745B219329F5ECD7E913E7639A8F4391070ED4062FD23122FA0B36DAE
- BE0867F6FE0ADA6B774A2BC5E2863080F0E9277FFB06666FC2C9532744E94610
- C4C4866CFFA6B9F3C530B7B9A5114366236CDBFE8F20A5D8470E1FFDAD34F5B2
- 9072FC3F1912D215C9B92B20E83989AA6F1B4AF020E2A94ECDC983C259EB2131
- AB0C4D61A819DC3006D8EDDD7598BCBC8AC18CE86DC8BE03013FF4F6754320E8
- C7E34E0D630A0AA1F24CA5680EB6361BF7C15F373D829B1C3E448BC25D0BE1EB
- E347713347973C86393EAEE73A3EACB4FBEC5D10F493560CF4CB6472506A4C20
- 93C7C62A11DC300610307D7DCDD9E7E8DAB3771798CD268C0D64209729C0EF0F
- 8AF63F7BD61C8CFF3D801164E8F8B1137FA8AF6FC09C7564608E3F66DD5DECD5
- ECF17733A52619FC8E9D481839B558E24378EA345C3C17437C640EFE88EDE170
- 431910F0FBDDEA5DDB6474B4D9511A74C66BD43AE01827063FF4D6671AA6C0AC
- EA027776F7AE4DD26D9705C656324A740C09795C62D62294FC310805BA6288C4
- 85C5BAB5BE061D9DBBBF5F245ED41289F8FF0B062C30A8BF653C76C8686AEF80
- ED5BB7A0AD9B2011ED9DD55543C79F7F0FFBEE5D06E7962D04DD1FDE86F5EEEE
- 0F740C12A55B87C503B7C3F772D365E3F3A63C220B05DA20E03E1D2B61A9ED76
- F4415B638368E083896FA9BD0467F7BD09EDF57BC4350763B8AF45D7042D8384
- 5734EC529EDEACB78E99009F2D9A0F328E07EDE17DC03EFB44B4C504A51A2CA8
- 115A591C1C6EAB0BEEF6FAFFF88E07BE2A2D118331D930F5ADE7E140DEA4AFF2
- A6B499E0EBF908639970941C7665A4DA6182CF9F381E70399C01851CE20AA64C
- 070E4D2F0C017ABB3AC11F30635B014D553BFC731F8AFD447EC334E02E256C54
- 73BCAA20310DE2EDDDB0F8F3AD30F5F0515034B788E3C5E634C8D698C1A0D080
- 5A1907634DC97CA90CEECFE6619A38210A628EBF9EBD179F340E4C6973C0EF3C
- 84AA3F1043444BB8A3B901CF7A27FCFE637899EEA53EFC09CFC19A5E882465CF
- 008D31475C7B30AE9A01C85B451EC0F4C5004F3FC3D8DFBEC9D847AB3978A394
- C19A42738A9C548AC26043971D522F5E04FFC9A3D01A62672BBB5AFD1C9E6794
- 2879D153276A0CA057AA43F72BD96FC602CCBF1DE0BBCFF1FC3F9EE4B8F79E9F
- 089F26FA145959E31FE083BE060878D0B98944C5124F84B7D6D78588F8EA2610
- D3BDFE39544B27053644A60C872B36019CC8E6013CBC8AB18D3C63BC46A51212
- 351A7510EDB0D7E512DC1E0FD361805390992906423214E38EEA4A7FB9C7BBFB
- 5D8FF0C4F7D5503ED694CAAB91859439D23189BE1B0EB7D484641EF0A7991258
- B2C1A0F023F36C7D1D60EF7581DCA086B12F6441E21C2DEE402220ACF962A3BA
- E274B0AAC67169CDB3C278FA0AF4CA13B0391F9D2C9D3E617AC33315DA52CC0A
- ED70F1E83B434CE08ABEBF6700147D87B1BF97F1FCAA8294144DA6C522B7E8F5
- 72755C1CE6E52A30E9F52CD96C86AEDE5E68C7A027011DDF9EBA73FE26AFB7EE
- 75B7705BA700352A06FAF8806B6A9ED1C2BB3023A4AD29D12FA83819146566CB
- CC1A0DAF44C6A8E47248329820CF9A0171020F157FB900DDA7FA207EB20E64EA
- C87605B0B7D9A0BBDDC69EF929DCD6DA097599295070F334B8C79C9C8AC2C27C
- 4422BEAFBB0BE303F403EE3EACEB42EF7C1CFB57225F6A02530096BFC4D891C9
- F1F1138AB2B2544430B197D4DC81B9BD1F131C52233A87F3ACE13760072F9C0D
- 357ABDF5AFBA84D9BD784251DF273E78A13518AA3968ABF5C7EBB4A22978B058
- 0D26461AA1C47583587B701DEC009FD70B26D4A839E38A41598549D3AD27A1F7
- BC4354693F8EB5D4D506DFDF0AAF575E82985822C604B0781C0EE8EDB8041E57
- BB34231623326034C0ECC7197B6F544A8A3CC564A2005FDCF4B99616D7C99A9A
- C0F1A6265B39D6B5369B20C6FF680E29090920F84302123F2B423CC183C9E18F
- 5DC2DC56BFBFF990ADCE6FC21881E449A7338F52DF5351EEDB5F79124EB5D6C2
- EE8A5370BE056D1F9F17406247255B213F39038E3D740E5C4D1E68AEA90E7576
- 0BAD6FBD0F4392A8C8D1487BA5B639250D728AEF0663CA2469462C2ECB0094E5
- B86FA3DA67A3BA6B50D549A13AFBFA84330D0DBE0F5DAE379F12849C758290FC
- 3840BACDD1E7226D08A0F4E2311902743E7102845F1646A1078FE5D75CC29C4E
- 9FD751DED12888DA848CAB6A6880A0D9C3177F5A2A2CAEFC11CCDC3C1782A383
- A84995D08DEB52789B8EC994353E198E3E70061C2DDDDC0F7F2B3CE8F182535A
- BA1F11C9C7C40B2338C161198092916F606C4BBAD1186750ABE96D3674F6F60A
- 551D1DDD2F09C2BCFF06F846274003CDC524B3F5B8009FB8A457DC0C09E2140A
- 37F90DB16310BA04A83FE216FEC8042EC491EAA333B4BB7B83FA79712CAD7039
- 0BB8CF435C5A0F14BD9E0705DFCF84D3B555388ECC254D48CB00336F848BAF70
- B6C315B0455A3206C3134FD7A46B43312C03E660106690C9F4897A3D3A7C465E
- 1E6A3B3A3C44FC4580FDD2B47ED805A1D91B0C06C80FF0C8805020208B306838
- 3486E074D02F78224710668C7CF29839B8173C22FB8EF46F3E69613C8C7D390B
- 4ED75481077D8D1F1951945B00CA56661C0530EC9F7C44DB3F114EFEC2ED6847
- 060E7C2B88C61006A0F4657732F6626E62A2983E91E25CB2D97C3F178495F500
- A7A86F30F239AEC4A052C942F460BC66C1605C1BDE161E1D0A1AA3AFCAA2DF40
- A6693153F3D6FBC1DB436F76C37F811221C4B2C008990F27C1A9FA2A51BBD0FB
- 424156167F0FCF8B81CF6044C7FFD4EE6A6D81DAF24D606F3D21CD88C5100620
- 5B57EB50FA71E898E881ED3D3DA16A8023270186FDB88687AA3A531026A95095
- 15788F0739EE67CC85C66997A60C0132A01A53443C01F1BC4675D5C6A9C0B6E5
- 04047D6D319B8FB4ADF7258017FFF5389DE0F778607446069F2F08A55900433C
- 5B987103F71B9392216BC20A884F9928CD88C510069431B6263D3E5E4DD294A1
- 8DB6D8ED817743A16F4BC343700B634F6050C428CAA3AF448D9D9D810AE8B74F
- D2F22185CCC3AD659DAD5DE11741894623781A7BA1630FBD340D6F1E1BFD6D7B
- 4733A89608BE9375756E3249864CCBB15AB952807BC505A21066DA00F3C8CFC8
- 957A0C8E06BE60456308039218CB2569D28328642546A0DD1F908609740F9D60
- 723D40DA520C61D32D16158FF778F19EBACE4E784F105EC571DDE54A7A0A4C36
- DD153256DA9A0129128F3B537C229CD9D80CAEDE00787D68BBFE20040302B8E8
- 1CEFEA80BFD4082F7B5C2E051114447F60D6E964993C3F0ED78B8148B8E804A9
- 509B18117E7F301C621880E2617A3CDA22DFFFDD78E6B7305685F290E3309E59
- 407E412CA8FA094F73DC16637CBC5286C4FB50FD2FD86CC1538CED6A02407721
- 124B316C0CF1B8FFF8A757B17734D352C06F8883BA9E1E7013033075F6A2D11C
- DF50074E47009C6E0CB49C01A8BD581F387E961D7CF7106CC473C6E745E2E9DD
- 821683A414743FB8660CFA09EF273ECC0CBC9066C42286010680642608F238A5
- 12145802E474004877E85337D562410EA4AE67EC8334B53A37D56251F891AA4E
- F4D0D51D1DC2E650E8E73887088F101FC38465F3E0194B0257109FB94466B9BF
- 08CEB536820309A217E6D9A999D075DA03953F6902672FE604CDADE074FA42AF
- FD4E7812E95106D141D39F51F9F082344E83C2C24B32AB7E0C101F26BCA7DD06
- F5959F40B72DFCF7028311CD0086D97617AAA4B30F553F888B10130C829061C1
- F41CC7E598096AF0705FFE3C6307C7E97493F2535294F4973D0EF4CC476B6A7C
- 1F0AC246947E1D7691964433412CD9A930ED9699B04E97348BF30590C9137A40
- 354303C7EAAB81FE4C829C6E813507BA0FFAE0D8BA6A683AD02974F540CFFDB7
- C38B2F2E862D8C67320135135043DB5073C0C2022FAF878F7EF0387CB4FA56D8
- 804B200762B5408EA9B7363E1DE47146717830A2B94776CD7F9DB1CD8B131296
- 24A14A92D2D4757404EBBBBA7CED8CD59830FAC3B89DE522E16A640E4571212C
- C7AAAABC3B83C177FF2E086F44D6C142CCEDAF917BCA0D6BD9DB19E9A9C9D6D1
- 4BB8A0FB02C60B8DE260DD1B3608550B30212317785471B2739BDD0E0D6D2DC0
- A1F1C599D11FB58460D69871A0C13103265E47CE9683AFB41B12972B681BC021
- 25549B2C49C4495C55023241A92FC65CC0010DE7FE3E241B8C6680B8510C821E
- 7A402EDF589C93A316B9881CA720C4835A417FBA46890B690787ED1E0C90CE36
- 367A8F06839FA3E37B8EEE97D6195CC437BB374D97AFCC1C7B17C7313C2A9DC7
- E975376E1C7FD056AB5F4162DB3828B466830629415314BF1EF9F1B9B4490D3D
- 1BFBD4186A63E2015B0FEF87B13F4D057D81525C87470E3046E217FF23FA1BC8
- 8089E0713AA0F1C21723A6C3345D6804A8C0737D0AD7D797916A36CB31140439
- 3E90E2023A16E9ACA76CED425393AFAEADCDBB29147AE90B809FE1BDF43A9C4C
- 395253114DB630078A1F5C06DFB18E9ACF69F54920B88F819C0F6261A4CDA050
- 30B0946921E40DC0A57D0DA8011C249B13E8E50B28F0F96A7A2E4ED4190C1040
- DBDE75E23024DFA1C348512B3290241F219E80628B3444F0CA2408F8BCD0D755
- 3D241D8ED6807EE07A3C66817F29E6B825069D8E99B45A25491F252EB4F4F5B9
- BC6EB7E21866B8FF8352C700930E739232AD4525D226304D1CE87FF66DB6352D
- 23D79C9A772BEF7560C0E30D7FAAA6AC9DC44712A436A9B1A7D50F0DAF7780AB
- CA0766931E2C5A3350E6E8C420A8D36987F6F64E48B9D300196B8D61D5428804
- 4BC4F6932FFD78282463262C0AE86C393DA209C48098809E6F2E9E3333C673DC
- 7C7421A96704610F96BD1730E5EF081F75743F95680644D614DBDF5803BF9C3F
- 43F5959C890FCA84A01D3CBD474482C936C55A82C8042AB869AADD757E709E71
- 83B3DC0B9E8B3E5065C84157A400DD381568C6200D972158FC8D6A3BBAED1040
- 4F2D5318A0D7DE70E50CB80A44D6A03AA63DAB186E472FFDBEB57025A8F45670
- 776E4573F789F64D3368126D53BC49BC0E6F3A0C6C4B97234958FC8D6A47FAA5
- 2B71304E3F1E3C6E17B45CDA398401112DBA1ED0B3A8D0A141F62FFA00A31E8C
- CF3DCC7E634E9B2018124641C875021D950F641C9EE1E879D0CC51E549ED49E2
- 58E876A2048B788C8941CC306DAAFB039C701B7F86F68BD7917EACB10C0791F9
- 3718C454FEB5AFC387B3A6E816E64D5E2B634C06413FBA0ADA5CBF6CA48D8B4D
- FAA5EB704D9B0E23CC94F01CE9DEF085D4A68B701D734DBF383F0C6432AF0377
- 5F2BB4D6EE250DA0889606C58937920174A28865C92C58F3DDB5F0A6C152086A
- 43A63828ED4BAA8830B1310069F36225224C40CCB408A1523B1A030CA08BC8D8
- C01C8FB31DBADBCF1303E82FDA494BE901C11BCE808478B0FEEE4538A8D3C0C0
- 37F201FC3334EE7288E510C2EB03CFA27540E173C4546F280322104D20AA44AE
- A3EB48A16BDA43741F5D470A81EA6891461792E2E54ABF9407D5149F502DAE19
- 79C83F13F48C680207134DEDE10A215247206E5AAAA34B8420AA2F5786C5E007
- FC7F237A3F97DB1B111A5DFF1BD70E80FF059FD1E90533117C87000000004945
- 4E44AE426082
- }
- Logo.Data = {
- 89504E470D0A1A0A0000000D4948445200000040000000400806000000AA6971
- DE000000017352474200AECE1CE90000000467414D410000B18F0BFC61050000
- 189049444154785EED5A777854C7B53F73EF166DD7EE4AABB6EA120851842802
- 44111803065C80E0F619B063E3CF26B8C44EE284D8F18B4B623B095F123BC9B3
- 93F8C529CFF14B6C708B63137AEF454854A1DE566D55B6B7FBCEB97B57DA9584
- 4CCB7B7F243F989DB93373E7CEA973CEBD827FE3DFF8D7815C060AA9D90F4EAA
- FF25B07605BC2435AF1DA30B462F7964DDC3DB7372B2CBA4AE1B8AA28913EE7D
- E4D187B7A5A6A5164B5D3704930B61FEB65F834BBAECC75569804A15177FDFAA
- 7BDE1D352A7FDE3DF7DEF57B9EE787A8D4F540AFD7A7DE79D7CAB7C71416CCBB
- 6FD5BDEF721CC74B43D705AD0A0CFFF128FB13CF3399D4D58FAB62C0828537BF
- A8D168D477DCB60C0CF106EBACD9339F92866E086EBD6DC9469D4E27C3F55942
- 82397FFAF49275D2D075E1E935F00B935E4866D27534AE980196244BE18CD2E9
- EB4B6794CA8D46234C2A9EC42F5C74F37F90D4A429D785EC9CAC39138AC6DF53
- 36A74C8E6B42F1C449FCE2A5B7BC82FC4E90A65C13CA26C38A853360554AFE52
- A9271657CC80DB6FBFF5A746A329382A7F34B85C1E9830BE08501BE44B6F5DFC
- 6369CA3583547DE5CA156F59ADD6605AAA15D777C3C4A289B8BE56B960D18217
- A569570D931E92BEBB96BD6D2D5C2998AD33A5DE585C1103929293C6E5E5E72E
- 9C3E6DBADCE7F3832008100C0A306BE66C1939AD8CCC8C19D2D46B026AD66309
- 8909F9B81EEFF17821141220100842C9D4127949C994B55AAD36499A7A5540E2
- FFCB9498A6B5163E88DA2F48BDB1B8220614158DBF5BA954FAD3ADE9E0F707C4
- BE4020009919599064490A7D65E5F237196357E54F2220E2162F59F40332A938
- A50A191B14194C8CCECBCD0374B4FCF809E3564AD3AF184B67C383D327C092C2
- D9CFCA385E89F45F070370334E00269064A2E1F5FA60CEEC323E29C9327ECAD4
- C90F4ADD570532216482A268C24471BD088809740860CD3C1E4F8FD47D454849
- 80ACA7D7B037B227AE01952E1720D889F2BF0E06B4B7B59FF37A3DF2DEDE1E90
- C9064EA65028043A9D1EC68D1DC7D083FF382E2ECE200D5D11C8748A274D5C55
- 3667AE9C348BD623C2A9C8E572686969A669ACADADFDAC78C315803160CF3FCA
- FE684CC85124E7DF0382EF0808A10E1CB90E069C3973F6639BADEDF49EBDBB83
- 4AA5A27F9354C866A74C2E2187A85DB070FEF7A55BBE1464322BEF5CF1EBD494
- D4209916A97C04380671710AD8B56797FFC2858B9F3735361D9386BE14772F82
- A726E4F333C7CCDE2003A10B04EF51EC45E271AFC3E18A18808486367DF0E1D7
- 5A6DAD7C5D7D1D1013228848AD74C64C59E9CC194F582C8963A4A111316D7AC9
- 23168BA5B0AC6CAE8C4E9568A6A2BF81D3A7CBC1E1E8838F367FF2B874CB9722
- 2B150A1FBD93BD9A37652D53AA5341706FC5DE101622FE3A1840A8ABADDB577E
- EAF47BA8057E994C264A89364B20DB1D3DAA008CF1C6D0F215CB7E29768E003A
- DB972E5DFCEAA4E2628E1C1F39D408D0E721530370E4D891E0CE1DBB7FD4D9D9
- 59250D8D08B44CF98BEBD99F8DC963B984ACDB51F20791F62E69F4063080F0E9
- A79F7DD3E170044F959FA4B058EC8B488DCEEE79736F926140336FECD8C265E2
- E06570CB925B5ED1EAB4AAE2E229E27D84C83A1A8D0AF6EDDF17EAEBEB6BDFB1
- 7DE70FC5C12BC00377C0F772D2E5E30A667C0B39D88AB65F2EF6D79DAB80935B
- 5E82968B9F89D78371550CE8EDE96DDAB675FBCB47513A3EBF57945604244593
- C90CB9B979A1652BEE7803B504CF9EA1B05AD3A64C9D3AF9A1B965F3E45EF1CC
- 0F9B108154BFBDBD0DAA6B2E711F6EFEF809BFDF3F2479190E853950B2E63678
- B660FA639C5C190F82673BF686D7D4C59BC06C9D0C6A43BA783D1857C500C2EE
- 5D7B37F6F6F6B6EC3FB03F84AADC2F392A4EA70B66CE98CD19F4FA943965B3BE
- 29DDD20F341B468E2F39293998919E85A6E39546C250ABE360C7AE1D819A9ADA
- 9DA7CB2BFE2A758F087447AA17BEC6FE6C4E2B114C69F351F5F7A3EAF749A318
- 0D26A742FA985BC0905828F5C4E2AA198092F690742E5DAAE2DA3BDAD15B874D
- 8140D2E438062525D3F8F937DFF49CC160B04A43222856484E492EBAE9A69B65
- 7D7DBD31CCC35304CE9C3D033D3D3D6CF3A68FD64BB77C29D6DD09AFA6256B32
- F3A73EC10BC13A10FCE7C203516BA30FC76B72864371D50C2054569CD95C5B53
- BB6BC7CEED01B55A2DF6451E465A4079824EABE33136F889388850A954C6DB6E
- 5BFA938945C59C52A11443DD08C8A972B8930307F707F6EED9FFF3365BDB1969
- 6844508EBF72013C3E66E693BC4CAE84907B573FC18389A7F670B8260610366F
- FEF831BBDDCE9D3F7F16C3598DD41B86C3E1248728C710F6EEECECACD9D4B7E8
- 96052FA3E3D34C9D52228E0F6C5000BD5E0BFB0FEC139C0E67CFD6ADDB5E1017
- F9124472FCC4ECB982DE320D89DF8374BA4482058C5823C4776130D570EE0BE8
- 69AF94EE8CC53533C0D66AAB3878E0E0AFF6EEDF13206748254290CFE783D4D4
- 34484B4D0BAE58B9FC3FD3D252274D9F31ED51727C6EB75B349508E834E9B2DB
- E1DCF973ECE38F3E7D0A1D63AF3434229E5A0D6F24261812B28B1EE604DF4508
- F9AB87104F6D0746AFF696D3E0EE6B92EE8CC5353380B0E58BADCF3B11878F1E
- A2B739526FD81C7A7A7A61DEBCF97C626242E1EA35F7BD6FC1A4292B3307DC6E
- 4FFF1C824EA783ED3BB6061A1B9B0E9D3871F24F62E79760CE6458BEA814568F
- 99F9948CE3303375EF1D4A3CAD8F252D371FC6953D0996EC9BA4BB63715D0C40
- 69DA3FFBDBE71B4E9D3A29385D0EF1188B1046599D8C97D38B0D66329BB2CB66
- 97C9BABBBBA50D86E7E8F53A923C747575F19BDEDFFC28F60F6FA85130EAC142
- 397EEAA8C582D6340E822EB4FB10469294A8896B87890F3363A00DC280CF89C6
- 75318070F8D0915F77B4779CDBB9737B10BD7E7F8448058319983AB5048F2A25
- 545456C4447CE4F8140A05ECDDB73B70E8E0E1B79A9B5B4E4A432362C343EC6D
- A3C9A2B316AE62216F25AA7E43FFF32E473CEA88D81E0ED7CD00B4E7E0A64D1F
- 7EADA9B989AF6FA88B7188F450746CF4E204257D968EB8F0A6B0188DF1E4F8F0
- D4703ABFF87CCBB3D22D230273FCAF9616C1AD634A9F9431C183AA7F6880C8E1
- 88C7E275BBC0D5D30CBECB64D4D7CD0042F5A59A9D78347EB07DC7363F9DE71C
- 9E69910D50A89B93930B89891628AF080B998E4ED28ED315E5C2A79F7CF60CCE
- 8904ED9745B219329F5ECD7E913E7639A8F4391070ED4062FD23122FA0B36DAE
- BE0867F6FE0ADA6B774A2BC5E2863080F0E9277FFB06666FC2C9532744E94610
- C4C4866CFFA6B9F3C530B7B9A5114366236CDBFE8F20A5D8470E1FFDAD34F5B2
- 9072FC3F1912D215C9B92B20E83989AA6F1B4AF020E2A94ECDC983C259EB2131
- AB0C4D61A819DC3006D8EDDD7598BCBC8AC18CE86DC8BE03013FF4F6754320E8
- C7E34E0D630A0AA1F24CA5680EB6361BF7C15F373D829B1C3E448BC25D0BE1EB
- E347713347973C86393EAEE73A3EACB4FBEC5D10F493560CF4CB6472506A4C20
- 93C7C62A11DC300610307D7DCDD9E7E8DAB3771798CD268C0D64209729C0EF0F
- 8AF63F7BD61C8CFF3D801164E8F8B1137FA8AF6FC09C7564608E3F66DD5DECD5
- ECF17733A52619FC8E9D481839B558E24378EA345C3C17437C640EFE88EDE170
- 431910F0FBDDEA5DDB6474B4D9511A74C66BD43AE01827063FF4D6671AA6C0AC
- EA027776F7AE4DD26D9705C656324A740C09795C62D62294FC310805BA6288C4
- 85C5BAB5BE061D9DBBBF5F245ED41289F8FF0B062C30A8BF653C76C8686AEF80
- ED5BB7A0AD9B2011ED9DD55543C79F7F0FFBEE5D06E7962D04DD1FDE86F5EEEE
- 0F740C12A55B87C503B7C3F772D365E3F3A63C220B05DA20E03E1D2B61A9ED76
- F4415B638368E083896FA9BD0467F7BD09EDF57BC4350763B8AF45D7042D8384
- 5734EC529EDEACB78E99009F2D9A0F328E07EDE17DC03EFB44B4C504A51A2CA8
- 115A591C1C6EAB0BEEF6FAFFF88E07BE2A2D118331D930F5ADE7E140DEA4AFF2
- A6B499E0EBF908639970941C7665A4DA6182CF9F381E70399C01851CE20AA64C
- 070E4D2F0C017ABB3AC11F30635B014D553BFC731F8AFD447EC334E02E256C54
- 73BCAA20310DE2EDDDB0F8F3AD30F5F0515034B788E3C5E634C8D698C1A0D080
- 5A1907634DC97CA90CEECFE6619A38210A628EBF9EBD179F340E4C6973C0EF3C
- 84AA3F1043444BB8A3B901CF7A27FCFE637899EEA53EFC09CFC19A5E882465CF
- 008D31475C7B30AE9A01C85B451EC0F4C5004F3FC3D8DFBEC9D847AB3978A394
- C19A42738A9C548AC26043971D522F5E04FFC9A3D01A62672BBB5AFD1C9E6794
- 2879D153276A0CA057AA43F72BD96FC602CCBF1DE0BBCFF1FC3F9EE4B8F79E9F
- 089F26FA145959E31FE083BE060878D0B98944C5124F84B7D6D78588F8EA2610
- D3BDFE39544B27053644A60C872B36019CC8E6013CBC8AB18D3C63BC46A51212
- 351A7510EDB0D7E512DC1E0FD361805390992906423214E38EEA4A7FB9C7BBFB
- 5D8FF0C4F7D5503ED694CAAB91859439D23189BE1B0EB7D484641EF0A7991258
- B2C1A0F023F36C7D1D60EF7581DCA086B12F6441E21C2DEE402220ACF962A3BA
- E274B0AAC67169CDB3C278FA0AF4CA13B0391F9D2C9D3E617AC33315DA52CC0A
- ED70F1E83B434CE08ABEBF6700147D87B1BF97F1FCAA8294144DA6C522B7E8F5
- 72755C1CE6E52A30E9F52CD96C86AEDE5E68C7A027011DDF9EBA73FE26AFB7EE
- 75B7705BA700352A06FAF8806B6A9ED1C2BB3023A4AD29D12FA83819146566CB
- CC1A0DAF44C6A8E47248329820CF9A0171020F157FB900DDA7FA207EB20E64EA
- C87605B0B7D9A0BBDDC69EF929DCD6DA097599295070F334B8C79C9C8AC2C27C
- 4422BEAFBB0BE303F403EE3EACEB42EF7C1CFB57225F6A02530096BFC4D891C9
- F1F1138AB2B2544430B197D4DC81B9BD1F131C52233A87F3ACE13760072F9C0D
- 357ABDF5AFBA84D9BD784251DF273E78A13518AA3968ABF5C7EBB4A22978B058
- 0D26461AA1C47583587B701DEC009FD70B26D4A839E38A41598549D3AD27A1F7
- BC4354693F8EB5D4D506DFDF0AAF575E82985822C604B0781C0EE8EDB8041E57
- BB34231623326034C0ECC7197B6F544A8A3CC564A2005FDCF4B99616D7C99A9A
- C0F1A6265B39D6B5369B20C6FF680E29090920F84302123F2B423CC183C9E18F
- 5DC2DC56BFBFF990ADCE6FC21881E449A7338F52DF5351EEDB5F79124EB5D6C2
- EE8A5370BE056D1F9F17406247255B213F39038E3D740E5C4D1E68AEA90E7576
- 0BAD6FBD0F4392A8C8D1487BA5B639250D728AEF0663CA2469462C2ECB0094E5
- B86FA3DA67A3BA6B50D549A13AFBFA84330D0DBE0F5DAE379F12849C758290FC
- 3840BACDD1E7226D08A0F4E2311902743E7102845F1646A1078FE5D75CC29C4E
- 9FD751DED12888DA848CAB6A6880A0D9C3177F5A2A2CAEFC11CCDC3C1782A383
- A84995D08DEB52789B8EC994353E198E3E70061C2DDDDC0F7F2B3CE8F182535A
- BA1F11C9C7C40B2338C161198092916F606C4BBAD1186750ABE96D3674F6F60A
- 551D1DDD2F09C2BCFF06F846274003CDC524B3F5B8009FB8A457DC0C09E2140A
- 37F90DB16310BA04A83FE216FEC8042EC491EAA333B4BB7B83FA79712CAD7039
- 0BB8CF435C5A0F14BD9E0705DFCF84D3B555388ECC254D48CB00336F848BAF70
- B6C315B0455A3206C3134FD7A46B43312C03E660106690C9F4897A3D3A7C465E
- 1E6A3B3A3C44FC4580FDD2B47ED805A1D91B0C06C80FF0C8805020208B306838
- 3486E074D02F78224710668C7CF29839B8173C22FB8EF46F3E69613C8C7D390B
- 4ED75481077D8D1F1951945B00CA56661C0530EC9F7C44DB3F114EFEC2ED6847
- 060E7C2B88C61006A0F4657732F6626E62A2983E91E25CB2D97C3F178495F500
- A7A86F30F239AEC4A052C942F460BC66C1605C1BDE161E1D0A1AA3AFCAA2DF40
- A6693153F3D6FBC1DB436F76C37F811221C4B2C008990F27C1A9FA2A51BBD0FB
- 424156167F0FCF8B81CF6044C7FFD4EE6A6D81DAF24D606F3D21CD88C5100620
- 5B57EB50FA71E898E881ED3D3DA16A8023270186FDB88687AA3A531026A95095
- 15788F0739EE67CC85C66997A60C0132A01A53443C01F1BC4675D5C6A9C0B6E5
- 04047D6D319B8FB4ADF7258017FFF5389DE0F778607446069F2F08A55900433C
- 5B987103F71B9392216BC20A884F9928CD88C510069431B6263D3E5E4DD294A1
- 8DB6D8ED817743A16F4BC343700B634F6050C428CAA3AF448D9D9D810AE8B74F
- D2F22185CCC3AD659DAD5DE11741894623781A7BA1630FBD340D6F1E1BFD6D7B
- 4733A89608BE9375756E3249864CCBB15AB952807BC505A21066DA00F3C8CFC8
- 957A0C8E06BE60456308039218CB2569D28328642546A0DD1F908609740F9D60
- 723D40DA520C61D32D16158FF778F19EBACE4E784F105EC571DDE54A7A0A4C36
- DD153256DA9A0129128F3B537C229CD9D80CAEDE00787D68BBFE20040302B8E8
- 1CEFEA80BFD4082F7B5C2E051114447F60D6E964993C3F0ED78B8148B8E804A9
- 509B18117E7F301C621880E2617A3CDA22DFFFDD78E6B7305685F290E3309E59
- 407E412CA8FA094F73DC16637CBC5286C4FB50FD2FD86CC1538CED6A02407721
- 124B316C0CF1B8FFF8A757B17734D352C06F8883BA9E1E7013033075F6A2D11C
- DF50074E47009C6E0CB49C01A8BD581F387E961D7CF7106CC473C6E745E2E9DD
- 821683A414743FB8660CFA09EF273ECC0CBC9066C42286010680642608F238A5
- 12145802E474004877E85337D562410EA4AE67EC8334B53A37D56251F891AA4E
- F4D0D51D1DC2E650E8E73887088F101FC38465F3E0194B0257109FB94466B9BF
- 08CEB536820309A217E6D9A999D075DA03953F6902672FE604CDADE074FA42AF
- FD4E7812E95106D141D39F51F9F082344E83C2C24B32AB7E0C101F26BCA7DD06
- F5959F40B72DFCF7028311CD0086D97617AAA4B30F553F888B10130C829061C1
- F41CC7E598096AF0705FFE3C6307C7E97493F2535294F4973D0EF4CC476B6A7C
- 1F0AC246947E1D7691964433412CD9A930ED9699B04E97348BF30590C9137A40
- 354303C7EAAB81FE4C829C6E813507BA0FFAE0D8BA6A683AD02974F540CFFDB7
- C38B2F2E862D8C67320135135043DB5073C0C2022FAF878F7EF0387CB4FA56D8
- 804B200762B5408EA9B7363E1DE47146717830A2B94776CD7F9DB1CD8B131296
- 24A14A92D2D4757404EBBBBA7CED8CD59830FAC3B89DE522E16A640E4571212C
- C7AAAABC3B83C177FF2E086F44D6C142CCEDAF917BCA0D6BD9DB19E9A9C9D6D1
- 4BB8A0FB02C60B8DE260DD1B3608550B30212317785471B2739BDD0E0D6D2DC0
- A1F1C599D11FB58460D69871A0C13103265E47CE9683AFB41B12972B681BC021
- 25549B2C49C4495C55023241A92FC65CC0010DE7FE3E241B8C6680B8510C821E
- 7A402EDF589C93A316B9881CA720C4835A417FBA46890B690787ED1E0C90CE36
- 367A8F06839FA3E37B8EEE97D6195CC437BB374D97AFCC1C7B17C7313C2A9DC7
- E975376E1C7FD056AB5F4162DB3828B466830629415314BF1EF9F1B9B4490D3D
- 1BFBD4186A63E2015B0FEF87B13F4D057D81525C87470E3046E217FF23FA1BC8
- 8089E0713AA0F1C21723A6C3345D6804A8C0737D0AD7D797916A36CB31140439
- 3E90E2023A16E9ACA76CED425393AFAEADCDBB29147AE90B809FE1BDF43A9C4C
- 395253114DB630078A1F5C06DFB18E9ACF69F54920B88F819C0F6261A4CDA050
- 30B0946921E40DC0A57D0DA8011C249B13E8E50B28F0F96A7A2E4ED4190C1040
- DBDE75E23024DFA1C348512B3290241F219E80628B3444F0CA2408F8BCD0D755
- 3D241D8ED6807EE07A3C66817F29E6B825069D8E99B45A25491F252EB4F4F5B9
- BC6EB7E21866B8FF8352C700930E739232AD4525D226304D1CE87FF66DB6352D
- 23D79C9A772BEF7560C0E30D7FAAA6AC9DC44712A436A9B1A7D50F0DAF7780AB
- CA0766931E2C5A3350E6E8C420A8D36987F6F64E48B9D300196B8D61D5428804
- 4BC4F6932FFD78282463262C0AE86C393DA209C48098809E6F2E9E3333C673DC
- 7C7421A96704610F96BD1730E5EF081F75743F95680644D614DBDF5803BF9C3F
- 43F5959C890FCA84A01D3CBD474482C936C55A82C8042AB869AADD757E709E71
- 83B3DC0B9E8B3E5065C84157A400DD381568C6200D972158FC8D6A3BBAED1040
- 4F2D5318A0D7DE70E50CB80A44D6A03AA63DAB186E472FFDBEB57025A8F45670
- 776E4573F789F64D3368126D53BC49BC0E6F3A0C6C4B97234958FC8D6A47FAA5
- 2B71304E3F1E3C6E17B45CDA398401112DBA1ED0B3A8D0A141F62FFA00A31E8C
- CF3DCC7E634E9B2018124641C875021D950F641C9EE1E879D0CC51E549ED49E2
- 58E876A2048B788C8941CC306DAAFB039C701B7F86F68BD7917EACB10C0791F9
- 3718C454FEB5AFC387B3A6E816E64D5E2B634C06413FBA0ADA5CBF6CA48D8B4D
- FAA5EB704D9B0E23CC94F01CE9DEF085D4A68B701D734DBF383F0C6432AF0377
- 5F2BB4D6EE250DA0889606C58937920174A28865C92C58F3DDB5F0A6C152086A
- 43A63828ED4BAA8830B1310069F36225224C40CCB408A1523B1A030CA08BC8D8
- C01C8FB31DBADBCF1303E82FDA494BE901C11BCE808478B0FEEE4538A8D3C0C0
- 37F201FC3334EE7288E510C2EB03CFA27540E173C4546F280322104D20AA44AE
- A3EB48A16BDA43741F5D470A81EA6891461792E2E54ABF9407D5149F502DAE19
- 79C83F13F48C680207134DEDE10A215247206E5AAAA34B8420AA2F5786C5E007
- FC7F237A3F97DB1B111A5DFF1BD70E80FF059FD1E90533117C87000000004945
- 4E44AE426082
- }
- Banner.Color = clHighlight
- Banner.ColorBalance = 0.5
- Banner.Height = 80
- Banner.ImageBalance = 0.5
- Title.ParentFont = False
- Title.Font.Height = 20
- Title.Font.Style = [fsBold]
- Title.Text = 'Image Strip Editor'
- Title.X = 0
- Title.Y = 0
- TitleSub.ParentFont = True
- TitleSub.Text = 'You can change the order of images by holding shift while dragging the mouse'
- TitleSub.X = 0
- TitleSub.Y = 0
- object OKButton: TButton
- Left = 365
- Height = 25
- Top = 360
- Width = 75
- Anchors = [akRight, akBottom]
- Caption = '&OK'
- ModalResult = 1
- TabOrder = 0
- end
- object CancelButton: TButton
- Left = 448
- Height = 25
- Top = 360
- Width = 75
- Anchors = [akRight, akBottom]
- Caption = '&Cancel'
- ModalResult = 2
- TabOrder = 1
- end
- object AddButton: TButton
- Left = 448
- Height = 25
- Top = 88
- Width = 75
- Anchors = [akTop, akRight]
- Caption = 'Add'
- OnClick = AddButtonClick
- TabOrder = 2
- end
- object RemoveButton: TButton
- Left = 448
- Height = 25
- Top = 120
- Width = 75
- Anchors = [akTop, akRight]
- Caption = 'Remove'
- OnClick = RemoveButtonClick
- TabOrder = 3
- end
- object SaveButton: TButton
- Left = 448
- Height = 25
- Top = 152
- Width = 75
- Anchors = [akTop, akRight]
- Caption = 'Save'
- OnClick = SaveButtonClick
- TabOrder = 4
- end
- object ClearButton: TButton
- Left = 448
- Height = 25
- Top = 185
- Width = 75
- Anchors = [akTop, akRight]
- Caption = 'Clear'
- OnClick = ClearButtonClick
- TabOrder = 5
- end
- object Grid: TContentGrid
- Left = 8
- Height = 256
- Top = 88
- Width = 432
- DefColWidth = 75
- DefRowHeight = 25
- ColCount = 5
- RowCount = 5
- Anchors = [akTop, akLeft, akRight, akBottom]
- BorderStyle = bsSingle
- Color = clWindow
- ParentColor = False
- TabOrder = 6
- UseDockManager = False
- OnMouseDown = GridMouseDown
- OnMouseMove = GridMouseMove
- OnMouseUp = GridMouseUp
- end
- object OpenPictureDialog: TOpenPictureDialog
- FileName = 'C:\Development\Pascal\Components\Codebot.Cross\palette'
- Filter = 'Graphic (*.png;*.bmp*.ico;*.jpeg;*.jpg;*.tif;*.gif)|*.png;*.bmp;*.ico;*.jpeg;*.jpg;*.tif;*.gif|Portable Network Graphic (*.png)|*.png|Bitmaps (*.bmp)|*.bmp|Icon (*.ico)|*.ico|Joint Picture Expert Group (*.jpeg;*.jpg)|*.jpeg;*.jpg|Tagged Image File Format (*.tif;*.tiff)|*.tif;*.tiff|Graphics Interchange Format (*.gif)|*.gif'
- InitialDir = 'C:\Development\Pascal\Components\Codebot.Cross\'
- Options = [ofAllowMultiSelect, ofEnableSizing, ofViewDetail]
- left = 56
- top = 96
- end
- object SavePictureDialog: TSavePictureDialog
- Filter = 'Portable Network Graphic (*.png)|*.png'
- left = 56
- top = 160
- end
- object Images: TImageStrip
- left = 56
- top = 224
- end
-end
diff --git a/source/codebot.design.surfacebitmapeditor.lfm b/source/codebot.design.surfacebitmapeditor.lfm
deleted file mode 100644
index a269437..0000000
--- a/source/codebot.design.surfacebitmapeditor.lfm
+++ /dev/null
@@ -1,393 +0,0 @@
-object SurfaceBitmapEditor: TSurfaceBitmapEditor
- Left = 657
- Height = 464
- Top = 169
- Width = 610
- ClientHeight = 464
- ClientWidth = 610
- Constraints.MinHeight = 288
- Constraints.MinWidth = 404
- KeyPreview = True
- OnKeyDown = FormKeyDown
- OnKeyPress = FormKeyPress
- Position = poDesktopCenter
- LCLVersion = '1.5'
- Options = [boReanchor, boBannerShadow, boFooterShadow, boFooterGrip]
- Logo.Data = {
- 89504E470D0A1A0A0000000D4948445200000040000000400806000000AA6971
- DE000000017352474200AECE1CE90000000467414D410000B18F0BFC61050000
- 105349444154785EED5B0B7054D779FEEFDDBBEF87DEEF0792D00304081038C2
- 40B079D8026C6CE21093FA417067D236E371A9E369DD76DC36D3349D76324D89
- 63BB766C17E27AA8E3D84EDCC66986006E5DC0A62E36102424052181A4D5FBB5
- ABC7AE76F76EFFEFE81EBA5A5620620CC2E36FE69F73EFDD73CE3DDF77FEF39F
- C7954CF41983AA90A53CC3F4B0C7A614FB02D17351A288F153422846FA998055
- A3D4AD0B2D8793EDCA3CDCB70CE86FEE6F0C7D45FC380D5423BDE9613191E79E
- 059643596EB5F49BF7552BEBCAAC4A71AABACDF8795A7C2604D05472DE5D69D9
- CFE42B77DE6237EBBD0DD4D813D6C743D14E23CBB4B8E90530A964DB3CDFFC4E
- 8E47A97EA8DA66765A14FAB02D441DC311F5D0D9F04E23DBB4B8A905E08067AE
- AD30FF2C2F495DB57D89CD9CEE54A975204C1F9C0F851B7B227BDA87F4FD46D6
- 6971D30AA02864BAA3DCFC7A618ABAFECB5536AD20D9445E9F4EFF7D2EA48F4C
- 44FB8FB6861F37B25E1637A5003C75A9EB4AB55738C86DB977814D2B4B67F2C3
- 3A9DEA0C51EFA8AEBE7B36FCC84484868DEC97C54D29C09AB9DA0BA5E9A6AF6E
- 9A6F352DCA99ECF9F3433A9DEE0A879A7A233F6A1BD2FFC3C87A45DC34EB0093
- C5996E76672FAE28CEFB2B5752CE6ADD55A0E8AA8D6CCA38D9743F05C77D516D
- AC7DE4E8C9867563BEBEFF358A5D11B35E0067EE9207D32A37FFBD6A71E7E1DE
- A229E472BBC8E676936AD228140A516822441381711AF38FEA7A94D4D0686F5D
- FFE9B77705FA9B0F8A4A2E83592D40EAFCBBFEC153BCFA9B058539D1ACDC6CC5
- EE745049B693FA7C411A0BEAE4B2A9D43918A07044A708338F8423343232427D
- 1D9D9131FF88A9FFF44F7FDF7FE17F7E68549710B33606C0E53D452B1F5B5855
- 41B7DEBA48299B9341168B99AA0A9DE4B66BA499144AE2740A786AB03B9D943B
- B7C4E4494FA5948ADAEF18BF4C8B592B806A71A493A29AD3D253788DAF907A95
- 2DB53A9CA49AB98E2BE0A69C05AE2566AD00BCAAAB362EA72012E1B1CEE35D8F
- 462918D28DA7BF3D66A500690EA5EAB652ED45E39626C2511AE5A007FCE2E400
- 750D4DD0F8844E17FA03E2D927C1AC13C063534AB6F0B636DDA65B713F3E1EA0
- E1B13079BB7DE4F5F651E78536EA696DA2FEE613347CF618F95B4FD088F72C8D
- F676D2E8908F82812045D93B22E13051540F894A2F8359350D3A2C4ACE7D8BCC
- C7325D6ACEFD8BEDDA3FF6DE4FA7274AA932638CAC810E8A86C6989CCE0151A5
- B4B434CACDCDA7BEFE5EEAE9EE16EB0101CD4601C54D27FB33C383E73E786EA0
- FEDF774DFE9018B34600AB46295B175A8EF29E7EEE57AAACE692348D7EDD6FA3
- 97BAD75149490E3DF1C413E4E429CE6AB592C964E219EFFF9B8E1ED7759D2626
- 26281008D0BE7DFF4A6FFFF2BDE683BFFC59B51E0EFA8C6C09312BCE0435951C
- 5B2A2D0771A0B175A1D53C2F4BC37E9E3AFD3AB59BE6D05F7CEBDB949999C9EB
- 008BE8FD58F200EEF1DC6C3693DD6EA7EAEAA574FAE487C97EDF70B8BBBBFB3F
- 8D6C0971C305C09E7ED37CF3CF7393D4157755DACCD57920AF53076F700E0796
- D017EF7A8056AC5861E49E1920C6CA952B9513274EAC191818A81F1E1EAE377E
- BA04375400EE47757DB9795F518ABAE9CE0AABF99602337571AFA3F74FF933A9
- DBB5949E7CF24941082E1E894484058341F2FBFD343A3A7AD1B00486610820AF
- C3E1604FA8569A9A9AEE397FFEFC6B3C3C068CD74EC10D9D05569768CFCE4D53
- BF7C5BA9455B5EA051FFA82EF6F51DBE28FDC6B28C76EDDA25DC1BA430CEA5AB
- 4300908508DCBB34383848FDFDFDD4DBDB4BEDEDEDD4D8D84867CE9C11C32129
- 29C9C201735A17BA6102DC52A07DBB32CBF47B2BE6584C2B0ACDE40F46C5BEDE
- EB8BB0002A85A226345E0436495E223E062482142D393939C4C1B3C0787C096E
- 88008B724C7F549D6F7AAA3ACFACAE2E365390173AE8F9490174EA1C9D1C9908
- 6A0088C4DA4C80A182BCE9E9E90A0F8742E3F125B8EE0294679876AC2CD2BE57
- C9917ECD5C8B7826897B79EC23D5CC93BB3C08C0AB5EF28D8769341016A98F17
- 45CDBD417AAFD14787CE0CD181BA013ADC3848C75B86A9A1C34F17FAC6687064
- 42940FF362282B2B4B73B95C73C48304B8AE41704E8ABA6543B9F9B5D2344DAD
- ADB0909D777932E28B940DD0AC8E683079BE52BE7C03FDEA541FB5F40528D969
- 15670063BC046EF08ED091C67E263B4EE77BC7A8B96B84EADB86E9E396413AD6
- D447EF9DEEA22367BA282BCD43E15058696EACD3392E3C232A8FC375F100A7D3
- 919EE351D7DC59617E333FC9A4DCC9E45D56C5E879EE75E1FE11C2DE06CF03BA
- 468AD9CE4383D810FDA31408452E1A8E7DAE04DF5888EA5AFB69386C4730CC37
- 1E5F82EB22C0E38F3F56F78DC71E7D377FD12AD31D0B9215DEEC4C19F3B071F6
- DA14BB42BE804EF57DEA8BAA66E1159F4261261F66C2530498591860118264B5
- D93073387938B98DC753F0A90BC0111B3397C995314775546C503FCCFA5D6A08
- 6409D298EF9182749A53A1A1713D72AA33F2BD4EBF7AD86CB547155E2984794E
- 8708D8FA4AC3767826F08D06C866137B2AAC0B1206C24F550026AFEC7C64C7BF
- 395C9ED43CDEB8AC5EB5969CE905F451C603D4A69508F27D3CF767B8541A0EE8
- E1F383FA3B1FB486FF58D334B7CDE1120141EEFF0313DCFB86CD6408007E0860
- E180CA1B249E0AAFBF005F5CB3FA898A79E59B165656291B6B37D1E2C58B69C3
- FA8D94935B48C1B22FD1909A41594C7E24A887FA46A3A70E3485BECAD474B8AB
- DDE1122CE1FE11F682D82180673301860060F7A446D80312AE053E35010A0A0B
- 6A366DAEFDBB82FC4275CE9C22F2783C626586054A667A16EFEA1C54B2F6410A
- 46B5B02F18ED79A73EB489E3DD38CAB207B86C0EA7A8071E30190320C2A46158
- CC041802803B292D7A5D3DC066B3253DBCE3C137DD6E0F55CE5F28C863B9EAF5
- 7AA9ADAD8D7883C20215936A7191396F49E4E775A13BC643D11EA338E67FB7DD
- CE418101B21021C8AE2F8D5738E4B4AA94E2D0C865339189775489109C08D304
- 7B8C27394D9DCE033E9575C0EF3CB07DDF9CC2C2EA9A9A955AD5A22AB18F6F69
- 6921DE94505F5F9FD8A8343737F2D08EAAE4C9F61FFAAF0FFE9237303CE94DA2
- B0B070DBE2156B972E282F5692EC2AAD284DA2AA02279567DBA822DB4A155916
- 5A5A60A365454EAA2971D3EA8A64BAB52C99969724D392A2249A9FEF26975DA3
- 119E5A0AB353498F4C281DCD75FEE6E6E63DC62B2EE29A7BC08A5B6BBEB16061
- E597162D5A6206791C5EB4B6B68ACD0A0C071AFD03BD7A9897AA7B5EDE7BD73F
- BFFC2FB598298CE202F080141A50CA739CB4AA3C99F252AD64352BF85B806997
- C3164DE5C592997253ED5491E7A1BB97E7D39F6EABA295F3D2A9242789DC6E77
- 9191750AAEA9003939D955F7DC7BF7F70B0B8A949A2FD488318F5EEFEAEA12E4
- 796C93B7AB3DECEDF406F7EE79654B63E36F7ED1DED6FE216F78468D2A0458A4
- 64F6928B7E2D49C3B0D54D24C074C0378582CC641CA664F3ED2563E59A09C02F
- 70EEF8DA433FF5B83DCADADBD7514A4A8AD89A76747408F238CB3BDFD612EAEE
- EE1A7CEED9E7573536344DFB0597EBF240BC58A2B1225C8D00D80F70EF634AD6
- 383665198F2FE29A09B0F5BE7B9F4B4D4B2DACBD73B3969D9D2D7A1DBD0FF2C1
- 8920B55E6809757ABDE7BEBFFB9965DE0EEFC746B1848000182A1292B4EC7DEC
- F4104B2E5CB8C0B1A45904579C0B24120687A5884140A26DF13511A0BA7AE9C3
- D5D54B76ACBB7D833677EE5C11E5D13090F78FF8A8ADBD35D27CF6ECE1A79F7E
- F60BC343C36D46B16931390BD88DBB494811701072FAF469212EDE3336364643
- 43434270CC30383F88053C006789DCFBD144ABC14F2C4046467AC57DDBB6BEB0
- 70C1225ABAB45A1C4F35343408F2FDFDBDD4D9D5113D7EFCE3575F7A714F6D30
- 70F9135A090E9C4E78407C8F826C7D7DBD381142708D37780684C05A430202B0
- FB63488613AD053E91001CD4AC0F7FEDA1B7B232B3CC776CA815EE8606827C87
- B79DFA067AE957FB0F7EEB273F7E632737EE8A1F2924B079891D0200DC1FBDCE
- DE216612F42A0CF7D21064613E9F4FE407200090919181E9F7930F81A4A4A465
- 4545457F505E5EFED4C64DB56FA5A6A654DE7EFB7A0D2A837C4F4F0FB5B436EB
- C3BEC1C8EBAFBDB1E3E081437F6D149D113025B231C7A902A067414A1297E465
- 0AE232C5EE0B9E08C898919999A9B1075C723032E385108FC9B2EAEAEAB7783D
- FFB7C5C5C577E7E5E5AD5355535947BB37DAD27A4E773A1C6A4F6F0F359D6D08
- 8F8CF8C7F7BCFCA3CDF5F567DE368ACF184CC2BD60C1823FDBB0618388DE208D
- C34F1C784A570741B1C58CB98E371933708D7A38482ADC41C1A6A6A6178C5709
- CCC80398FC0226FF1EBBD16D656565B47DFB765ABD7AB57045EE2DE5D7A74E9B
- 7EF2C6EB9186C6BAF0E0E040CF333FF8A79AE6E673EF1AC5AF0A1000297A1680
- 001852B13D2F4DBA7CBC49A1501686618003D6DF2A087283F22A2A2AF6738A85
- 04E5E7E78BCAD903C4EF52E9BABA33135E6F67DDD3BB9F5DD6D3DD33ED87882B
- 81094C1100AE8CF749D270731888CA349EB834F4BE1400FB11CE93C2CF262B36
- 703901D0B99E82828277B8602E7A1B9FA73EFAE82331C51D397244445B548E31
- 16180FD87FF8FC4B8FB0BB8E71598F61200373B1613276B0617EB3B16190E3D8
- 17C3F0E20A8DDF85BC821C8445C4C7F54CC983B44C61CC410467974B548B13E2
- 29C76310002F4723A00C1A86462277525A5ADA8FB9F2C57C4DF3E6CDA3DCDC5C
- EAECECA403070E880F0FE3E3E34204CCBDE2AFB54221D4154B3E56845843FD89
- CCC1C4523915A4202E48C4938549C2B16461F1F75200262EEEE3A74234188421
- 0444402AAE79E1F037C9C9C95F47411C64A4A7A78B4D0D7A040D40C5702F540E
- 017881D2CD41663D979593776C8A39293E9526F3291C63967300FC43167AEDCA
- 952B8567C1E43003E475BC4DF71B0051B01A3C71E24494578D87CF9D3BB79777
- A7AF72FB27204012F2C41804D8C9C4BF83D558494909BEAE88E90DA4A5FA5200
- 341022B067ECE348FD032E2B2189CA34DE00E9FA517E57E6D6AD5B0FC0CB3860
- 99D05B570B493816B1CF8C78A0636B7EECD8B147CF9E3DFB3C1A00978B15601D
- DB1E763B13C63C08C315E518940200A85C8CFF40A097D7E58FF2B5FCFB5CBC15
- FFAA02A248E5B5241E0BE45538B8AE617C77F7EEDD58B65EEC41692263DCB32B
- D97465F6EEDD1B3974E8D09B1CC71E8C97B99CED39361348A3D7310561ACC3B0
- 1485C92FB2305E75F1A6AFFDCF993CBEBE4A92208C164893901E26C5C6272004
- 42A4E27390FCF0196F580BC012FD369D4D979F818E17EF4763D058AC1793D95E
- 614330124AC1B5A7211FE10DC8F1EEEEEEEFF276F77ECE77928B609D2FCD6F18
- DE865901865D0A0CEF8249CF906209246A70AC5DAD1089F2A3731910411CA621
- F2438D4A36FCB391EC0DD94310C9CF631E84043916678853ACEDA507A11E9884
- 2414EB05C80B132F8EBB565253532B376EDCF86A4D4D8D384B00A4CBCA6B99CA
- 6B20FEFE4A401C78FFFDF7431C109F617B4A361A2908CB86C5DAC546C6A4F106
- C814886D11AEE53DCAE33DC82B5359A789579B7F525A5ABA8D03E0E467E16B00
- 1647BC1B41DB40B4AFAFEFF8D1A347BFCE1E7D21B6D18980DF6523139107E253
- 09493A3685C5D6152B3AAEA5C97BF91B0CF99102F25DB24E18620F520CA9D858
- 74390BC737FA7A0204E5108B252E0DF7927422F212B1224821620D44E3530401
- 5C5F52D98D422C69790D43FBE20D902908CB349108F25AF638EEA74056341B11
- 4B36D600994A429278AC7D8ECFF1393EC71540F47F2A39B2C39E732535000000
- 0049454E44AE426082
- }
- Logo.Data = {
- 89504E470D0A1A0A0000000D4948445200000040000000400806000000AA6971
- DE000000017352474200AECE1CE90000000467414D410000B18F0BFC61050000
- 105349444154785EED5B0B7054D779FEEFDDBBEF87DEEF0792D00304081038C2
- 40B079D8026C6CE21093FA417067D236E371A9E369DD76DC36D3349D76324D89
- 63BB766C17E27AA8E3D84EDCC66986006E5DC0A62E36102424052181A4D5FBB5
- ABC7AE76F76EFFEFE81EBA5A5620620CC2E36FE69F73EFDD73CE3DDF77FEF39F
- C7954CF41983AA90A53CC3F4B0C7A614FB02D17351A288F153422846FA998055
- A3D4AD0B2D8793EDCA3CDCB70CE86FEE6F0C7D45FC380D5423BDE9613191E79E
- 059643596EB5F49BF7552BEBCAAC4A71AABACDF8795A7C2604D05472DE5D69D9
- CFE42B77DE6237EBBD0DD4D813D6C743D14E23CBB4B8E90530A964DB3CDFFC4E
- 8E47A97EA8DA66765A14FAB02D441DC311F5D0D9F04E23DBB4B8A905E08067AE
- AD30FF2C2F495DB57D89CD9CEE54A975204C1F9C0F851B7B227BDA87F4FD46D6
- 6971D30AA02864BAA3DCFC7A618ABAFECB5536AD20D9445E9F4EFF7D2EA48F4C
- 44FB8FB6861F37B25E1637A5003C75A9EB4AB55738C86DB977814D2B4B67F2C3
- 3A9DEA0C51EFA8AEBE7B36FCC84484868DEC97C54D29C09AB9DA0BA5E9A6AF6E
- 9A6F352DCA99ECF9F3433A9DEE0A879A7A233F6A1BD2FFC3C87A45DC34EB0093
- C5996E76672FAE28CEFB2B5752CE6ADD55A0E8AA8D6CCA38D9743F05C77D516D
- AC7DE4E8C9867563BEBEFF358A5D11B35E0067EE9207D32A37FFBD6A71E7E1DE
- A229E472BBC8E676936AD228140A516822441381711AF38FEA7A94D4D0686F5D
- FFE9B77705FA9B0F8A4A2E83592D40EAFCBBFEC153BCFA9B058539D1ACDC6CC5
- EE745049B693FA7C411A0BEAE4B2A9D43918A07044A708338F8423343232427D
- 1D9D9131FF88A9FFF44F7FDF7FE17F7E68549710B33606C0E53D452B1F5B5855
- 41B7DEBA48299B9341168B99AA0A9DE4B66BA499144AE2740A786AB03B9D943B
- B7C4E4494FA5948ADAEF18BF4C8B592B806A71A493A29AD3D253788DAF907A95
- 2DB53A9CA49AB98E2BE0A69C05AE2566AD00BCAAAB362EA72012E1B1CEE35D8F
- 462918D28DA7BF3D66A500690EA5EAB652ED45E39626C2511AE5A007FCE2E400
- 750D4DD0F8844E17FA03E2D927C1AC13C063534AB6F0B636DDA65B713F3E1EA0
- E1B13079BB7DE4F5F651E78536EA696DA2FEE613347CF618F95B4FD088F72C8D
- F676D2E8908F82812045D93B22E13051540F894A2F8359350D3A2C4ACE7D8BCC
- C7325D6ACEFD8BEDDA3FF6DE4FA7274AA932638CAC810E8A86C6989CCE0151A5
- B4B434CACDCDA7BEFE5EEAE9EE16EB0101CD4601C54D27FB33C383E73E786EA0
- FEDF774DFE9018B34600AB46295B175A8EF29E7EEE57AAACE692348D7EDD6FA3
- 97BAD75149490E3DF1C413E4E429CE6AB592C964E219EFFF9B8E1ED7759D2626
- 26281008D0BE7DFF4A6FFFF2BDE683BFFC59B51E0EFA8C6C09312BCE0435951C
- 5B2A2D0771A0B175A1D53C2F4BC37E9E3AFD3AB59BE6D05F7CEBDB949999C9EB
- 008BE8FD58F200EEF1DC6C3693DD6EA7EAEAA574FAE487C97EDF70B8BBBBFB3F
- 8D6C0971C305C09E7ED37CF3CF7393D4157755DACCD57920AF53076F700E0796
- D017EF7A8056AC5861E49E1920C6CA952B9513274EAC191818A81F1E1EAE377E
- BA04375400EE47757DB9795F518ABAE9CE0AABF99602337571AFA3F74FF933A9
- DBB5949E7CF24941082E1E894484058341F2FBFD343A3A7AD1B00486610820AF
- C3E1604FA8569A9A9AEE397FFEFC6B3C3C068CD74EC10D9D05569768CFCE4D53
- BF7C5BA9455B5EA051FFA82EF6F51DBE28FDC6B28C76EDDA25DC1BA430CEA5AB
- 4300908508DCBB34383848FDFDFDD4DBDB4BEDEDEDD4D8D84867CE9C11C32129
- 29C9C201735A17BA6102DC52A07DBB32CBF47B2BE6584C2B0ACDE40F46C5BEDE
- EB8BB0002A85A226345E0436495E223E062482142D393939C4C1B3C0787C096E
- 88008B724C7F549D6F7AAA3ACFACAE2E365390173AE8F9490174EA1C9D1C9908
- 6A0088C4DA4C80A182BCE9E9E90A0F8742E3F125B8EE0294679876AC2CD2BE57
- C9917ECD5C8B7826897B79EC23D5CC93BB3C08C0AB5EF28D8769341016A98F17
- 45CDBD417AAFD14787CE0CD181BA013ADC3848C75B86A9A1C34F17FAC6687064
- 42940FF362282B2B4B73B95C73C48304B8AE41704E8ABA6543B9F9B5D2344DAD
- ADB0909D777932E28B940DD0AC8E683079BE52BE7C03FDEA541FB5F40528D969
- 15670063BC046EF08ED091C67E263B4EE77BC7A8B96B84EADB86E9E396413AD6
- D447EF9DEEA22367BA282BCD43E15058696EACD3392E3C232A8FC375F100A7D3
- 919EE351D7DC59617E333FC9A4DCC9E45D56C5E879EE75E1FE11C2DE06CF03BA
- 468AD9CE4383D810FDA31408452E1A8E7DAE04DF5888EA5AFB69386C4730CC37
- 1E5F82EB22C0E38F3F56F78DC71E7D377FD12AD31D0B9215DEEC4C19F3B071F6
- DA14BB42BE804EF57DEA8BAA66E1159F4261261F66C2530498591860118264B5
- D93073387938B98DC753F0A90BC0111B3397C995314775546C503FCCFA5D6A08
- 6409D298EF9182749A53A1A1713D72AA33F2BD4EBF7AD86CB547155E2984794E
- 8708D8FA4AC3767826F08D06C866137B2AAC0B1206C24F550026AFEC7C64C7BF
- 395C9ED43CDEB8AC5EB5969CE905F451C603D4A69508F27D3CF767B8541A0EE8
- E1F383FA3B1FB486FF58D334B7CDE1120141EEFF0313DCFB86CD6408007E0860
- E180CA1B249E0AAFBF005F5CB3FA898A79E59B165656291B6B37D1E2C58B69C3
- FA8D94935B48C1B22FD1909A41594C7E24A887FA46A3A70E3485BECAD474B8AB
- DDE1122CE1FE11F682D82180673301860060F7A446D80312AE053E35010A0A0B
- 6A366DAEFDBB82FC4275CE9C22F2783C626586054A667A16EFEA1C54B2F6410A
- 46B5B02F18ED79A73EB489E3DD38CAB207B86C0EA7A8071E30190320C2A46158
- CC041802803B292D7A5D3DC066B3253DBCE3C137DD6E0F55CE5F28C863B9EAF5
- 7AA9ADAD8D7883C20215936A7191396F49E4E775A13BC643D11EA338E67FB7DD
- CE418101B21021C8AE2F8D5738E4B4AA94E2D0C865339189775489109C08D304
- 7B8C27394D9DCE033E9575C0EF3CB07DDF9CC2C2EA9A9A955AD5A22AB18F6F69
- 6921DE94505F5F9FD8A8343737F2D08EAAE4C9F61FFAAF0FFE9237303CE94DA2
- B0B070DBE2156B972E282F5692EC2AAD284DA2AA02279567DBA822DB4A155916
- 5A5A60A365454EAA2971D3EA8A64BAB52C99969724D392A2249A9FEF26975DA3
- 119E5A0AB353498F4C281DCD75FEE6E6E63DC62B2EE29A7BC08A5B6BBEB16061
- E597162D5A6206791C5EB4B6B68ACD0A0C071AFD03BD7A9897AA7B5EDE7BD73F
- BFFC2FB598298CE202F080141A50CA739CB4AA3C99F252AD64352BF85B806997
- C3164DE5C592997253ED5491E7A1BB97E7D39F6EABA295F3D2A9242789DC6E77
- 9191750AAEA9003939D955F7DC7BF7F70B0B8A949A2FD488318F5EEFEAEA12E4
- 796C93B7AB3DECEDF406F7EE79654B63E36F7ED1DED6FE216F78468D2A0458A4
- 64F6928B7E2D49C3B0D54D24C074C0378582CC641CA664F3ED2563E59A09C02F
- 70EEF8DA433FF5B83DCADADBD7514A4A8AD89A76747408F238CB3BDFD612EAEE
- EE1A7CEED9E7573536344DFB0597EBF240BC58A2B1225C8D00D80F70EF634AD6
- 383665198F2FE29A09B0F5BE7B9F4B4D4B2DACBD73B3969D9D2D7A1DBD0FF2C1
- 8920B55E6809757ABDE7BEBFFB9965DE0EEFC746B1848000182A1292B4EC7DEC
- F4104B2E5CB8C0B1A45904579C0B24120687A5884140A26DF13511A0BA7AE9C3
- D5D54B76ACBB7D833677EE5C11E5D13090F78FF8A8ADBD35D27CF6ECE1A79F7E
- F60BC343C36D46B16931390BD88DBB494811701072FAF469212EDE3336364643
- 43434270CC30383F88053C006789DCFBD144ABC14F2C4046467AC57DDBB6BEB0
- 70C1225ABAB45A1C4F35343408F2FDFDBDD4D9D5113D7EFCE3575F7A714F6D30
- 70F9135A090E9C4E78407C8F826C7D7DBD381142708D37780684C05A430202B0
- FB63488613AD053E91001CD4AC0F7FEDA1B7B232B3CC776CA815EE8606827C87
- B79DFA067AE957FB0F7EEB273F7E632737EE8A1F2924B079891D0200DC1FBDCE
- DE216612F42A0CF7D21064613E9F4FE407200090919181E9F7930F81A4A4A465
- 4545457F505E5EFED4C64DB56FA5A6A654DE7EFB7A0D2A837C4F4F0FB5B436EB
- C3BEC1C8EBAFBDB1E3E081437F6D149D113025B231C7A902A067414A1297E465
- 0AE232C5EE0B9E08C898919999A9B1075C723032E385108FC9B2EAEAEAB7783D
- FFB7C5C5C577E7E5E5AD5355535947BB37DAD27A4E773A1C6A4F6F0F359D6D08
- 8F8CF8C7F7BCFCA3CDF5F567DE368ACF184CC2BD60C1823FDBB0618388DE208D
- C34F1C784A570741B1C58CB98E371933708D7A38482ADC41C1A6A6A6178C5709
- CCC80398FC0226FF1EBBD16D656565B47DFB765ABD7AB57045EE2DE5D7A74E9B
- 7EF2C6EB9186C6BAF0E0E040CF333FF8A79AE6E673EF1AC5AF0A1000297A1680
- 001852B13D2F4DBA7CBC49A1501686618003D6DF2A087283F22A2A2AF6738A85
- 04E5E7E78BCAD903C4EF52E9BABA33135E6F67DDD3BB9F5DD6D3DD33ED87882B
- 81094C1100AE8CF749D270731888CA349EB834F4BE1400FB11CE93C2CF262B36
- 703901D0B99E82828277B8602E7A1B9FA73EFAE82331C51D397244445B548E31
- 16180FD87FF8FC4B8FB0BB8E71598F61200373B1613276B0617EB3B16190E3D8
- 17C3F0E20A8DDF85BC821C8445C4C7F54CC983B44C61CC410467974B548B13E2
- 29C76310002F4723A00C1A86462277525A5ADA8FB9F2C57C4DF3E6CDA3DCDC5C
- EAECECA403070E880F0FE3E3E34204CCBDE2AFB54221D4154B3E56845843FD89
- CCC1C4523915A4202E48C4938549C2B16461F1F75200262EEEE3A74234188421
- 0444402AAE79E1F037C9C9C95F47411C64A4A7A78B4D0D7A040D40C5702F540E
- 017881D2CD41663D979593776C8A39293E9526F3291C63967300FC43167AEDCA
- 952B8567C1E43003E475BC4DF71B0051B01A3C71E24494578D87CF9D3BB79777
- A7AF72FB27204012F2C41804D8C9C4BF83D558494909BEAE88E90DA4A5FA5200
- 341022B067ECE348FD032E2B2189CA34DE00E9FA517E57E6D6AD5B0FC0CB3860
- 99D05B570B493816B1CF8C78A0636B7EECD8B147CF9E3DFB3C1A00978B15601D
- DB1E763B13C63C08C315E518940200A85C8CFF40A097D7E58FF2B5FCFB5CBC15
- FFAA02A248E5B5241E0BE45538B8AE617C77F7EEDD58B65EEC41692263DCB32B
- D97465F6EEDD1B3974E8D09B1CC71E8C97B99CED39361348A3D7310561ACC3B0
- 1485C92FB2305E75F1A6AFFDCF993CBEBE4A92208C164893901E26C5C6272004
- 42A4E27390FCF0196F580BC012FD369D4D979F818E17EF4763D058AC1793D95E
- 614330124AC1B5A7211FE10DC8F1EEEEEEEFF276F77ECE77928B609D2FCD6F18
- DE865901865D0A0CEF8249CF906209246A70AC5DAD1089F2A3731910411CA621
- F2438D4A36FCB391EC0DD94310C9CF631E84043916678853ACEDA507A11E9884
- 2414EB05C80B132F8EBB565253532B376EDCF86A4D4D8D384B00A4CBCA6B99CA
- 6B20FEFE4A401C78FFFDF7431C109F617B4A361A2908CB86C5DAC546C6A4F106
- C814886D11AEE53DCAE33DC82B5359A789579B7F525A5ABA8D03E0E467E16B00
- 1647BC1B41DB40B4AFAFEFF8D1A347BFCE1E7D21B6D18980DF6523139107E253
- 09493A3685C5D6152B3AAEA5C97BF91B0CF99102F25DB24E18620F520CA9D858
- 74390BC737FA7A0204E5108B252E0DF7927422F212B1224821620D44E3530401
- 5C5F52D98D422C69790D43FBE20D902908CB349108F25AF638EEA74056341B11
- 4B36D600994A429278AC7D8ECFF1393EC71540F47F2A39B2C39E732535000000
- 0049454E44AE426082
- }
- Banner.Color = clHighlight
- Banner.ColorBalance = 0.5
- Banner.Height = 80
- Banner.ImageBalance = 0.5
- Title.ParentFont = False
- Title.Font.Height = 20
- Title.Font.Style = [fsBold]
- Title.Text = 'Surface Bitmap Editor'
- Title.X = 0
- Title.Y = 0
- TitleSub.ParentFont = True
- TitleSub.Text = 'A surface bitmap can load and save all popular image formats'
- TitleSub.X = 0
- TitleSub.Y = 0
- object BorderContainer: TSizingPanel
- Left = 8
- Height = 240
- Top = 88
- Width = 368
- Anchors = [akTop, akLeft, akRight, akBottom]
- BorderStyle = bsSingle
- ClientHeight = 236
- ClientWidth = 364
- Color = clWindow
- ParentColor = False
- TabOrder = 0
- UseDockManager = False
- OnRender = BorderContainerRender
- object RenderImage: TRenderImage
- Left = 0
- Height = 236
- Top = 0
- Width = 364
- Angle = 0
- Saturation = 1
- Colorized = False
- Mode = imFit
- Opacity = 255
- Align = alClient
- Color = clHighlight
- end
- end
- object OKButton: TButton
- Left = 301
- Height = 25
- Top = 344
- Width = 75
- Anchors = [akRight, akBottom]
- Caption = '&OK'
- ModalResult = 1
- TabOrder = 1
- end
- object CancelButton: TButton
- Left = 384
- Height = 25
- Top = 344
- Width = 75
- Anchors = [akRight, akBottom]
- Caption = '&Cancel'
- ModalResult = 2
- TabOrder = 2
- end
- object LoadButton: TButton
- Left = 384
- Height = 25
- Top = 88
- Width = 75
- Anchors = [akTop, akRight]
- Caption = '&Load'
- OnClick = LoadButtonClick
- TabOrder = 3
- end
- object SaveButton: TButton
- Left = 384
- Height = 25
- Top = 120
- Width = 75
- Anchors = [akTop, akRight]
- Caption = '&Save'
- OnClick = SaveButtonClick
- TabOrder = 4
- end
- object ClearButton: TButton
- Left = 384
- Height = 25
- Top = 152
- Width = 75
- Anchors = [akTop, akRight]
- Caption = 'Cl&ear'
- OnClick = ClearButtonClick
- TabOrder = 5
- end
- object OpenPictureDialog: TOpenPictureDialog
- FileName = 'C:\Development\Pascal\Components\Codebot.Cross\palette'
- Filter = 'Graphic (*.png;*.bmp*.ico;*.jpeg;*.jpg;*.tif;*.gif)|*.png;*.bmp;*.ico;*.jpeg;*.jpg;*.tif;*.gif|Portable Network Graphic (*.png)|*.png|Bitmaps (*.bmp)|*.bmp|Icon (*.ico)|*.ico|Joint Picture Expert Group (*.jpeg;*.jpg)|*.jpeg;*.jpg|Tagged Image File Format (*.tif;*.tiff)|*.tif;*.tiff|Graphics Interchange Format (*.gif)|*.gif'
- InitialDir = 'C:\Development\Pascal\Components\Codebot.Cross\'
- Options = [ofAllowMultiSelect, ofEnableSizing, ofViewDetail]
- left = 64
- top = 104
- end
- object SavePictureDialog: TSavePictureDialog
- Filter = 'Portable Network Graphic (*.png)|*.png'
- left = 64
- top = 184
- end
-end
diff --git a/source/codebot.graphics.extras.pas b/source/codebot.graphics.extras.pas
deleted file mode 100644
index 34bcd24..0000000
--- a/source/codebot.graphics.extras.pas
+++ /dev/null
@@ -1,67 +0,0 @@
-(********************************************************)
-(* *)
-(* Codebot Pascal Library *)
-(* http://cross.codebot.org *)
-(* Modified October 2015 *)
-(* *)
-(********************************************************)
-
-{ }
-unit Codebot.Graphics.Extras;
-
-{$i codebot.inc}
-
-interface
-
-uses
- Classes, SysUtils, Graphics, Controls, Forms, LCLIntf, LCLType,
- Codebot.System,
- Codebot.Graphics.Types;
-
-{ Load a cursor from a resource by name and associate it with a cursor id }
-procedure LoadCursor(const ResName: string; Cursor: TCursor);
-
-{ Copy the screen pixels into a bitmap }
-procedure CaptureScreen(Dest: TBitmap);
-
-procedure CaptureScreenRect(Rect: TRectI; Dest: TBitmap);
-
-implementation
-
-procedure LoadCursor(const ResName: string; Cursor: TCursor);
-var
- C: TCursorImage;
-begin
- C := TCursorImage.Create;
- try
- C.LoadFromResourceName(HINSTANCE, ResName);
- Screen.Cursors[Cursor] := C.ReleaseHandle;
- finally
- C.Free;
- end;
-end;
-
-procedure CaptureScreen(Dest: TBitmap);
-var
- DC: HDC;
-begin
- DC := GetDC(0);
- Dest.LoadFromDevice(DC);
- ReleaseDC(0, DC);
-end;
-
-procedure CaptureScreenRect(Rect: TRectI; Dest: TBitmap);
-var
- DC: HDC;
-begin
- if Rect.Empty then
- Exit;
- DC := GetDC(0);
- if (Dest.Width <> Rect.Width) or (Dest.Height <> Rect.Height) then
- Dest.SetSize(Rect.Width, Rect.Height);
- BitBlt(HDC(Dest.Canvas.Handle), 0, 0, Rect.Width, Rect.Height,
- DC, Rect.Left, Rect.Top, SRCCOPY);
- ReleaseDC(0, DC);
-end;
-
-end.
diff --git a/source/codebot.graphics.markup.pas b/source/codebot.graphics.markup.pas
deleted file mode 100644
index f43bcb5..0000000
--- a/source/codebot.graphics.markup.pas
+++ /dev/null
@@ -1,788 +0,0 @@
-(********************************************************)
-(* *)
-(* Codebot.Cross Pascal Library *)
-(* http://cross.codebot.org *)
-(* Modified March 2015 *)
-(* *)
-(********************************************************)
-
-{ }
-unit Codebot.Graphics.Markup;
-
-{$i codebot.inc}
-
-interface
-
-uses
- SysUtils, Classes, Graphics,
- Codebot.System,
- Codebot.Graphics,
- Codebot.Graphics.Types,
- Codebot.Text.Xml;
-
-type
- TPenData = record
- Name: string;
- Pen: IPen;
- end;
-
- TBrushData = record
- Name: string;
- Brush: IBrush;
- end;
-
- TFontData = record
- Name: string;
- Font: IFont;
- end;
-
- TCommandKind = (
- ckNone,
- ckMoveTo,
- ckLineTo,
- ckArcTo,
- ckCurveTo,
- ckEllipse,
- ckRectangle,
- ckRoundRectangle,
- ckText,
- ckPathOpen,
- ckPathClose,
- ckClip,
- ckUnclip,
- ckStatePush,
- ckStatePop,
- ckIdentity,
- ckRotate,
- ckScale,
- ckTranslate,
- ckStroke,
- ckFill
- );
-
- { TCommandData }
-
- TCommandData = record
- public
- procedure Reset;
- public
- Kind: TCommandKind;
- Expr: array[0..3] of string;
- case TCommandKind of
- ckMoveTo,
- ckLineTo,
- ckScale,
- ckTranslate:(
- X: Float; Y: Float;
- );
- ckArcTo: (
- Area: TRectF; BeginAngle: Float; EndAngle: Float;
- );
- ckCurveTo: (
- P: TPointF; C1: TPointF; C2: TPointF;
- );
- ckEllipse,
- ckRectangle: (
- Rect: TRectF;
- );
- ckRoundRectangle: (
- RoundRect: TRectF; Radius: Float;
- );
- ckText: (
- Font: ShortString;
- Text: ShortString;
- Insert: TPointF;
- );
- ckRotate: (
- Angle: Float;
- );
- ckStroke,
- ckFill: (
- Resource: ShortString;
- Preserve: Boolean;
- );
- end;
-
- TExpressionKind = (
- ekNone,
- ekColor,
- ekFloat,
- ekPoint,
- ekRect
- );
-
- TExpression = record
- public
- procedure Reset;
- procedure Resolve(var Data: TCommandData);
- public
- Name: string;
- Path: string;
- Kind: TExpressionKind;
- case TExpressionKind of
- ekColor: ( Color: TColorB; );
- ekFloat: ( Value: Float; );
- ekPoint: ( Point: TPointF; );
- ekRect: ( Rect: TRectF; );
- end;
-
- TExpressionArray = TArrayList;
-
-{ TSurfaceHeader }
-
- TSurfaceHeader = record
- public
- procedure Reset;
- procedure Normalize;
- public
- Title: string;
- Width: Integer;
- Height: Integer;
- Opacity: Byte;
- Scale: Float;
- Display: string;
- end;
-
-{ TSurfaceData }
-
- TSurfaceData = record
- private
- function GetScale: Float;
- private
- function FindBrush(const Name: string): IBrush;
- function FindPen(const Name: string): IPen;
- function FindFont(const Name: string): IFont;
- property Scale: Float read GetScale;
- public
- Doc: IDocument;
- Valid: Boolean;
- Header: TSurfaceHeader;
- Expressions: TExpressionArray;
- Brushes: TArrayList;
- Pens: TArrayList;
- Fonts: TArrayList;
- Commands: TArrayList;
- procedure Process(Document: IDocument; constref Defaults: TSurfaceHeader);
- procedure Render(Surface: ISurface);
- end;
-
-implementation
-
-{ TCommandData }
-
-procedure TCommandData.Reset;
-begin
- Kind := ckNone;
- Expr[0] := '';
- Expr[1] := '';
- Expr[2] := '';
- Expr[3] := '';
- FillZero(Font, SizeOf(Font));
- FillZero(Text, SizeOf(Text));
- FillZero(Insert, SizeOf(Insert));
-end;
-
-{ TExpression }
-
-procedure TExpression.Reset;
-begin
- Name := '';
- Path := '';
- Kind := ekNone;
- FillZero(Rect, SizeOf(Rect));
-end;
-
-procedure TExpression.Resolve(var Data: TCommandData);
-begin
- if Data.Expr[0] = Name then
- case Data.Kind of
- ckMoveTo,
- ckLineTo,
- ckScale,
- ckTranslate:
- if Kind = ekFloat then
- Data.X := Value;
- ckRotate:
- if Kind = ekFloat then
- Data.Angle := DegToRad(Value);
- ckArcTo,
- ckRectangle,
- ckRoundRectangle:
- if Kind = ekRect then
- Data.Rect := Rect;
- ckCurveTo:
- if Kind = ekPoint then
- Data.P := Point;
- ckText:
- if Kind = ekPoint then
- Data.Insert := Point;
- end;
- if Data.Expr[1] = Name then
- case Data.Kind of
- ckMoveTo,
- ckLineTo,
- ckScale,
- ckTranslate:
- if Kind = ekFloat then
- Data.Y := Value;
- ckArcTo,
- ckRoundRectangle:
- if Kind = ekFloat then
- Data.BeginAngle := Value;
- ckCurveTo:
- if Kind = ekPoint then
- Data.C1:= Point;
- end;
- if Data.Expr[2] = Name then
- case Data.Kind of
- ckArcTo:
- if Kind = ekFloat then
- Data.EndAngle := Value;
- ckCurveTo:
- if Kind = ekPoint then
- Data.C2:= Point;
- end;
-end;
-
-
-procedure TSurfaceHeader.Reset;
-begin
- Title := '(untitled)';
- Width := 256;
- Height := 256;
- Opacity := 255;
- Scale := 1;
- Display := 'fit';
-end;
-
-procedure TSurfaceHeader.Normalize;
-begin
- if Scale > 5 then
- Scale := 5
- else if Scale < 0.25 then
- Scale := 0.25;
- if Width < 32 then
- Width := 32
- else if Width > 512 then
- Width := 512;
- if Height < 32 then
- Height := 32
- else if Height > 512 then
- Height := 512;
- if Display.ArrayIndex(['fit', 'tile', 'overlay']) < 0 then
- Display := 'fit';
-end;
-
-{ TSurfaceData }
-
-procedure TSurfaceData.Process(Document: IDocument; constref Defaults: TSurfaceHeader);
-var
- Added: TExpressionArray;
-
- procedure AddExpression(Name: string; Kind: TExpressionKind);
- var
- Expr: TExpression;
- I: Integer;
- begin
- for I := Expressions.Lo to Expressions.Hi do
- begin
- Expr := Expressions[I];
- if Expr.Name = Name then
- begin
- if Expr.Kind <> Kind then
- Expr.Reset;
- Expr.Kind := Kind;
- Expressions[I] := Expr;
- if Added.IndexOf(Expr) < 0 then
- Added.Push(Expr);
- Exit;
- end;
- end;
- Expr.Reset;
- Expr.Name := Name;
- Expr.Kind := Kind;
- Expressions.Push(Expr);
- Added.Push(Expr);
- end;
-
- function ParseBrush(F: IFiler): TBrushData;
- var
- C: TColorB;
- S: string;
- I: Integer;
- begin
- Result.Name := F.ReadStr('@name');
- S := F.ReadStr('@color');
- if S <> '' then
- begin
- C := StrToColor(S);
- S := F.ReadStr('@alpha');
- if S <> '' then
- begin
- I := StrToIntDef(S, 255);
- if I < 0 then
- I := 0;
- if I > 255 then
- I := 255;
- C.Alpha := I;
- end;
- end
- else
- C := clBlack;
- Result.Brush := NewBrush(C);
- end;
-
- function ParsePen(F: IFiler; var Data: TSurfaceData): TPenData;
- var
- Brush: IBrush;
- C: TColorB;
- W: Float;
- S: string;
- I: Integer;
- begin
- Result.Name := F.ReadStr('@name');
- S := F.ReadStr('@color');
- if S <> '' then
- begin
- C := StrToColor(S);
- S := F.ReadStr('@alpha');
- if S <> '' then
- begin
- I := StrToIntDef(S, 255);
- if I < 0 then
- I := 0;
- if I > 255 then
- I := 255;
- C.Alpha := I;
- end;
- end
- else
- C := clBlack;
- S := F.ReadStr('@width');
- if S <> '' then
- begin
- W := StrToFloatDef(S, 1);
- if W < 0.1 then
- W := 0.1;
- end
- else
- W := 1;
- S := F.ReadStr('@brush');
- if S <> '' then
- Brush := Data.FindBrush(S)
- else
- Brush := nil;
- if Brush <> nil then
- Result.Pen := NewPen(Brush, W * Scale)
- else
- Result.Pen := NewPen(C, W * Scale);
- end;
-
- function ParseFont(F: IFiler): TFontData;
- var
- Font: TFont;
- Style: TFontStyles;
- C: TColorB;
- S: string;
- I: Integer;
- begin
- Font := TFont.Create;
- Result.Name := F.ReadStr('@name');
- S := F.ReadStr('@color');
- if S <> '' then
- begin
- C := StrToColor(S);
- S := F.ReadStr('@alpha');
- if S <> '' then
- begin
- I := StrToIntDef(S, 255);
- if I < 0 then
- I := 0;
- if I > 255 then
- I := 255;
- C := I;
- end;
- end
- else
- C := clBlack;
- S := F.ReadStr('@face');
- if S <> '' then
- Font.Name := S;
- S := F.ReadStr('@size');
- if S <> '' then
- begin
- I := StrToIntDef(S, 0);
- if I > 0 then
- Font.Height := I;
- end;
- Style := [];
- if F.ReadBool('@bold') then
- Include(Style, fsBold);
- if F.ReadBool('@italic') then
- Include(Style, fsItalic);
- if F.ReadBool('@underline') then
- Include(Style, fsUnderline);
- Font.Style := Style;
- Result.Font := NewFont(Font);
- Result.Font.Color := C;
- Font.Free;
- end;
-
- function Command(Kind: TCommandKind): TCommandData;
- begin
- Result.Reset;
- Result.Kind := Kind;
- end;
-
- function ParseMoveTo(Kind: TCommandKind; F: IFiler): TCommandData;
- var
- S: string;
- begin
- Result.Reset;
- Result.Kind := Kind;
- S := F.ReadStr('@x');
- if S.IsIdentifier then
- begin
- AddExpression(S, ekFloat);
- Result.Expr[0] := S;
- end
- else
- Result.X := F.ReadFloat('@x');
- S := F.ReadStr('@y');
- if S.IsIdentifier then
- begin
- AddExpression(S, ekFloat);
- Result.Expr[1] := S;
- end
- else
- Result.Y := F.ReadFloat('@y');
- end;
-
- function ParseRect(Rect: string): TRectF;
- var
- Words: StringArray;
- I: Integer;
- begin
- Result := TRectF.Create;
- Words := Rect.Words;
- for I := 0 to Words.Length - 1 do
- case I of
- 0: Result.X := StrToFloatDef(Words[I], 0);
- 1: Result.Y := StrToFloatDef(Words[I], 0);
- 2: Result.Width := StrToFloatDef(Words[I], 0);
- 3: Result.Height := StrToFloatDef(Words[I], 0);
- else
- Break;
- end;
- end;
-
- function ParseArcTo(Kind: TCommandKind; F: IFiler): TCommandData;
- begin
- Result.Reset;
- Result.Kind := Kind;
- Result.Area := ParseRect(F.ReadStr('@rect'));
- Result.BeginAngle := DegToRad(F.ReadFloat('@beginAngle'));
- Result.EndAngle := DegToRad(F.ReadFloat('@endAngle'));
- end;
-
- function ParsePoint(Rect: string): TPointF;
- var
- Words: StringArray;
- I: Integer;
- begin
- Result := TPointF.Create;
- Words := Rect.Words;
- for I := 0 to Words.Length - 1 do
- case I of
- 0: Result.X := StrToFloatDef(Words[I], 0);
- 1: Result.Y := StrToFloatDef(Words[I], 0);
- else
- Break;
- end;
- end;
-
- function ParseCurveTo(Kind: TCommandKind; F: IFiler): TCommandData;
- begin
- Result.Reset;
- Result.Kind := Kind;
- Result.P := ParsePoint(F.ReadStr('@p'));
- Result.C1 := ParsePoint(F.ReadStr('@c1'));
- Result.C2 := ParsePoint(F.ReadStr('@c2'));
- end;
-
- function ParseEllipse(Kind: TCommandKind; F: IFiler): TCommandData;
- begin
- Result.Reset;
- Result.Kind := Kind;
- Result.Rect := ParseRect(F.ReadStr('@rect'));
- end;
-
- function ParseRoundRect(Kind: TCommandKind; F: IFiler): TCommandData;
- begin
- Result.Reset;
- Result.Kind := Kind;
- Result.RoundRect := ParseRect(F.ReadStr('@rect'));
- Result.Radius := F.ReadFloat('@radius');
- if Result.Radius < 0 then
- Result.Radius := 0;
- end;
-
- function ParseText(Kind: TCommandKind; F: IFiler): TCommandData;
- begin
- Result.Reset;
- Result.Kind := Kind;
- Result.Font := F.ReadStr('@font');
- Result.Text := F.ReadStr('@text');
- Result.Insert := ParsePoint(F.ReadStr('@insert'));
- end;
-
- function ParseRotate(Kind: TCommandKind; F: IFiler): TCommandData;
- var
- S: string;
- begin
- Result.Reset;
- Result.Kind := Kind;
- S := F.ReadStr('@angle');
- if S.IsIdentifier then
- begin
- AddExpression(S, ekFloat);
- Result.Expr[0] := S;
- end
- else
- Result.Angle := DegToRad(F.ReadFloat('@angle'));
- end;
-
- function ParseStroke(Kind: TCommandKind; F: IFiler): TCommandData;
- begin
- Result.Reset;
- Result.Kind := Kind;
- if Kind = ckFill then
- Result.Resource := F.ReadStr('@brush')
- else
- Result.Resource := F.ReadStr('@pen');
- Result.Preserve := F.ReadBool('@preserve');
- end;
-
-var
- R: INode;
- N: INode;
- L: INodeList;
- F: IFiler;
- S: string;
-begin
- Doc := Document;
- Header := Defaults;
- Brushes.Length := 0;
- Pens.Length := 0;
- Fonts.Length := 0;
- Commands.Length := 0;
- R := Doc.Root;
- Valid := (R <> nil) and (R.Name = 'surface');
- if not Valid then
- Exit;
- F := R.Filer;
- Header.Title := F.ReadStr('@title', Defaults.Title, True).Trim;
- Header.Width := F.ReadInt('@width', Defaults.Width, True);
- Header.Height := F.ReadInt('@height', Defaults.Height, True);
- Header.Opacity := F.ReadInt('@opacity', Defaults.Opacity, True);
- Header.Scale := F.ReadFloat('@scale', Defaults.Scale, True);
- Header.Display := F.ReadStr('@display', Defaults.Display, True);
- Header.Normalize;
- L := R.SelectList('resources/brush');
- if L <> nil then
- for N in L do
- begin
- F := N.Filer;
- if F.ReadStr('@name') = '' then
- Continue
- else
- Brushes.Push(ParseBrush(F));
- end;
- L := R.SelectList('resources/pen');
- if L <> nil then
- for N in L do
- begin
- F := N.Filer;
- if F.ReadStr('@name') = '' then
- Continue
- else
- Pens.Push(ParsePen(F, Self));
- end;
- L := R.SelectList('resources/font');
- if L <> nil then
- for N in L do
- begin
- F := N.Filer;
- if F.ReadStr('@name') = '' then
- Continue
- else
- Fonts.Push(ParseFont(F));
- end;
- N := R.SelectNode('commands');
- if N <> nil then
- L := N.Nodes
- else
- L := nil;
- if L <> nil then
- for N in L do
- begin
- S := N.Name;
- F := N.Filer;
- if S = 'pathOpen' then
- Commands.Push(Command(ckPathOpen))
- else if S = 'pathClose' then
- Commands.Push(Command(ckPathClose))
- else if S = 'clip' then
- Commands.Push(Command(ckClip))
- else if S = 'unclip' then
- Commands.Push(Command(ckUnclip))
- else if S = 'statePush' then
- Commands.Push(Command(ckStatePush))
- else if S = 'statePop' then
- Commands.Push(Command(ckStatePop))
- else if S = 'identity' then
- Commands.Push(Command(ckIdentity))
- else if S = 'moveTo' then
- Commands.Push(ParseMoveTo(ckMoveTo, F))
- else if S = 'lineTo' then
- Commands.Push(ParseMoveTo(ckLineTo, F))
- else if S = 'scale' then
- Commands.Push(ParseMoveTo(ckScale, F))
- else if S = 'translate' then
- Commands.Push(ParseMoveTo(ckTranslate, F))
- else if S = 'translate' then
- Commands.Push(ParseMoveTo(ckTranslate, F))
- else if S = 'arcTo' then
- Commands.Push(ParseArcTo(ckArcTo, F))
- else if S = 'curveTo' then
- Commands.Push(ParseCurveTo(ckCurveTo, F))
- else if S = 'ellipse' then
- Commands.Push(ParseEllipse(ckEllipse, F))
- else if S = 'rectangle' then
- Commands.Push(ParseEllipse(ckRectangle, F))
- else if S = 'roundRectangle' then
- Commands.Push(ParseRoundRect(ckRoundRectangle, F))
- else if S = 'text' then
- Commands.Push(ParseText(ckText, F))
- else if S = 'rotate' then
- Commands.Push(ParseRotate(ckRotate, F))
- else if S = 'stroke' then
- Commands.Push(ParseStroke(ckStroke, F))
- else if S = 'fill' then
- Commands.Push(ParseStroke(ckFill, F));
- end;
- Expressions := Added;
-end;
-
-function TSurfaceData.GetScale: Float;
-begin
- Result := Header.Scale;
-end;
-
-function TSurfaceData.FindBrush(const Name: string): IBrush;
-var
- I: Integer;
-begin
- for I := Brushes.Lo to Brushes.Hi do
- if Name = Brushes[I].Name then
- Exit(Brushes[I].Brush);
- Result := nil;
-end;
-
-function TSurfaceData.FindPen(const Name: string): IPen;
-var
- I: Integer;
-begin
- for I := Pens.Lo to Pens.Hi do
- if Name = Pens[I].Name then
- Exit(Pens[I].Pen);
- Result := nil;
-end;
-
-function TSurfaceData.FindFont(const Name: string): IFont;
-var
- I: Integer;
-begin
- for I := Fonts.Lo to Fonts.Hi do
- if Name = Fonts[I].Name then
- Exit(Fonts[I].Font);
- Result := nil;
-end;
-
-procedure TSurfaceData.Render(Surface: ISurface);
-
- procedure Resolve(var Data: TCommandData);
- var
- I: Integer;
- begin
- if (Data.Expr[0] = '') and (Data.Expr[1] = '') and
- (Data.Expr[2] = '') and (Data.Expr[3] = '') then
- Exit;
- for I := Expressions.Lo to Expressions.Hi do
- Expressions[I].Resolve(Data);
- end;
-
-var
- Data: TCommandData;
- F: IFont;
- B: IBrush;
- P: IPen;
- R: TRectF;
- I: Integer;
-begin
- for I := Commands.Lo to Commands.Hi do
- begin
- Data := Commands[I];
- Resolve(Data);
- case Data.Kind of
- ckMoveTo: Surface.MoveTo(Data.X * Scale, Data.Y * Scale);
- ckLineTo: Surface.LineTo(Data.X * Scale, Data.Y * Scale);
- ckArcTo: Surface.ArcTo(Data.Area * Scale, Data.BeginAngle, Data.EndAngle);
- ckCurveTo: Surface.CurveTo(Data.P.X * Scale, Data.P.Y * Scale, Data.C1 * Scale, Data.C2 * Scale);
- ckEllipse: Surface.Ellipse(Data.Rect * Scale);
- ckRectangle: Surface.Rectangle(Data.Rect * Scale);
- ckRoundRectangle: Surface.RoundRectangle(Data.RoundRect * Scale, Data.Radius * Scale);
- ckText:
- begin
- F := FindFont(Data.Font);
- if F = nil then
- Continue;
- R := TRectF.Create(1000, 1000);
- R.Center(Data.Insert);
- Surface.TextOut(F, Data.Text, R, drCenter);
- end;
- ckPathOpen: Surface.Path.Add;
- ckPathClose: Surface.Path.Close;
- ckClip: Surface.Path.Clip;
- ckUnclip: Surface.Path.Unclip;
- ckStatePush: Surface.Save;
- ckStatePop: Surface.Restore;
- ckIdentity: Surface.Matrix.Identity;
- ckRotate: Surface.Matrix.Rotate(Data.Angle);
- ckScale: Surface.Matrix.Scale(Data.X * Scale, Data.Y * Scale);
- ckTranslate: Surface.Matrix.Translate(Data.X * Scale, Data.Y * Scale);
- ckStroke:
- begin
- P := FindPen(Data.Resource);
- if P <> nil then
- Surface.Stroke(P, Data.Preserve);
- end;
- ckFill:
- begin
- B := FindBrush(Data.Resource);
- if B <> nil then
- Surface.Fill(B, Data.Preserve);
- end;
- end;
- end;
-end;
-
-function DefaultExpressionCompare(constref A, B: TExpression): Integer;
-begin
- Result := StrCompare(A.Name, B.Name);
-end;
-
-initialization
- TExpressionArray.DefaultCompare := DefaultExpressionCompare;
-end.
-
diff --git a/source/codebot.inc b/source/codebot.inc
deleted file mode 100644
index cede825..0000000
--- a/source/codebot.inc
+++ /dev/null
@@ -1,17 +0,0 @@
-{$ifndef fpc}
-'This library requires the free pascal compiler'
-{$endif}
-{$if fpc_fullversion < 30000}
-'This library requires the free pascal 3 or greater'
-{$endif}
-
-{$mode delphi}
-
-{$z4}
-{$macro on}
-
-{$ifdef windows}
- {$define apicall := stdcall}
-{$else}
- {$define apicall := cdecl}
-{$endif}
diff --git a/source/codebot.interop.openssl.pas b/source/codebot.interop.openssl.pas
deleted file mode 100644
index 5d88e1b..0000000
--- a/source/codebot.interop.openssl.pas
+++ /dev/null
@@ -1,254 +0,0 @@
-(********************************************************)
-(* *)
-(* Codebot Pascal Library *)
-(* http://cross.codebot.org *)
-(* Modified September 2013 *)
-(* *)
-(********************************************************)
-
-{ }
-unit Codebot.Interop.OpenSSL;
-
-{$i codebot.inc}
-
-interface
-
-uses
- Codebot.Core;
-
-const
- 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;
- SSL_ERROR_ZERO_RETURN = 6;
- SSL_ERROR_WANT_CONNECT = 7;
-
- MD5_DIGEST_LENGTH = 16;
- SHA1_DIGEST_LENGTH = 20;
- SHA256_DIGEST_LENGTH = 32;
- SHA512_DIGEST_LENGTH = 64;
-
-type
- TSSLCtx = Pointer;
- TSSL = Pointer;
- TSSLMethod = Pointer;
- TEVPMethod = Pointer;
-
- MD5_CTX = record
- data: array[0..127] of Byte;
- end;
- TMD5Ctx = MD5_CTX;
- PMD5Ctx = ^TMD5Ctx;
-
- MD5_DIGEST = record
- data: array [0..MD5_DIGEST_LENGTH - 1] of Byte;
- end;
- TMD5Digest = MD5_DIGEST;
- PMD5Digest = ^TMD5Digest;
-
- SHA1_CTX = record
- data: array[0..255] of Byte;
- end;
- TSHA1Ctx = SHA1_CTX;
- PSHA1Ctx = ^TSHA1Ctx;
-
- SHA1_DIGEST = record
- data: array [0..SHA1_DIGEST_LENGTH - 1] of Byte;
- end;
- TSHA1Digest = SHA1_DIGEST;
- PSHA1Digest = ^TSHA1Digest;
-
- SHA256_CTX = record
- data: array[0..255] of Byte;
- end;
- TSHA256Ctx = SHA256_CTX;
- PSHA256Ctx = ^TSHA256Ctx;
-
- SHA256_DIGEST = record
- data: array [0..SHA256_DIGEST_LENGTH - 1] of Byte;
- end;
- TSHA256Digest = SHA256_DIGEST;
- PSHA256Digest = ^TSHA256Digest;
-
- SHA512_CTX = record
- data: array[0..255] of Byte;
- end;
- TSHA512Ctx = SHA512_CTX;
- PSHA512Ctx = ^TSHA512Ctx;
-
- SHA512_DIGEST = record
- data: array [0..SHA512_DIGEST_LENGTH - 1] of Byte;
- end;
- TSHA512Digest = SHA512_DIGEST;
- PSHA512Digest = ^TSHA512Digest;
-
- HMAC_CTX = record
- data: array[0..511] of Byte;
- end;
- THMACCtx = HMAC_CTX;
- PHMACCtx = ^THMACCtx;
-
-{ OpenSSL routines }
-
-var
- SSL_library_init: function: Integer; cdecl;
- SSL_load_error_strings: procedure; cdecl;
- SSLv23_client_method: function: TSSLMethod; cdecl;
- SSL_CTX_new: function(method: TSSLMethod): TSSLCtx; cdecl;
- SSL_CTX_free: procedure(context: TSSLCtx); cdecl;
- SSL_new: function(context: TSSLCtx): TSSL; cdecl;
- SSL_shutdown: function(ssl: TSSL): LongInt; cdecl;
- SSL_free: procedure(ssl: TSSL); cdecl;
- SSL_set_fd: function(ssl: TSSL; socket: LongInt): LongBool; cdecl;
- SSL_connect: function(ssl: TSSL): LongBool; cdecl;
- SSL_write: function(ssl: TSSL; buffer: Pointer; size: LongWord): LongInt; cdecl;
- SSL_read: function(ssl: TSSL; buffer: Pointer; size: LongWord): LongInt; cdecl;
- SSL_get_error: function(ssl: TSSL; ret_code: Integer): Integer; cdecl;
-
-{ Hashing routines }
-
- MD5_Init: function(out context: TMD5Ctx): LongBool; cdecl;
- MD5_Update: function(var context: TMD5Ctx; data: Pointer; size: Cardinal): LongBool; cdecl;
- MD5_Final: function(out digest: TMD5Digest; var context: TMD5Ctx): LongBool; cdecl;
- SHA1_Init: function(out context: TSHA1Ctx): LongBool; cdecl;
- SHA1_Update: function(var context: TSHA1Ctx; data: Pointer; size: Cardinal): LongBool; cdecl;
- SHA1_Final: function(out digest: TSHA1Digest; var context: TSHA1Ctx): LongBool; cdecl;
- SHA256_Init: function(out context: TSHA256Ctx): LongBool; cdecl;
- SHA256_Update: function(var context: TSHA256Ctx; data: Pointer; size: Cardinal): LongBool; cdecl;
- SHA256_Final: function(out digest: TSHA256Digest; var context: TSHA256Ctx): LongBool; cdecl;
- SHA512_Init: function(out context: TSHA512Ctx): LongBool; cdecl;
- SHA512_Update: function(var context: TSHA512Ctx; data: Pointer; size: Cardinal): LongBool; cdecl;
- SHA512_Final: function(out digest: TSHA512Digest; var context: TSHA512Ctx): LongBool; cdecl;
- EVP_md5: function: TEVPMethod; cdecl;
- EVP_sha1: function: TEVPMethod; cdecl;
- EVP_sha256: function: TEVPMethod; cdecl;
- EVP_sha512: function: TEVPMethod; cdecl;
- HMAC_CTX_init: procedure(out context: THMACCtx); cdecl;
- HMAC_CTX_cleanup: procedure(var context: THMACCtx); cdecl;
- HMAC_Init_ex: function(var context: THMACCtx; key: Pointer; size: Cardinal; method: TEVPMethod; engine: Pointer): LongBool; cdecl;
- HMAC_Update: function(var context: THMACCtx; data: Pointer; size: Cardinal): LongBool; cdecl;
- HMAC_Final: function(var context: THMACCtx; digest: Pointer; var digestSize: LongWord): LongBool; cdecl;
-
-const
-{$ifdef windows}
- libssl = 'libssl32.dll';
- libssl100 = libssl;
- libcrypto = 'libeay32.dll';
- libcrypto1 = libcrypto;
-{$endif}
-{$ifdef linux}
- libssl = 'libssl.' + SharedSuffix;
- libssl100 = libssl + '.1.0.0';
- libcrypto = 'libcrypto.' + SharedSuffix;
- libcrypto1 = libcrypto + '.1';
-{$endif}
-
-function OpenSSLInit(ThrowExceptions: Boolean = False): Boolean;
-
-implementation
-
-var
- Loaded: Boolean;
- Initialized: Boolean;
- FailedModuleName: string;
- FailedProcName: string;
-
-function OpenSSLInit(ThrowExceptions: Boolean = False): Boolean;
-var
- Module: HModule;
-
- procedure CheckExceptions;
- begin
- if (not Initialized) and (ThrowExceptions) then
- LibraryExceptProc(FailedModuleName, FailedProcName);
- end;
-
- function TryLoad(const ProcName: string; var Proc: Pointer): Boolean;
- begin
- FailedProcName := ProcName;
- Proc := LibraryGetProc(Module, ProcName);
- Result := Proc <> nil;
- if not Result then
- CheckExceptions;
- end;
-
-begin
- ThrowExceptions := ThrowExceptions and (@LibraryGetProc <> nil);
- if Loaded then
- begin
- CheckExceptions;
- Exit(Initialized);
- end;
- Loaded:= True;
- if Initialized then
- Exit(True);
- Result := False;
- FailedModuleName := libssl;
- FailedProcName := '';
- Module := LibraryLoad(libssl, libssl100);
- if Module = ModuleNil then
- begin
- CheckExceptions;
- Exit;
- end;
- Result :=
- TryLoad('SSL_library_init', @SSL_library_init) and
- TryLoad('SSL_library_init', @SSL_library_init) and
- TryLoad('SSL_load_error_strings', @SSL_load_error_strings) and
- TryLoad('SSLv23_client_method', @SSLv23_client_method) and
- TryLoad('SSL_CTX_new', @SSL_CTX_new) and
- TryLoad('SSL_CTX_free', @SSL_CTX_free) and
- TryLoad('SSL_new', @SSL_new) and
- TryLoad('SSL_shutdown', @SSL_shutdown) and
- TryLoad('SSL_free', @SSL_free) and
- TryLoad('SSL_set_fd', @SSL_set_fd) and
- TryLoad('SSL_connect', @SSL_connect) and
- TryLoad('SSL_write', @SSL_write) and
- TryLoad('SSL_read', @SSL_read) and
- TryLoad('SSL_get_error', @SSL_get_error);
- if not Result then
- Exit;
- Result := False;
- FailedModuleName := libcrypto;
- FailedProcName := '';
- Module := LibraryLoad(libcrypto, libcrypto1);
- if Module = ModuleNil then
- begin
- CheckExceptions;
- Exit;
- end;
- Result :=
- TryLoad('MD5_Init', @MD5_Init) and
- TryLoad('MD5_Update', @MD5_Update) and
- TryLoad('MD5_Final', @MD5_Final) and
- TryLoad('SHA1_Init', @SHA1_Init) and
- TryLoad('SHA1_Update', @SHA1_Update) and
- TryLoad('SHA1_Final', @SHA1_Final) and
- TryLoad('SHA256_Init', @SHA256_Init) and
- TryLoad('SHA256_Update', @SHA256_Update) and
- TryLoad('SHA256_Final', @SHA256_Final) and
- TryLoad('SHA512_Init', @SHA512_Init) and
- TryLoad('SHA512_Update', @SHA512_Update) and
- TryLoad('SHA512_Final', @SHA512_Final) and
- TryLoad('EVP_md5', @EVP_md5) and
- TryLoad('EVP_sha1', @EVP_sha1) and
- TryLoad('EVP_sha256', @EVP_sha256) and
- TryLoad('EVP_sha512', @EVP_sha512) and
- TryLoad('HMAC_CTX_init', @HMAC_CTX_init) and
- TryLoad('HMAC_CTX_cleanup', @HMAC_CTX_cleanup) and
- TryLoad('HMAC_Init_ex', @HMAC_Init_ex) and
- TryLoad('HMAC_Update', @HMAC_Update) and
- TryLoad('HMAC_Final', @HMAC_Final);
- if not Result then
- Exit;
- FailedModuleName := '';
- FailedProcName := '';;
- Initialized := True;
- SSL_library_init;
- SSL_load_error_strings;
-end;
-
-end.
diff --git a/source/codebot.networking.storage.pas b/source/codebot.networking.storage.pas
deleted file mode 100644
index f2dcf6d..0000000
--- a/source/codebot.networking.storage.pas
+++ /dev/null
@@ -1,140 +0,0 @@
-(********************************************************)
-(* *)
-(* Codebot Pascal Library *)
-(* http://cross.codebot.org *)
-(* Modified March 2015 *)
-(* *)
-(********************************************************)
-
-{ }
-unit Codebot.Networking.Storage;
-
-{$i codebot.inc}
-
-interface
-
-uses
- Classes,
- SysUtils,
- Codebot.System,
- Codebot.Text,
- Codebot.Text.Xml,
- Codebot.Cryptography,
- Codebot.Networking,
- Codebot.Networking.Web;
-
-{ TCloudVendor }
-
-type
- TCloudVendor = (
- cloudAmazon,
- cloudGoogle,
- cloudMicrosoft
- );
-
-{ TCloudStorage }
-
- TCloudStorage = class(TObject)
- private
- FVendor: TCloudVendor;
- FPrivateKey: string;
- FPublicKey: string;
- function ComputeSignature(const Verb, MD5, ContentType, Date, Resource: string): string;
- function GetRequestHeader(const Resource: string): string;
- public
- Header: THttpResponseHeader;
- constructor Create(Vendor: TCloudVendor; const PublicKey, PrivateKey: string);
- function List(const Resource: string): IDocument;
- function ListRaw(const Resource: string): string;
- function Fetch(const Resource: string; Stream: TStream): Boolean;
- end;
-
-implementation
-
-uses
- lazutf8sysutils;
-
-const
- CloudHosts: array[TCloudVendor] of string = (
- 's3.amazonaws.com',
- 'storage.googleapis.com',
- 'blob.core.windows.net'
- );
-
-constructor TCloudStorage.Create(Vendor: TCloudVendor; const PublicKey, PrivateKey: string);
-begin
- inherited Create;
- FVendor := Vendor;
- FPublicKey := PublicKey;
- FPrivateKey := PrivateKey;
-end;
-
-function TCloudStorage.ComputeSignature(const Verb, MD5, ContentType, Date, Resource: string): string;
-var
- S: string;
-begin
- S := Verb + #10 + MD5 + #10 + ContentType + #10 + Date + #10 + Resource.FirstOf('?');
- Result := 'Authorization: AWS ' + FPublicKey + ':' + AuthString(FPrivateKey, hashSHA1, S).Encode;
-end;
-
-function TCloudStorage.GetRequestHeader(const Resource: string): string;
-var
- Date: string;
- Signature: string;
-begin
- Date := NowUTC.ToString('GMT');
- Signature := ComputeSignature('GET', '', '', Date, Resource);
- Result := 'GET ' + Resource + ' HTTP/1.0'#10 +
- 'Host: ' + CloudHosts[FVendor] + #10 +
- 'Connection: Close' + #10 +
- 'Date: ' + Date + #10 +
- Signature + #10#10;
-end;
-
-function TCloudStorage.List(const Resource: string): IDocument;
-var
- Socket: TSocket;
- Body, Buffer: string;
-begin
- Header.Clear;
- Body := '';
- Socket := TSocket.Create;
- try
- if Socket.Connect(CloudHosts[FVendor], 80) then
- begin
- Buffer := GetRequestHeader(Resource);
- Socket.WriteAll(Buffer);
- while Socket.Read(Buffer) > 0 do
- begin
- Body := Body + Buffer;
- if Header.Code = 0 then
- if not Header.Extract(Body) then
- Continue;
- if XmlValidate(Body) then
- Break;
- end;
- end;
- finally
- Socket.Free;
- end;
- if Header.Code = 0 then
- Body := '';
- Result := DocumentCreate;
- Result.Xml := Body.Replace(' xmlns="http://', ' X="');
-end;
-
-function TCloudStorage.ListRaw(const Resource: string): string;
-var
- D: IDocument;
-begin
- D := List(Resource);
- D.Beautify;
- Result := D.Xml;
-end;
-
-function TCloudStorage.Fetch(const Resource: string; Stream: TStream): Boolean;
-begin
-end;
-
-end.
-
diff --git a/source/codebot.networking.web.pas b/source/codebot.networking.web.pas
deleted file mode 100644
index bfbecec..0000000
--- a/source/codebot.networking.web.pas
+++ /dev/null
@@ -1,788 +0,0 @@
-(********************************************************)
-(* *)
-(* Codebot Pascal Library *)
-(* http://cross.codebot.org *)
-(* Modified March 2015 *)
-(* *)
-(********************************************************)
-
-{ }
-unit Codebot.Networking.Web;
-
-{$i codebot.inc}
-
-interface
-
-uses
- Classes,
- SysUtils,
- Codebot.System,
- Codebot.Text.Xml,
- Codebot.Networking;
-
-{ TUrl parses urls such as https://example.com:8080/resource and
- captures the component values
- See also
- }
-
-type
- TUrl = record
- private
- FProtocol: string;
- FPort: Word;
- FDomain: string;
- FResource: string;
- FSecure: Boolean;
- FValid: Boolean;
- public
- { Convert a TUrl to a string }
- class operator Implicit(const Value: TUrl): string;
- { Convert s string to a TUrl }
- class operator Implicit(const Value: string): TUrl;
- { Create a TUrl given a string }
- class function Create(const S: string): TUrl; static;
- { The protocol portion of the url, for example HTTP }
- property Protocol: string read FProtocol;
- { The port portion of the url, for example 8080 }
- property Port: Word read FPort;
- { The domain portion of the url, for example www.google.com }
- property Domain: string read FDomain;
- { The resource portion of the url, for example /search/?query=hello }
- property Resource: string read FResource;
- { Flag indicating if SSL should be used }
- property Secure: Boolean read FSecure;
- { Flag indicating if a url is properly formatted }
- property Valid: Boolean read FValid;
- end;
-
-{ THttpResponseHeader parses a buffer and find components of a
- valid http response header
- See also
- }
-
- THttpResponseHeader = record
- public
- { Response code such as 200 }
- Code: Integer;
- { Response status such as OK }
- Status: string;
- { Reponse key values }
- Keys: TNamedStrings;
- { Reponse raw header text }
- RawHeader: string;
- { When Valid is true a complete header was processed from extract }
- Valid: Boolean;
- { Clears all component values }
- procedure Clear;
- { Attempt to parse an incomming response buffer }
- function Extract(var Buffer: string): Boolean;
- end;
-
- TTransmistHeaderCompleteEvent = procedure (Sender: TObject; const Header: THttpResponseHeader) of object;
-
-{ THttpClient implements the http 1.0 client protocol
- See also
- }
-
- THttpClient = class
- private
- FCancelled: Boolean;
- FCompleted: Boolean;
- FUserAgent: string;
- FResponseHeader: THttpResponseHeader;
- FResponseStream: TStream;
- FResponseText: TStringStream;
- FFOnCancel: TNotifyEvent;
- FOnHeaderComplete: TTransmistHeaderCompleteEvent;
- FOnComplete: TNotifyEvent;
- FOnProgress: TTransmitEvent;
- function GetCode: Integer;
- function GetStatus: string;
- function GetName(Index: Integer): string;
- function GetValue(Name: string): string;
- function GetNameCount: Integer;
- function GetResponseText: string;
- function Process(const Url: TUrl; const Request: string): Boolean;
- protected
- { Complete is invoked when Process is about to return true }
- procedure Complete; virtual;
- { Invoke the OnCancel event }
- procedure DoCancel; virtual;
- { Invoke the OnHeaderComplete event }
- procedure DoHeaderComplete; virtual;
- { Invoke the OnResponseComplete event }
- procedure DoComplete; virtual;
- { Invoke the OnProgress event }
- procedure DoProgress(const Size, Transmitted: LargeWord); virtual;
- public
- { Create an http client instance }
- constructor Create;
- destructor Destroy; override;
- { Clear the last response }
- procedure Clear;
- { Cancel an ongoing response, can be invoked automatically when an unxpected condition is encountered }
- procedure Cancel;
- { Request a copy of the response header }
- procedure CopyHeader(out Header: THttpResponseHeader);
- { Send an HTTP GET request }
- function Get(const Url: TUrl): Boolean; overload;
- { Send an HTTP GET request with custom headers }
- function Get(const Url: TUrl; const Headers: TNamedStrings): Boolean; overload;
- { Send an HTTP POST request with custom headers and content }
- function Post(const Url: TUrl; const Headers: TNamedStrings;
- const ContentType: string; const Content: string): Boolean;
- { Send an HTTP POST request with an arguments form body }
- function PostArgs(const Url: TUrl; const Args: TNamedStrings): Boolean;
- { Send an HTTP POST request with a json body }
- function PostJson(const Url: TUrl; const Json: string): Boolean;
- { Send an HTTP POST request with an xml body }
- function PostXml(const Url: TUrl; Doc: IDocument): Boolean;
- { Holds true if the last request completed properly }
- property Completed: Boolean read FCompleted;
- { The user agent as seen by the server }
- property UserAgent: string read FUserAgent write FUserAgent;
- { The response code returned from the server }
- property Code: Integer read GetCode;
- { The response status returned from the server }
- property Status: string read GetStatus;
- { Response header names }
- property Names[Index: Integer]: string read GetName;
- { Response header values }
- property Values[Name: string]: string read GetValue;
- { Response header name count }
- property NameCount: Integer read GetNameCount;
- { Set ResponseStream to write the response body to a stream }
- property ResponseStream: TStream read FResponseStream write FResponseStream;
- { If ResponseStream is nil then the response body is stored in ResponseText instead }
- property ResponseText: string read GetResponseText;
- { FOnCancel is invoked if the request is stoped before completion }
- property OnCancel: TNotifyEvent read FFOnCancel write FFOnCancel;
- { OnHeaderComplete is invoked after a complete response header is read }
- property OnHeaderComplete: TTransmistHeaderCompleteEvent read FOnHeaderComplete write FOnHeaderComplete;
- { OnComplete is invoked after a response is read }
- property OnComplete: TNotifyEvent read FOnComplete write FOnComplete;
- { OnProgress is invoked as after the request header is received and while bytes are being read }
- property OnProgress: TTransmitEvent read FOnProgress write FOnProgress;
- end;
-
-const
- ContentNone = '';
- ContentText = 'text/plain';
- ContentHtml = 'text/html';
- ContentArgs = 'application/x-www-form-urlencoded';
- ContentJson = 'application/json';
- ContentXml = 'text/xml; charset=utf-8';
-
-{ Simplified HTTP GET with response output to a stream }
-function WebGet(const Url: TUrl; Response: TStream; const UserAgent: string = ''): Boolean; overload;
-{ Simplified HTTP GET with response output to a string }
-function WebGet(const Url: TUrl; out Response: string; const UserAgent: string = ''): Boolean; overload;
-
-{ HttpResponseHeaderExtract attempts to parse buffer and find a
- valid http response header }
-function HttpResponseHeaderExtract(var Buffer: string; out Header: string;
- out BreakStyle: string): Boolean;
-{ HttpRequestGet creates an http get request given a url }
-function HttpRequestGet(const Url: TUrl; const UserAgent: string = ''): string;
-{ HttpRequestPost creates an http post request given a url and arguments }
-function HttpRequestPostArgs(const Url: TUrl; const Args: TNamedStrings; const UserAgent: string = ''): string;
-{ HttpRequestPostJson creates an http post request given a url and json string }
-function HttpRequestPostJson(const Url: TUrl; const Json: string; const UserAgent: string = ''): string;
-{ HttpRequestPostJson creates an http post request given a url and json string }
-function HttpRequestPostXml(const Url: TUrl; Doc: IDocument; const UserAgent: string = ''): string;
-{ UrlEncode escapes char sequences suitable for posting data }
-function UrlEncode(const Value: string): string;
-{ UrlDecode reverts previously escaped char sequences }
-function UrlDecode(const Value: string): string;
-{ ArgsEncode converts name value pairs to a string suitable for posting }
-function ArgsEncode(const Args: TNamedStrings): string;
-{ ArgsDecode converts a posted string back to name value pairs }
-function ArgsDecode(const Args: string): TNamedStrings;
-
-implementation
-
-function ProtocolPort(const Protocol: string): Word;
-var
- S: string;
-begin
- S := Protocol.ToUpper;
- if S = 'FTP' then
- Result := 21
- else if S = 'HTTP' then
- Result := 80
- else if S = 'HTTPS' then
- Result := 443
- else
- Result := 0;
-end;
-
-function DomainValidate(const S: string): Boolean;
-begin
- Result := S <> '';
-end;
-
-{ TUrl }
-
-class operator TUrl.Implicit(const Value: TUrl): string;
-begin
- Result := Value.FProtocol.ToLower + '://' + Value.FDomain;
- if Value.FPort <> ProtocolPort(Value.FProtocol) then
- Result := Result + ':' + IntToStr(Value.FPort);
- if Value.FResource <> '/' then
- Result := Result + Value.FResource;
-end;
-
-class operator TUrl.Implicit(const Value: string): TUrl;
-begin
- Result := TUrl.Create(Value);
-end;
-
-class function TUrl.Create(const S: string): TUrl;
-var
- U: string;
-begin
- Result.FProtocol := 'HTTP';
- if S.IndexOf('://') > 0 then
- begin
- U := S.FirstOf('://');
- if U <> '' then
- Result.FProtocol := U.ToUpper;
- U := S.SecondOf('://');
- end
- else
- U := S;
- Result.FPort := ProtocolPort(Result.FProtocol);
- Result.FResource := '/' + U.SecondOf('/');
- U := U.FirstOf('/');
- Result.FDomain := U.FirstOf(':');
- U := U.SecondOf(':');
- if U <> '' then
- Result.FPort := StrToIntDef(U, Result.FPort);
- Result.FSecure := Result.FProtocol = 'HTTPS';
- Result.FValid := DomainValidate(Result.FDomain) and (Result.FPort > 0);
-end;
-
-{ THttpResponseHeader }
-
-procedure THttpResponseHeader.Clear;
-begin
- Code := 0;
- Status := '';
- RawHeader := '';
- Valid := False;
- Keys.Clear;
-end;
-
-function THttpResponseHeader.Extract(var Buffer: string): Boolean;
-var
- BreakStyle: string;
- Lines, Row: StringArray;
- I: Integer;
-begin
- Result := False;
- if Valid then
- Exit;
- Valid := HttpResponseHeaderExtract(Buffer, RawHeader, BreakStyle);
- if Valid then
- begin
- Lines := RawHeader.Split(BreakStyle);
- for I := Lines.Lo to Lines.Hi do
- if I = 0 then
- begin
- Row := Lines[I].Words;
- if Row.Length > 1 then
- Code := StrToIntDef(Row[1], 0);
- if Row.Length > 2 then
- Status := Row[2];
- end
- else
- Keys.Add(Lines[I].FirstOf(':').Trim, Lines[I].SecondOf(':').Trim);
- end;
- Result := Valid;
-end;
-
-{ THttpClient }
-
-constructor THttpClient.Create;
-begin
- inherited Create;
- FResponseText := TStringStream.Create('');
- Clear;
-end;
-
-destructor THttpClient.Destroy;
-begin
- FResponseText.Free;
- inherited Destroy;
-end;
-
-procedure THttpClient.Clear;
-begin
- FCompleted := False;
- FCancelled := True;
- FResponseHeader.Clear;
- FResponseText.Size := 0;
-end;
-
-procedure THttpClient.Complete;
-begin
- if not FCompleted then
- begin
- FCompleted := True;
- FCancelled := True;
- DoComplete;
- end;
-end;
-
-procedure THttpClient.Cancel;
-begin
- if not FCancelled then
- begin
- FCancelled := True;
- DoCancel;
- end;
-end;
-
-procedure THttpClient.CopyHeader(out Header: THttpResponseHeader);
-begin
- Header := FResponseHeader;
-end;
-
-function THttpClient.GetCode: Integer;
-begin
- Result := FResponseHeader.Code;
-end;
-
-function THttpClient.GetStatus: string;
-begin
- Result := FResponseHeader.Status;
-end;
-
-function THttpClient.GetName(Index: Integer): string;
-begin
- Result := FResponseHeader.Keys.Names[Index];
-end;
-
-function THttpClient.GetValue(Name: string): string;
-begin
- Result := FResponseHeader.Keys.Values[Name];
-end;
-
-function THttpClient.GetNameCount: Integer;
-begin
- Result := FResponseHeader.Keys.Count;
-end;
-
-function THttpClient.GetResponseText: string;
-begin
- Result := FResponseText.DataString;
-end;
-
-procedure THttpClient.DoCancel;
-begin
- if Assigned(FFOnCancel) then
- FFOnCancel(Self);
-end;
-
-procedure THttpClient.DoHeaderComplete;
-begin
- if Assigned(FOnHeaderComplete) then
- FOnHeaderComplete(Self, FResponseHeader);
-end;
-
-procedure THttpClient.DoComplete;
-begin
- if Assigned(FOnComplete) then
- FOnComplete(Self);
-end;
-
-procedure THttpClient.DoProgress(const Size, Transmitted: LargeWord);
-begin
- if Assigned(FOnProgress) then
- FOnProgress(Self, Size, Transmitted);
-end;
-
-function THttpClient.Process(const Url: TUrl; const Request: string): Boolean;
-
- function Stream: TStream;
- begin
- if FResponseStream <> nil then
- Result := FResponseStream
- else
- Result := FResponseText;
- end;
-
-const
- BufferSize = $10000;
-var
- Socket: TSocket;
- Temp, S: string;
- ContentLength, ContentRead: LargeInt;
- Count: LongInt;
- Buffer: Pointer;
- I: Integer;
-begin
- Result := False;
- Clear;
- try
- FCancelled := False;
- if not Url.Valid then
- Exit;
- if Request.Length = 0 then
- Exit;
- Socket := TSocket.Create;
- try
- Socket.Secure := Url.Secure;
- Socket.Timeout := 4000;
- if not Socket.Connect(Url.Domain, Url.Port) then
- Exit;
- if not Socket.WriteAll(Request) then
- Exit;
- Temp := '';
- repeat
- I := Socket.Read(S);
- if I < 1 then
- Exit;
- Temp := Temp + S;
- until FResponseHeader.Extract(Temp);
- DoHeaderComplete;
- S := FResponseHeader.Keys.Values['Content-Length'];
- if S <> '' then
- begin
- ContentLength := StrToInt64Def(S, 0);
- if ContentLength < 1 then
- Exit(True);
- if Temp.Length >= ContentLength then
- begin
- Stream.Write(Temp[1], ContentLength);
- Exit(True);
- end;
- end
- else
- ContentLength := High(ContentLength);
- ContentRead := Temp.Length;
- if ContentRead > 0 then
- Stream.Write(Temp[1], Temp.Length);
- Temp := '';
- GetMem(Buffer, BufferSize);
- try
- repeat
- Count := Socket.Read(Buffer^, BufferSize);
- if Count > 0 then
- begin
- if Count + ContentRead >= ContentLength then
- Count := ContentLength - ContentRead;
- if Stream.Write(Buffer^, Count) = Count then
- begin
- ContentRead := ContentRead + Count;
- DoProgress(ContentLength, ContentRead);
- end
- else
- Exit;
- end;
- until (FCancelled) or (Count < 1) or (ContentRead >= ContentLength);
- if FCancelled then
- Result := False
- else if S <> '' then
- Result := ContentRead >= ContentLength
- else
- Result := True;
- finally
- FreeMem(Buffer);
- end;
- finally
- Socket.Free;
- end;
- finally
- if Result then
- Complete
- else
- Cancel;
- end;
-end;
-
-function THttpClient.Get(const Url: TUrl): Boolean;
-var
- S: string;
-begin
- S := HttpRequestGet(Url, FUserAgent);
- Result := Process(Url, S);
-end;
-
-function THttpClient.Get(const Url: TUrl; const Headers: TNamedStrings): Boolean;
-var
- Name, Value: string;
- S: string;
- I: Integer;
-begin
- S := 'GET ' + Url.Resource + ' HTTP/1.0'#13#10 +
- 'Host: ' + Url.Domain + #13#10;
- for I := 0 to Headers.Count - 1 do
- begin
- Name := Headers.Names[I];
- Value := Headers.ValueByIndex[I];
- S := S + Name + ': ' + Value + #13#10;
- end;
- if UserAgent <> '' then
- S := S + 'User-Agent: ' + UserAgent + #13#10;
- S := S + 'Connection: Close'#13#10#13#10;
- Result := Process(Url, S);
-end;
-
-function THttpClient.Post(const Url: TUrl; const Headers: TNamedStrings;
- const ContentType: string; const Content: string): Boolean;
-var
- Name, Value: string;
- S: string;
- I: Integer;
-begin
- S := 'POST ' + Url.Resource + ' HTTP/1.0'#13#10 +
- 'Host: ' + Url.Domain + #13#10;
- for I := 0 to Headers.Count - 1 do
- begin
- Name := Headers.Names[I];
- Value := Headers.ValueByIndex[I];
- S := S + Name + ': ' + Value + #13#10;
- end;
- if Content.Length > 0 then
- begin
- S := S + 'Content-Type: ' + ContentType + #13#10;
- S := S + 'Content-Length: ' + IntToStr(Content.Length) + #13#10;
- end;
- if UserAgent <> '' then
- S := S + 'User-Agent: ' + UserAgent + #13#10;
- S := S + 'Connection: Close'#13#10#13#10;
- if Content.Length > 0 then
- S := S + Content;
- Result := Process(Url, S);
-end;
-
-function THttpClient.PostArgs(const Url: TUrl; const Args: TNamedStrings): Boolean;
-var
- S: string;
-begin
- S := HttpRequestPostArgs(Url, Args, FUserAgent);
- Result := Process(Url, S);
-end;
-
-function THttpClient.PostJson(const Url: TUrl; const Json: string): Boolean;
-var
- S: string;
-begin
- S := HttpRequestPostJson(Url, Json, FUserAgent);
- Result := Process(Url, S);
-end;
-
-function THttpClient.PostXml(const Url: TUrl; Doc: IDocument): Boolean;
-var
- S: string;
-begin
- S := HttpRequestPostXml(Url, Doc, FUserAgent);
- Result := Process(Url, S);
-end;
-
-function HttpResponseHeaderExtract(var Buffer: string; out Header: string; out BreakStyle: string): Boolean;
-const
- Breaks: array[0..3] of string = (#10#10, #13#10#13#10, #13#13, #10#13#10#13);
-var
- First, Index: Integer;
- I, J: Integer;
-begin
- Result := False;
- Header := '';
- BreakStyle := '';
- First := -1;
- Index := -1;
- for I := Low(Breaks) to High(Breaks) do
- begin
- J := Buffer.IndexOf(Breaks[I]);
- if J < 1 then
- Continue;
- if (First < 0) or (J < First) then
- begin
- First := J;
- Index := I;
- end;
- end;
- if Index > -1 then
- begin
- Header := Buffer.FirstOf(Breaks[Index]);
- Buffer := Buffer.SecondOf(Breaks[Index]);
- BreakStyle := Breaks[Index];
- BreakStyle.Length := BreakStyle.Length div 2;
- Result := True;
- end;
-end;
-
-function HttpRequestGet(const Url: TUrl; const UserAgent: string = ''): string;
-begin
- if not Url.Valid then
- Exit('');
- Result :=
- 'GET ' + Url.Resource + ' HTTP/1.0'#13#10 +
- 'Host: ' + Url.Domain + #13#10;
- if UserAgent <> '' then
- Result := Result + 'User-Agent: ' + UserAgent + #13#10;
- Result := Result + 'Connection: Close'#13#10#13#10;
-end;
-
-function HttpRequestPostArgs(const Url: TUrl; const Args: TNamedStrings; const UserAgent: string = ''): string;
-var
- Content: string;
-begin
- if not Url.Valid then
- Exit('');
- Content := ArgsEncode(Args);
- Result :=
- 'POST ' + Url.Resource + ' HTTP/1.0'#13#10 +
- 'Host: ' + Url.Domain + #13#10 +
- 'Content-Length: ' + IntToStr(Content.Length) + #13#10 +
- 'Content-Type: ' + ContentArgs + #13#10;
- if UserAgent <> '' then
- Result := Result + 'User-Agent: ' + UserAgent + #13#10;
- Result := Result + 'Connection: Close'#13#10#13#10 + Content;
-end;
-
-function HttpRequestPostJson(const Url: TUrl; const Json: string; const UserAgent: string = ''): string;
-begin
- if not Url.Valid then
- Exit('');
- Result :=
- 'POST ' + Url.Resource + ' HTTP/1.0'#13#10 +
- 'Host: ' + Url.Domain + #13#10 +
- 'Content-Length: ' + IntToStr(Json.Length) + #13#10 +
- 'Content-Type: ' + ContentJson + #13#10;
- if UserAgent <> '' then
- Result := Result + 'User-Agent: ' + UserAgent + #13#10;
- Result := Result + 'Connection: Close'#13#10#13#10 + Json;
-end;
-
-function HttpRequestPostXml(const Url: TUrl; Doc: IDocument; const UserAgent: string = ''): string;
-var
- S: string;
-begin
- if not Url.Valid then
- Exit('');
- S := Doc.Xml;
- if S = '' then
- Exit('');
- Result :=
- 'POST ' + Url.Resource + ' HTTP/1.0'#13#10 +
- 'Host: ' + Url.Domain + #13#10 +
- 'Content-Length: ' + IntToStr(S.Length) + #13#10 +
- 'Content-Type: ' + ContentXml + #13#10;
- if UserAgent <> '' then
- Result := Result + 'User-Agent: ' + UserAgent + #13#10;
- Result := Result + 'Connection: Close'#13#10#13#10 + S;
-end;
-
-function UrlEncode(const Value: string): string;
-var
- C: Char;
- I: Integer;
-begin
- Result := '';
- for I := 1 to Value.Length do
- begin
- C := Value[I];
- if C in ['-', '_', '0'..'9', 'A'..'Z', 'a'..'z'] then
- Result := Result + C
- else
- Result := Result + '%' + IntToHex(Ord(C), 2);
- end;
-end;
-
-function UrlDecode(const Value: string): string;
-var
- C: Char;
- S: string;
- I, J: Integer;
-begin
- Result := '';
- I := Value.Length;
- J := 1;
- while J < I do
- begin
- C := Value[J];
- if C = '%' then
- begin
- if J + 2 > I then
- Exit('');
- S := '$' + Value[J + 1] + Value[J + 2];
- C := Chr(StrToInt(S));
- Inc(J, 2);
- end;
- Result := Result + C;
- Inc(J);
- end;
-end;
-
-function ArgsEncode(const Args: TNamedStrings): string;
-var
- N, V: string;
- I: Integer;
-begin
- Result := '';
- for I := 0 to Args.Count - 1 do
- begin
- if Result <> '' then
- Result := Result + '&';
- N := Args.Names[I];
- V := Args.ValueByIndex[I];
- Result := Result + UrlEncode(N) + '=' + UrlEncode(V);
- end;
-end;
-
-function ArgsDecode(const Args: string): TNamedStrings;
-var
- Pairs, NameValue: StringArray;
- S: string;
- N, V: string;
-begin
- Result.Clear;
- Pairs := Args.Split('&');
- for S in Pairs do
- begin
- NameValue := S.Split('=');
- if NameValue.Length <> 2 then
- begin
- Result.Clear;
- Exit;
- end;
- N := UrlDecode(NameValue[0]);
- V := UrlDecode(NameValue[1]);
- if N <> '' then
- Result.Add(N, V);
- end;
-end;
-
-function WebGet(const Url: TUrl; Response: TStream; const UserAgent: string = ''): Boolean;
-var
- Request: THttpClient;
-begin
- Request := THttpClient.Create;
- try
- Request.UserAgent := UserAgent;
- Request.ResponseStream := Response;
- Result := Request.Get(Url);
- finally
- Request.Free;
- end;
-end;
-
-function WebGet(const Url: TUrl; out Response: string; const UserAgent: string = ''): Boolean;
-var
- Request: THttpClient;
-begin
- Request := THttpClient.Create;
- try
- Request.UserAgent := UserAgent;
- Result := Request.Get(Url);
- Response := Request.ResponseText;
- finally
- Request.Free;
- end;
-end;
-
-end.
-
diff --git a/source/codebot.pas b/source/codebot.pas
deleted file mode 100644
index 4178c8f..0000000
--- a/source/codebot.pas
+++ /dev/null
@@ -1,41 +0,0 @@
-{ This file was automatically created by Lazarus. Do not edit!
- This source is only used to compile and install the package.
- }
-
-unit codebot;
-
-interface
-
-uses
- Codebot.Constants, Codebot.Core, Codebot.System, Codebot.Collections,
- Codebot.Interop.Windows.Direct2D, Codebot.Interop.Windows.GdiPlus,
- Codebot.Interop.Windows.ImageCodecs, Codebot.Interop.Windows.Msxml,
- Codebot.Interop.Linux.NetWM, Codebot.Interop.Linux.Xml2,
- Codebot.Interop.Sockets, Codebot.Interop.OpenSSL, Codebot.Text,
- Codebot.Cryptography, Codebot.Text.Xml, Codebot.Networking,
- Codebot.Networking.Storage, Codebot.Networking.Ftp, Codebot.Networking.Web,
- Codebot.Forms.Management, Codebot.Forms.Floating, Codebot.Forms.Popup,
- Codebot.Forms.Widget, Codebot.Graphics.Windows.ImageBitmap,
- Codebot.Graphics.Windows.InterfacedBitmap, Codebot.Graphics,
- Codebot.Graphics.Extras, Codebot.Graphics.Types,
- Codebot.Graphics.Windows.SurfaceGdiPlus,
- Codebot.Graphics.Windows.SurfaceD2D, Codebot.Graphics.Linux.SurfaceCairo,
- Codebot.Controls.Tooltips, Codebot.Controls.Extras,
- Codebot.Controls.Scrolling, Codebot.Controls.Sliders, Codebot.Input.Hotkeys,
- Codebot.Input.MouseMonitor, Codebot.Controls, Codebot.Controls.Colors,
- Codebot.Controls.Edits, Codebot.Controls.Banner, Codebot.Controls.Grids,
- Codebot.Design.ImageListEditor, Codebot.Design.SurfaceBitmapEditor,
- Codebot.Controls.Buttons, Codebot.Graphics.Markup,
- Codebot.Controls.Containers, Codebot.Controls.Highlighter,
- Codebot.Animation, Codebot.Geometry, Codebot.Debug, Codebot.Unique,
- LazarusPackageIntf;
-
-implementation
-
-procedure Register;
-begin
-end;
-
-initialization
- RegisterPackage('codebot', @Register);
-end.
diff --git a/source/codebot/codebot.animation.pas b/source/codebot/codebot.animation.pas
new file mode 100644
index 0000000..7e7390d
--- /dev/null
+++ b/source/codebot/codebot.animation.pas
@@ -0,0 +1,1586 @@
+(********************************************************)
+(* *)
+(* Codebot Pascal Library *)
+(* http://cross.codebot.org *)
+(* Modified March 2015 *)
+(* *)
+(********************************************************)
+
+{ }
+unit Codebot.Animation;
+
+{$i codebot.inc}
+
+interface
+
+uses
+ SysUtils, Classes,
+ Codebot.System,
+ Codebot.Collections,
+ Codebot.Graphics.Types,
+ Codebot.Geometry;
+
+{ TEasing is the function prototype for change over time [group animation]
+ See also
+
+
+ External: Easing functions on easings.net }
+
+type
+ TEasing = function(Percent: Float): Float;
+
+{ TEasingDefaults provides some default easing functions which conform to
+ the [group animation]
+ See also
+
+
+ External: Easing functions on easings.net }
+
+ TEasingDefaults = record
+ public
+ { The default easing function with no interpolation }
+ class function Linear(Percent: Float): Float; static;
+ { Slow, fast, then slow }
+ class function Easy(Percent: Float): Float; static;
+ { Real slow, fast, then real slow }
+ class function EasySlow(Percent: Float): Float; static;
+ { Wind up slow, fast, then overshoot and wind down slow }
+ class function Extend(Percent: Float): Float; static;
+ { Slow then fast }
+ class function Drop(Percent: Float): Float; static;
+ { Real slow then fast }
+ class function DropSlow(Percent: Float): Float; static;
+ { Real slow then fast }
+ class function Snap(Percent: Float): Float; static;
+ { Slow, fast, then bounce a few times }
+ class function Bounce(Percent: Float): Float; static;
+ { Slow, fast, then bounce a few more times }
+ class function Bouncy(Percent: Float): Float; static;
+ { Fast, then rebound slowly down }
+ class function Rubber(Percent: Float): Float; static;
+ { Fast, then rebound fast }
+ class function Spring(Percent: Float): Float; static;
+ { Fast, then rebound realy fast }
+ class function Boing(Percent: Float): Float; static;
+ end;
+
+{ TEasings is a dictionary which stores easings by name [group animation]
+ See also
+ }
+
+ TEasings = class(TDictionary)
+ protected
+ {doc off}
+ function DefaultValue: TEasing; override;
+ public
+ procedure RegisterDefaults;
+ {doc on}
+ end;
+
+{ Shortcut to easings key value type }
+
+ TEasingKeyValue = TEasings.TKeyValue;
+
+{ Calculates the percent change of an easing, optionally reversing the curve [group animation] }
+function Interpolate(Easing: TEasing; Percent: Float; Reverse: Boolean = False): Float; overload;
+{ Calculates the effect of an easing on values, optionally reversing the curve [group animation] }
+function Interpolate(Easing: TEasing; Percent: Float; Start, Finish: Float; Reverse: Boolean = False): Float; overload;
+{ Provides access to [group animation] }
+function Easings: TEasings;
+
+{ IDependencyProperty allows vector properties to be dettached from their owning
+ objects [group animation]
+ }
+
+type
+ IDependencyProperty = interface
+ ['{E021AD95-9985-48AB-B29F-8D25A7BBE10E}']
+ {doc ignore}
+ function GetCount: Integer;
+ { Get a component value }
+ function GetValue(Index: Integer): Float;
+ { Set a component value }
+ procedure SetValue(Value: Float; Index: Integer);
+ { Returns the number of component values }
+ property Count: Integer read GetCount;
+ end;
+
+{ TDependencyChangeNotify allows objects which own dependency properties to be
+ notified when the property values are updated other code [group animation] }
+
+ TDependencyChangeNotify = procedure(Prop: IDependencyProperty; Index: Integer) of object;
+
+{ TVec1Prop is a 1 component dependency property [group animation]
+ }
+
+ TVec1Prop = record
+ private
+ {doc off}
+ function GetValue: TVec1;
+ procedure SetValue(Value: TVec1);
+ function GetVec({%H-}Index: Integer): TVec1Prop;
+ procedure SetVec({%H-}Index: Integer; const Value: TVec1Prop);
+ public
+ class operator Implicit(const Value: TVec1): TVec1Prop;
+ class operator Implicit(const Value: TVec1Prop): TVec1;
+ class operator Negative(const A: TVec1Prop): TVec1;
+ class operator Positive(const A: TVec1Prop): TVec1;
+ class operator Equal(const A, B: TVec1Prop) : Boolean;
+ class operator NotEqual(const A, B: TVec1Prop): Boolean;
+ class operator GreaterThan(const A, B: TVec1Prop): Boolean;
+ class operator GreaterThanOrEqual(const A, B: TVec1Prop): Boolean;
+ class operator LessThan(const A, B: TVec1Prop): Boolean;
+ class operator LessThanOrEqual(const A, B: TVec1Prop): Boolean;
+ class operator Add(const A, B: TVec1Prop): TVec1;
+ class operator Subtract(const A, B: TVec1Prop): TVec1;
+ class operator Multiply(const A, B: TVec1Prop): TVec1;
+ class operator Divide(const A, B: TVec1Prop): TVec1;
+ procedure Link(OnChange: TDependencyChangeNotify = nil); overload;
+ procedure Link(Prop: IDependencyProperty; Index: LongInt); overload;
+ procedure Unlink;
+ function Linked: Boolean;
+ function Equals(const A: TVec1Prop): Boolean;
+ function Same(const A: TVec1Prop): Boolean;
+ property X: TVec1Prop index 0 read GetVec write SetVec;
+ property Value: TVec1 read GetValue write SetValue;
+ property Vec[Index: Integer]: TVec1Prop read GetVec write SetVec;
+ private
+ FProp: IDependencyProperty;
+ case Boolean of
+ True: (FIndex: LongInt);
+ False: (FValue: TVec1);
+ {doc on}
+ end;
+
+{ TVec2Prop is a 2 component dependency property [group animation]
+ }
+
+ TVec2Prop = record
+ private
+ {doc off}
+ function GetValue: TVec2;
+ procedure SetValue(const Value: TVec2);
+ function GetVec(Index: Integer): TVec1Prop;
+ procedure SetVec(Index: Integer; const Value: TVec1Prop);
+ public
+ class operator Implicit(const Value: TVec2Prop): TVec2;
+ class operator Implicit(const Value: TVec2): TVec2Prop;
+ class operator Implicit(const Value: TPoint): TVec2Prop;
+ class operator Explicit(const Value: TVec2Prop): TPoint;
+ class operator Implicit(const Value: TPointI): TVec2Prop;
+ class operator Explicit(const Value: TVec2Prop): TPointI;
+ class operator Implicit(const Value: TPointF): TVec2Prop;
+ class operator Implicit(const Value: TVec2Prop): TPointF;
+ class operator Negative(const A: TVec2Prop): TVec2;
+ class operator Add(const A, B: TVec2Prop): TVec2;
+ class operator Subtract(const A, B: TVec2Prop): TVec2;
+ class operator Multiply(const A: TVec2Prop; B: Float): TVec2;
+ class operator Divide(const A: TVec2Prop; B: Float): TVec2;
+ procedure Link(OnChange: TDependencyChangeNotify = nil); overload;
+ procedure Link(Prop: IDependencyProperty; Index: LongInt); overload;
+ procedure Unlink;
+ function Linked: Boolean;
+ property X: TVec1Prop index 0 read GetVec write SetVec;
+ property Y: TVec1Prop index 1 read GetVec write SetVec;
+ property AsVec1: TVec1Prop index 0 read GetVec write SetVec;
+ property Value: TVec2 read GetValue write SetValue;
+ property Vec[Index: Integer]: TVec1Prop read GetVec write SetVec;
+ private
+ FProp: IDependencyProperty;
+ case Boolean of
+ True: (FIndex: LongInt);
+ False: (FValue: TVec2);
+ {doc on}
+ end;
+
+{ TVec3Prop is a 3 component dependency property
+ }
+
+ TVec3Prop = record
+ private
+ {doc off}
+ function GetValue: TVec3;
+ procedure SetValue(const Value: TVec3);
+ function GetVec(Index: Integer): TVec1Prop;
+ procedure SetVec(Index: Integer; const Value: TVec1Prop);
+ function GetAsVec2: TVec2Prop;
+ procedure SetAsVec2(const Value: TVec2Prop);
+ public
+ class operator Implicit(const Value: TVec3Prop): TVec3;
+ class operator Implicit(const Value: TVec3): TVec3Prop;
+ class operator Negative(const A: TVec3Prop): TVec3;
+ class operator Add(const A, B: TVec3Prop): TVec3;
+ class operator Subtract(const A, B: TVec3Prop): TVec3;
+ class operator Multiply(const A: TVec3Prop; B: Float): TVec3;
+ class operator Divide(const A: TVec3Prop; B: Float): TVec3;
+ procedure Link(OnChange: TDependencyChangeNotify = nil); overload;
+ procedure Link(Prop: IDependencyProperty; Index: LongInt); overload;
+ procedure Unlink;
+ function Linked: Boolean;
+ property X: TVec1Prop index 0 read GetVec write SetVec;
+ property Y: TVec1Prop index 1 read GetVec write SetVec;
+ property Z: TVec1Prop index 2 read GetVec write SetVec;
+ property Pitch: TVec1Prop index 0 read GetVec write SetVec;
+ property Heading: TVec1Prop index 1 read GetVec write SetVec;
+ property Roll: TVec1Prop index 2 read GetVec write SetVec;
+ property XY: TVec2Prop read GetAsVec2 write SetAsVec2;
+ property AsVec1: TVec1Prop index 0 read GetVec write SetVec;
+ property AsVec2: TVec2Prop read GetAsVec2 write SetAsVec2;
+ property Value: TVec3 read GetValue write SetValue;
+ property Vec[Index: Integer]: TVec1Prop read GetVec write SetVec;
+ private
+ FProp: IDependencyProperty;
+ case Boolean of
+ True: (FIndex: LongInt);
+ False: (FValue: TVec3);
+ {doc on}
+ end;
+
+{ TVec4Prop is a 4 component dependency property [group animation]
+ }
+
+ TVec4Prop = record
+ private
+ {doc off}
+ function GetValue: TVec4;
+ procedure SetValue(const Value: TVec4);
+ function GetVec(Index: Integer): TVec1Prop;
+ procedure SetVec(Index: Integer; const Value: TVec1Prop);
+ function GetAsVec2: TVec2Prop;
+ procedure SetAsVec2(const Value: TVec2Prop);
+ function GetAsVec3: TVec3Prop;
+ procedure SetAsVec3(const Value: TVec3Prop);
+ public
+ class operator Implicit(const Value: TVec4): TVec4Prop;
+ class operator Implicit(const Value: TVec4Prop): TVec4;
+ class operator Implicit(Value: TColorB): TVec4Prop;
+ class operator Explicit(const Value: TVec4Prop): TColorB;
+ class operator Implicit(const Value: TColorF): TVec4Prop;
+ class operator Implicit(const Value: TVec4Prop): TColorF;
+ procedure Link(OnChange: TDependencyChangeNotify = nil); overload;
+ procedure Link(Prop: IDependencyProperty; Index: LongInt); overload;
+ procedure Unlink;
+ function Linked: Boolean;
+ property X: TVec1Prop index 0 read GetVec write SetVec;
+ property Y: TVec1Prop index 1 read GetVec write SetVec;
+ property Z: TVec1Prop index 2 read GetVec write SetVec;
+ property W: TVec1Prop index 3 read GetVec write SetVec;
+ property Red: TVec1Prop index 0 read GetVec write SetVec;
+ property Green: TVec1Prop index 1 read GetVec write SetVec;
+ property Blue: TVec1Prop index 2 read GetVec write SetVec;
+ property Alpha: TVec1Prop index 3 read GetVec write SetVec;
+ property S0: TVec1Prop index 0 read GetVec write SetVec;
+ property T0: TVec1Prop index 1 read GetVec write SetVec;
+ property S1: TVec1Prop index 2 read GetVec write SetVec;
+ property T1: TVec1Prop index 3 read GetVec write SetVec;
+ property XY: TVec2Prop read GetAsVec2 write SetAsVec2;
+ property XYZ: TVec3Prop read GetAsVec3 write SetAsVec3;
+ property RGB: TVec3Prop read GetAsVec3 write SetAsVec3;
+ property AsVec1: TVec1Prop index 0 read GetVec write SetVec;
+ property AsVec2: TVec2Prop read GetAsVec2 write SetAsVec2;
+ property AsVec3: TVec3Prop read GetAsVec3 write SetAsVec3;
+ property Value: TVec4 read GetValue write SetValue;
+ property Vec[Index: Integer]: TVec1Prop read GetVec write SetVec;
+ private
+ FProp: IDependencyProperty;
+ case Boolean of
+ True: (FIndex: LongInt);
+ False: (FValue: TVec4);
+ {doc on}
+ end;
+
+{ Link a dependency property [group animation] }
+procedure DependencyLink(var Prop: IDependencyProperty; Count: Integer; OnChange: TDependencyChangeNotify);
+{ Unlink a dependency property [group animation] }
+procedure DependencyUnlink(var Prop: IDependencyProperty);
+
+type
+ {doc ignore}
+ IPropertyResolver = interface;
+
+{ TVectorProperty is the result of resolved vector properties
+ }
+
+ TVectorProperty = record
+ Vec1Prop: TVec1Prop;
+ Vec2Prop: TVec2Prop;
+ Vec3Prop: TVec3Prop;
+ Vec4Prop: TVec4Prop;
+ Resolver: IPropertyResolver;
+ end;
+
+
+{ IPropertyResolver is used to convert a name to a vector property
+ }
+
+ IPropertyResolver = interface
+ ['{1638C795-D894-4B7F-9491-47F57A88F622}']
+ { Ask the object to resolve a name }
+ function Resolve(const Name: string; out Prop: TVectorProperty): Boolean;
+ end;
+
+{ Return false while clearing a vector property }
+
+function VectorPropertyEmpty(out Prop: TVectorProperty): Boolean;
+
+{ TAnimationTimer is a high performance timer fixed at 30 frames per second [group animation]
+ See also
+ }
+
+type
+ TAnimationTimer = class(TComponent)
+ private
+ FEnabled: Boolean;
+ FOnTimer: TNotifyEvent;
+ procedure Timer(Sender: TObject);
+ procedure SetEnabled(Value: Boolean);
+ public
+ { Create a new aniamtion timer }
+ constructor Create(AOwner: TComponent); override;
+ destructor Destroy; override;
+ published
+ { Start or stop the timer using enabled }
+ property Enabled: Boolean read FEnabled write SetEnabled default False;
+ { OnTimer is fired every 1/30 of a second when enabled }
+ property OnTimer: TNotifyEvent read FOnTimer write FOnTimer;
+ end;
+
+{ TAnimator }
+
+ TAnimator = class
+ private
+ type
+ TAnimationItem = record
+ Notify: IFloatPropertyNotify;
+ Prop: PFloat;
+ StartTarget: Float;
+ StopTarget: Float;
+ StartTime: Double;
+ StopTime: Double;
+ Easing: TEasing;
+ end;
+ PAnimationItem = ^TAnimationItem;
+
+ TAnimations = TArrayList;
+
+ var
+ FAnimations: TAnimations;
+ FAnimated: Boolean;
+ FOnStart: TNotifyDelegate;
+ FOnStop: TNotifyDelegate;
+ public
+ { Animate adds a property to the list of animated items }
+ procedure Animate(var Prop: Float; Target: Float; const Easing: string; Duration: Double = 0.25); overload;
+ procedure Animate(var Prop: Float; Target: Float; Easing: TEasing = nil; Duration: Double = 0.25); overload;
+ procedure Animate(NotifyObject: TObject; var Prop: Float; Target: Float; const Easing: string; Duration: Double = 0.25); overload;
+ procedure Animate(NotifyObject: TObject; var Prop: Float; Target: Float; Easing: TEasing = nil; Duration: Double = 0.25); overload;
+ { Stop removes a property animation }
+ procedure Stop(var Prop: Float);
+ { Step causes all animated properties to be evaluated }
+ procedure Step;
+ { Animated is True is if a property value changed when Step was last invoked }
+ property Animated: Boolean read FAnimated;
+ { OnStart is invoked if an animated property requires steps }
+ property OnStart: TNotifyDelegate read FOnStart;
+ { OnStop is when there are no more properties to animate }
+ property OnStop: TNotifyDelegate read FOnStop;
+ end;
+
+function Animator: TAnimator;
+
+implementation
+
+{ Easings }
+
+var
+ InternalEasings: TObject;
+
+function Easings: TEasings;
+begin
+ if InternalEasings = nil then
+ begin
+ InternalEasings := TEasings.Create;
+ TEasings(InternalEasings).RegisterDefaults;
+ end;
+ Result := TEasings(InternalEasings);
+end;
+
+{ TVec1Prop }
+
+class operator TVec1Prop.Implicit(const Value: TVec1Prop): TVec1;
+begin
+ Result := Value.Value;
+end;
+
+class operator TVec1Prop.Implicit(const Value: TVec1): TVec1Prop;
+begin
+ UIntPtr(Result.FProp) := 0;
+ Result.FValue := Value;
+end;
+
+class operator TVec1Prop.Negative(const A: TVec1Prop): TVec1;
+begin
+ Result := -A.Value;
+end;
+
+class operator TVec1Prop.Positive(const A: TVec1Prop): TVec1;
+begin
+ Result := A.Value;
+end;
+
+class operator TVec1Prop.Equal(const A, B: TVec1Prop) : Boolean;
+begin
+ Result := A.Value = B.Value;
+end;
+
+class operator TVec1Prop.NotEqual(const A, B: TVec1Prop): Boolean;
+begin
+ Result := A.Value <> B.Value;
+end;
+
+class operator TVec1Prop.GreaterThan(const A, B: TVec1Prop): Boolean;
+begin
+ Result := A.Value > B.Value;
+end;
+
+class operator TVec1Prop.GreaterThanOrEqual(const A, B: TVec1Prop): Boolean;
+begin
+ Result := A.Value >= B.Value;
+end;
+
+class operator TVec1Prop.LessThan(const A, B: TVec1Prop): Boolean;
+begin
+ Result := A.Value < B.Value;
+end;
+
+class operator TVec1Prop.LessThanOrEqual(const A, B: TVec1Prop): Boolean;
+begin
+ Result := A.Value <= B.Value;
+end;
+
+class operator TVec1Prop.Add(const A, B: TVec1Prop): TVec1;
+begin
+ Result := A.Value + B.Value;
+end;
+
+class operator TVec1Prop.Subtract(const A, B: TVec1Prop): TVec1;
+begin
+ Result := A.Value - B.Value;
+end;
+
+class operator TVec1Prop.Multiply(const A, B: TVec1Prop): TVec1;
+begin
+ Result := A.Value * B.Value;
+end;
+
+class operator TVec1Prop.Divide(const A, B: TVec1Prop): TVec1;
+begin
+ Result := A.Value / B.Value;
+end;
+
+procedure TVec1Prop.Link(OnChange: TDependencyChangeNotify = nil);
+begin
+ DependencyLink(FProp, 1, OnChange);
+ FIndex := 0;
+end;
+
+procedure TVec1Prop.Link(Prop: IDependencyProperty; Index: LongInt);
+begin
+ FProp := Prop;
+ FIndex := Index;
+end;
+
+procedure TVec1Prop.Unlink;
+begin
+ FProp := nil;
+end;
+
+function TVec1Prop.Linked: Boolean;
+var
+ B: Boolean;
+begin
+ B := FProp <> nil;
+ Result := B;
+end;
+
+function TVec1Prop.Equals(const A: TVec1Prop): Boolean;
+begin
+ Result := Value = A.Value;
+end;
+
+function TVec1Prop.Same(const A: TVec1Prop): Boolean;
+begin
+ if FProp = nil then
+ Result := False
+ else if FProp = A.FProp then
+ Result := FIndex = A.FIndex
+ else
+ Result := False;
+end;
+
+function TVec1Prop.GetValue: TVec1;
+begin
+ if FProp = nil then
+ Result := FValue
+ else
+ Result := FProp.GetValue(FIndex);
+end;
+
+procedure TVec1Prop.SetValue(Value: TVec1);
+begin
+ if FProp = nil then
+ FValue := Value
+ else
+ FProp.SetValue(Value, FIndex);
+end;
+
+function TVec1Prop.GetVec(Index: Integer): TVec1Prop;
+begin
+ Exit(Self);
+end;
+
+procedure TVec1Prop.SetVec(Index: Integer; const Value: TVec1Prop);
+begin
+ if not Same(Value) then
+ SetValue(Value.Value);
+end;
+
+{ TVec2Prop }
+
+class operator TVec2Prop.Implicit(const Value: TVec2Prop): TVec2;
+begin
+ Result := Value.Value;
+end;
+
+class operator TVec2Prop.Implicit(const Value: TVec2): TVec2Prop;
+begin
+ UIntPtr(Result.FProp) := 0;
+ Result.FValue := Value;
+end;
+
+class operator TVec2Prop.Implicit(const Value: TPoint): TVec2Prop;
+begin
+ UIntPtr(Result.FProp) := 0;
+ Result.FValue.X := Value.X;
+ Result.FValue.Y := Value.Y;
+end;
+
+class operator TVec2Prop.Explicit(const Value: TVec2Prop): TPoint;
+var
+ V: TVec2;
+begin
+ V := Value.Value;
+ Result.X := Round(V.X);
+ Result.Y := Round(V.Y);
+end;
+
+class operator TVec2Prop.Implicit(const Value: TPointI): TVec2Prop;
+begin
+ UIntPtr(Result.FProp) := 0;
+ Result.FValue.X := Value.X;
+ Result.FValue.Y := Value.Y;
+end;
+
+class operator TVec2Prop.Explicit(const Value: TVec2Prop): TPointI;
+var
+ V: TVec2;
+begin
+ V := Value.Value;
+ Result.X := Round(V.X);
+ Result.Y := Round(V.Y);
+end;
+
+class operator TVec2Prop.Implicit(const Value: TPointF): TVec2Prop;
+begin
+ UIntPtr(Result.FProp) := 0;
+ Result.FValue.X := Value.X;
+ Result.FValue.Y := Value.Y;
+end;
+
+class operator TVec2Prop.Implicit(const Value: TVec2Prop): TPointF;
+var
+ V: TVec2;
+begin
+ V := Value.Value;
+ Result.X := V.X;
+ Result.Y := V.Y;
+end;
+
+class operator TVec2Prop.Negative(const A: TVec2Prop): TVec2;
+begin
+ Result := -A.Value;
+end;
+
+class operator TVec2Prop.Add(const A, B: TVec2Prop): TVec2;
+begin
+ Result := A.Value + B.Value;
+end;
+
+class operator TVec2Prop.Subtract(const A, B: TVec2Prop): TVec2;
+begin
+ Result := A.Value - B.Value;
+end;
+
+class operator TVec2Prop.Multiply(const A: TVec2Prop; B: Float): TVec2;
+begin
+ Result := A.Value * B;
+end;
+
+class operator TVec2Prop.Divide(const A: TVec2Prop; B: Float): TVec2;
+begin
+ Result := A.Value / B;
+end;
+
+procedure TVec2Prop.Link(OnChange: TDependencyChangeNotify = nil);
+begin
+ DependencyLink(FProp, 2, OnChange);
+ FIndex := 0;
+end;
+
+procedure TVec2Prop.Link(Prop: IDependencyProperty; Index: LongInt);
+begin
+ FProp := Prop;
+ FIndex := Index;
+end;
+
+procedure TVec2Prop.Unlink;
+begin
+ FProp := nil;
+end;
+
+function TVec2Prop.Linked: Boolean;
+begin
+ Result := FProp <> nil;
+end;
+
+function TVec2Prop.GetValue: TVec2;
+begin
+ if FProp = nil then
+ Result := FValue
+ else
+ begin
+ Result.X := FProp.GetValue(FIndex);
+ Result.Y := FProp.GetValue(FIndex + 1);
+ end;
+end;
+
+procedure TVec2Prop.SetValue(const Value: TVec2);
+begin
+ if FProp = nil then
+ FValue := Value
+ else
+ begin
+ FProp.SetValue(Value.X, FIndex);
+ FProp.SetValue(Value.Y, FIndex + 1);
+ end;
+end;
+
+function TVec2Prop.GetVec(Index: Integer): TVec1Prop;
+var
+ V: TVec1Prop;
+begin
+ UIntPtr(V.FProp) := 0;
+ if FProp = nil then
+ begin
+ if Index < 1 then
+ V.FValue := FValue.X
+ else
+ V.FValue := FValue.Y;
+ end
+ else
+ begin
+ V.FProp := FProp;
+ if Index < 1 then
+ V.FIndex := FIndex
+ else
+ V.FIndex := FIndex + 1;
+ end;
+ Exit(V);
+end;
+
+procedure TVec2Prop.SetVec(Index: Integer; const Value: TVec1Prop);
+begin
+ if FProp = nil then
+ begin
+ FProp := nil;
+ if Index < 1 then
+ FValue.X := Value.Value
+ else
+ FValue.Y := Value.Value;
+ end
+ else
+ begin
+ if Index < 1 then
+ FProp.SetValue(Value.Value, FIndex)
+ else
+ FProp.SetValue(Value.Value, FIndex + 1);
+ end;
+end;
+
+{ TVec3Prop }
+
+class operator TVec3Prop.Implicit(const Value: TVec3): TVec3Prop;
+begin
+ UIntPtr(Result.FProp) := 0;
+ Result.FValue := Value;
+end;
+
+class operator TVec3Prop.Implicit(const Value: TVec3Prop): TVec3;
+begin
+ Result := Value.Value;
+end;
+
+class operator TVec3Prop.Negative(const A: TVec3Prop): TVec3;
+begin
+ Result := -A.Value;
+end;
+
+class operator TVec3Prop.Add(const A, B: TVec3Prop): TVec3;
+begin
+ Result := A.Value + B.Value;
+end;
+
+class operator TVec3Prop.Subtract(const A, B: TVec3Prop): TVec3;
+begin
+ Result := A.Value - B.Value;
+end;
+
+class operator TVec3Prop.Multiply(const A: TVec3Prop; B: Float): TVec3;
+begin
+ Result := A.Value * B;
+end;
+
+class operator TVec3Prop.Divide(const A: TVec3Prop; B: Float): TVec3;
+begin
+ Result := A.Value / B;
+end;
+
+procedure TVec3Prop.Link(OnChange: TDependencyChangeNotify = nil);
+begin
+ DependencyLink(FProp, 3, OnChange);
+ FIndex := 0;
+end;
+
+procedure TVec3Prop.Link(Prop: IDependencyProperty; Index: LongInt);
+begin
+ FProp := Prop;
+ FIndex := Index;
+end;
+
+procedure TVec3Prop.Unlink;
+begin
+ FProp := nil;
+end;
+
+function TVec3Prop.Linked: Boolean;
+begin
+ Result := FProp <> nil;
+end;
+
+function TVec3Prop.GetValue: TVec3;
+begin
+ if FProp = nil then
+ Result := FValue
+ else
+ begin
+ Result.X := FProp.GetValue(FIndex);
+ Result.Y := FProp.GetValue(FIndex + 1);
+ Result.Z := FProp.GetValue(FIndex + 2);
+ end;
+end;
+
+procedure TVec3Prop.SetValue(const Value: TVec3);
+begin
+ if FProp = nil then
+ FValue := Value
+ else
+ begin
+ FProp.SetValue(Value.X, FIndex);
+ FProp.SetValue(Value.Y, FIndex + 1);
+ FProp.SetValue(Value.Z, FIndex + 2);
+ end;
+end;
+
+function TVec3Prop.GetVec(Index: Integer): TVec1Prop;
+var
+ V: TVec1Prop;
+begin
+ UIntPtr(V.FProp) := 0;
+ if FProp = nil then
+ begin
+ if Index < 1 then
+ V.FValue := FValue.X
+ else if Index < 2 then
+ V.FValue := FValue.Y
+ else
+ V.FValue := FValue.Z;
+ end
+ else
+ begin
+ V.FProp := FProp;
+ if Index < 1 then
+ V.FIndex := FIndex
+ else if Index < 2 then
+ V.FIndex := FIndex + 1
+ else
+ V.FIndex := FIndex + 2;
+ end;
+ Exit(V);
+end;
+
+procedure TVec3Prop.SetVec(Index: Integer; const Value: TVec1Prop);
+begin
+ if FProp = nil then
+ begin
+ FProp := nil;
+ if Index < 1 then
+ FValue.X := Value.Value
+ else if Index < 2 then
+ FValue.Y := Value.Value
+ else
+ FValue.Z := Value.Value;
+ end
+ else
+ begin
+ if Index < 1 then
+ FProp.SetValue(Value.Value, FIndex)
+ else if Index < 2 then
+ FProp.SetValue(Value.Value, FIndex + 1)
+ else
+ FProp.SetValue(Value.Value, FIndex + 2);
+ end;
+end;
+
+function TVec3Prop.GetAsVec2: TVec2Prop;
+begin
+ Result.Link(FProp, 0);
+end;
+
+procedure TVec3Prop.SetAsVec2(const Value: TVec2Prop);
+var
+ V: TVec2;
+begin
+ V := Value.Value;
+ X := V.X;
+ Y := V.Y;
+end;
+
+{ TVec4Prop }
+
+class operator TVec4Prop.Implicit(const Value: TVec4): TVec4Prop;
+begin
+ UIntPtr(Result.FProp) := 0;
+ Result.FValue := Value;
+end;
+
+class operator TVec4Prop.Implicit(const Value: TVec4Prop): TVec4;
+begin
+ Result := Value.Value;
+end;
+
+class operator TVec4Prop.Implicit(Value: TColorB): TVec4Prop;
+begin
+ UIntPtr(Result.FProp) := 0;
+ Result.FValue := Value;
+end;
+
+class operator TVec4Prop.Explicit(const Value: TVec4Prop): TColorB;
+begin
+ Result := TColorB(Value.Value);
+end;
+
+class operator TVec4Prop.Implicit(const Value: TColorF): TVec4Prop;
+begin
+ UIntPtr(Result.FProp) := 0;
+ Result.FValue := TVec4(Value);
+end;
+
+class operator TVec4Prop.Implicit(const Value: TVec4Prop): TColorF;
+begin
+ Result := TColorF(Value.Value);
+end;
+
+procedure TVec4Prop.Link(OnChange: TDependencyChangeNotify = nil);
+begin
+ DependencyLink(FProp, 4, OnChange);
+ FIndex := 0;
+end;
+
+procedure TVec4Prop.Link(Prop: IDependencyProperty; Index: LongInt);
+begin
+ FProp := Prop;
+ FIndex := Index;
+end;
+
+procedure TVec4Prop.Unlink;
+begin
+ FProp := nil;
+end;
+
+function TVec4Prop.Linked: Boolean;
+begin
+ Result := FProp <> nil;
+end;
+
+function TVec4Prop.GetValue: TVec4;
+begin
+ if FProp = nil then
+ Result := FValue
+ else
+ begin
+ Result.X := FProp.GetValue(FIndex);
+ Result.Y := FProp.GetValue(FIndex + 1);
+ Result.Z := FProp.GetValue(FIndex + 2);
+ Result.W := FProp.GetValue(FIndex + 3);
+ end;
+end;
+
+procedure TVec4Prop.SetValue(const Value: TVec4);
+begin
+ if FProp = nil then
+ FValue := Value
+ else
+ begin
+ FProp.SetValue(Value.X, FIndex);
+ FProp.SetValue(Value.Y, FIndex + 1);
+ FProp.SetValue(Value.Z, FIndex + 2);
+ FProp.SetValue(Value.W, FIndex + 3);
+ end;
+end;
+
+function TVec4Prop.GetVec(Index: Integer): TVec1Prop;
+var
+ V: TVec1Prop;
+begin
+ UIntPtr(V.FProp) := 0;
+ if FProp = nil then
+ begin
+ if Index < 1 then
+ V.FValue := FValue.X
+ else if Index < 2 then
+ V.FValue := FValue.Y
+ else if Index < 3 then
+ V.FValue := FValue.Z
+ else
+ V.FValue := FValue.W;
+ end
+ else
+ begin
+ V.FProp := FProp;
+ if Index < 1 then
+ V.FIndex := FIndex
+ else if Index < 2 then
+ V.FIndex := FIndex + 1
+ else if Index < 3 then
+ V.FIndex := FIndex + 2
+ else
+ V.FIndex := FIndex + 3;
+ end;
+ Exit(V);
+end;
+
+procedure TVec4Prop.SetVec(Index: Integer; const Value: TVec1Prop);
+begin
+ if FProp = nil then
+ begin
+ FProp := nil;
+ if Index < 1 then
+ FValue.X := Value.Value
+ else if Index < 2 then
+ FValue.Y := Value.Value
+ else if Index < 3 then
+ FValue.Z := Value.Value
+ else
+ FValue.W := Value.Value;
+ end
+ else
+ begin
+ if Index < 1 then
+ FProp.SetValue(Value.Value, FIndex)
+ else if Index < 2 then
+ FProp.SetValue(Value.Value, FIndex + 1)
+ else if Index < 3 then
+ FProp.SetValue(Value.Value, FIndex + 2)
+ else
+ FProp.SetValue(Value.Value, FIndex + 3);
+ end;
+end;
+
+function TVec4Prop.GetAsVec2: TVec2Prop;
+begin
+ Result.Link(FProp, 0);
+end;
+
+procedure TVec4Prop.SetAsVec2(const Value: TVec2Prop);
+var
+ V: TVec2;
+begin
+ V := Value.Value;
+ X := V.X;
+ Y := V.Y;
+end;
+
+function TVec4Prop.GetAsVec3: TVec3Prop;
+begin
+ Result.Link(FProp, 0);
+end;
+
+procedure TVec4Prop.SetAsVec3(const Value: TVec3Prop);
+var
+ V: TVec3;
+begin
+ V := Value.Value;
+ X := V.X;
+ Y := V.Y;
+ Z := V.Z;
+end;
+
+{ TDependencyProperty }
+
+type
+ TPropertyValues = TArray;
+
+ TDependencyProperty = class(TInterfacedObject, IDependencyProperty)
+ private
+ FValues: TPropertyValues;
+ FOnChange: TDependencyChangeNotify;
+ public
+ function GetCount: Integer;
+ function GetValue(Index: Integer): Float;
+ procedure SetValue(Value: Float; Index: Integer);
+ end;
+
+function TDependencyProperty.GetCount: Integer;
+begin
+ Result := Length(FValues);
+end;
+
+function TDependencyProperty.GetValue(Index: Integer): Float;
+begin
+ Result := FValues[Index];
+end;
+
+procedure TDependencyProperty.SetValue(Value: Float; Index: Integer);
+begin
+ if FValues[Index] <> Value then
+ begin
+ FValues[Index] := Value;
+ if Assigned(FOnChange) then
+ FOnChange(Self, Index);
+ end;
+end;
+
+procedure DependencyLink(var Prop: IDependencyProperty; Count: Integer; OnChange: TDependencyChangeNotify);
+var
+ Dependency: TDependencyProperty;
+begin
+ if Prop = nil then
+ Dependency := TDependencyProperty.Create
+ else
+ Dependency := Prop as TDependencyProperty;
+ SetLength(Dependency.FValues, Count);
+ Dependency.FOnChange := OnChange;
+ Prop := Dependency;
+end;
+
+procedure DependencyUnlink(var Prop: IDependencyProperty);
+var
+ Dependency: TDependencyProperty;
+begin
+ if Prop = nil then
+ Exit;
+ Dependency := Prop as TDependencyProperty;
+ Dependency.FOnChange := nil;
+ Prop := nil;
+end;
+
+function VectorPropertyEmpty(out Prop: TVectorProperty): Boolean;
+begin
+ Prop.Vec1Prop.Value := 0;
+ Prop.Vec2Prop.Value := Vec2(0);
+ Prop.Vec3Prop.Value := Vec3(0);
+ Prop.Vec4Prop.Value := Vec4(0);
+ Prop.Resolver := nil;
+ Result := False;
+end;
+
+{ TAnimator }
+
+var
+ InternalAnimator: TObject;
+
+function Animator: TAnimator;
+begin
+ if InternalAnimator = nil then
+ InternalAnimator := TAnimator.Create;
+ Result := TAnimator(InternalAnimator);
+end;
+
+const
+ NegCosPi = 1.61803398874989; { 2 / -Cos(Pi * 1.2) }
+
+class function TEasingDefaults.Linear(Percent: Float): Float;
+begin
+ Result := Percent;
+end;
+
+class function TEasingDefaults.Easy(Percent: Float): Float;
+begin
+ Result := Percent * Percent * (3 - 2 * Percent);
+end;
+
+class function TEasingDefaults.EasySlow(Percent: Float): Float;
+begin
+ Percent := Easy(Percent);
+ Result := Percent * Percent * (3 - 2 * Percent);
+end;
+
+class function TEasingDefaults.Extend(Percent: Float): Float;
+begin
+ Percent := (Percent * 1.4) - 0.2;
+ Result := 0.5 - Cos(Pi * Percent) / NegCosPi;
+end;
+
+class function Power(const Base, Exponent: Float): Float;
+begin
+ if Exponent = 0 then
+ Result := 1
+ else if (Base = 0) and (Exponent > 0) then
+ Result := 0
+ else
+ Result := Exp(Exponent * Ln(Base));
+end;
+
+class function TEasingDefaults.Drop(Percent: Float): Float;
+begin
+ Result := Percent * Percent;
+end;
+
+class function TEasingDefaults.DropSlow(Percent: Float): Float;
+begin
+ Result := Percent * Percent * Percent * Percent * Percent;
+end;
+
+class function TEasingDefaults.Snap(Percent: Float): Float;
+begin
+ Percent := Percent * Percent;
+ Percent := (Percent * 1.4) - 0.2;
+ Result := 0.5 - Cos(Pi * Percent) / NegCosPi;
+end;
+
+class function TEasingDefaults.Bounce(Percent: Float): Float;
+begin
+ if Percent > 0.9 then
+ begin
+ Result := Percent - 0.95;
+ Result := 1 + Result * Result * 20 - (0.05 * 0.05 * 20);
+ end
+ else if Percent > 0.75 then
+ begin
+ Result := Percent - 0.825;
+ Result := 1 + Result * Result * 16 - (0.075 * 0.075 * 16);
+ end
+ else if Percent > 0.5 then
+ begin
+ Result := Percent - 0.625;
+ Result := 1 + Result * Result * 12 - (0.125 * 0.125 * 12);
+ end
+ else
+ begin
+ Percent := Percent * 2;
+ Result := Percent * Percent;
+ end;
+end;
+
+class function TEasingDefaults.Bouncy(Percent: Float): Float;
+var
+ Scale, Start, Step: Float;
+begin
+ Result := 1;
+ Scale := 5;
+ Start := 0.5;
+ Step := 0.2;
+ if Percent < Start then
+ begin
+ Result := Percent / Start;
+ Result := Result * Result;
+ end
+ else
+ while Step > 0.01 do
+ if Percent < Start + Step then
+ begin
+ Step := Step / 2;
+ Result := (Percent - (Start + Step)) * Scale;
+ Result := Result * Result;
+ Result := Result + 1 - Power(Step * Scale, 2);
+ Break;
+ end
+ else
+ begin
+ Start := Start + Step;
+ Step := Step * 0.6;
+ end;
+end;
+
+class function TEasingDefaults.Rubber(Percent: Float): Float;
+begin
+ if Percent > 0.9 then
+ begin
+ Result := Percent - 0.95;
+ Result := 1 - Result * Result * 20 + (0.05 * 0.05 * 20);
+ end
+ else if Percent > 0.75 then
+ begin
+ Result := Percent - 0.825;
+ Result := 1 + Result * Result * 18 - (0.075 * 0.075 * 18);
+ end
+ else if Percent > 0.5 then
+ begin
+ Result := Percent - 0.625;
+ Result := 1 - Result * Result * 14 + (0.125 * 0.125 * 14);
+ end
+ else
+ begin
+ Percent := Percent * 2;
+ Result := Percent * Percent;
+ end;
+end;
+
+class function TEasingDefaults.Spring(Percent: Float): Float;
+begin
+ Percent := Percent * Percent;
+ Result := Sin(PI * Percent * Percent * 10 - PI / 2) / 4;
+ Result := Result * (1 - Percent) + 1;
+ if Percent < 0.3 then
+ Result := Result * Easy(Percent / 0.3);
+end;
+
+class function TEasingDefaults.Boing(Percent: Float): Float;
+begin
+ Percent := Power(Percent, 1.5);
+ Result := Sin(PI * Power(Percent, 2) * 20 - PI / 2) / 4;
+ Result := Result * (1 - Percent) + 1;
+ if Percent < 0.2 then
+ Result := Result * Easy(Percent / 0.2);
+end;
+
+function TEasings.DefaultValue: TEasing;
+begin
+ Result := @TEasingDefaults.Linear;
+end;
+
+function EasingKeyCompare(constref A, B: string): Integer;
+begin
+ Result := StrCompare(A, B, True);
+end;
+
+
+procedure TEasings.RegisterDefaults;
+begin
+ Comparer := EasingKeyCompare;
+ Self['Linear'] := @TEasingDefaults.Linear;
+ Self['Easy'] := @TEasingDefaults.Easy;
+ Self['EasySlow'] := @TEasingDefaults.EasySlow;
+ Self['Extend'] := @TEasingDefaults.Extend;
+ Self['Drop'] := @TEasingDefaults.Drop;
+ Self['DropSlow'] := @TEasingDefaults.DropSlow;
+ Self['Snap'] := @TEasingDefaults.Snap;
+ Self['Bounce'] := @TEasingDefaults.Bounce;
+ Self['Bouncy'] := @TEasingDefaults.Bouncy;
+ Self['Rubber'] := @TEasingDefaults.Rubber;
+ Self['Spring'] := @TEasingDefaults.Spring;
+ Self['Boing'] := @TEasingDefaults.Boing;
+end;
+
+function Interpolate(Easing: TEasing; Percent: Float; Reverse: Boolean = False): Float;
+begin
+ if Percent < 0 then
+ Result := 0
+ else if Percent > 1 then
+ Result := 1
+ else if Reverse then
+ Result := 1 - Easing(1 - Percent)
+ else
+ Result := Easing(Percent);
+end;
+
+function Interpolate(Easing: TEasing; Percent: Float; Start, Finish: Float; Reverse: Boolean = False): Float;
+begin
+ if Percent < 0 then
+ Result := Start
+ else if Percent > 1 then
+ Result := Finish
+ else
+ begin
+ if Reverse then
+ Percent := 1 - Easing(1 - Percent)
+ else
+ Percent := Easing(Percent);
+ Result := Start * (1 - Percent) + Finish * Percent;
+ end;
+end;
+
+{ TAnimationThread }
+
+type
+ TAnimationThread = class(TThread)
+ private
+ procedure Animate;
+ protected
+ procedure Execute; override;
+ public
+ constructor Create;
+ end;
+
+{ TThreadedTimer }
+
+ TThreadedTimer = class(TObject)
+ private
+ FTimerCount: Integer;
+ FOnTimer: TNotifyDelegate;
+ function GetOnTimer: INotifyDelegate;
+ public
+ destructor Destroy; override;
+ property OnTimer: INotifyDelegate read GetOnTimer;
+ procedure Enable;
+ procedure Disable;
+ end;
+
+{ TThreadedTimer }
+
+var
+ InternalThreadedTimer: TObject;
+
+function ThreadedTimer: TThreadedTimer;
+begin
+ if InternalThreadedTimer = nil then
+ InternalThreadedTimer := TThreadedTimer.Create;
+ Result := TThreadedTimer(InternalThreadedTimer);
+end;
+
+var
+ InternalThread: TObject;
+
+destructor TThreadedTimer.Destroy;
+begin
+ InternalThread := nil;
+ inherited Destroy;
+end;
+
+function TThreadedTimer.GetOnTimer: INotifyDelegate;
+begin
+ Result := FOnTimer;
+end;
+
+procedure TThreadedTimer.Enable;
+begin
+ if InterLockedIncrement(FTimerCount) = 1 then
+ TAnimationThread.Create;
+end;
+
+procedure TThreadedTimer.Disable;
+begin
+ if InterLockedDecrement(FTimerCount) = 0 then
+ InternalThread := nil;
+end;
+
+{ TAnimationThread }
+
+constructor TAnimationThread.Create;
+begin
+ InternalThread := Self;
+ inherited Create(False);
+end;
+
+procedure TAnimationThread.Animate;
+var
+ Event: TNotifyEvent;
+begin
+ if InternalThread <> Self then
+ Exit;
+ if InternalThreadedTimer = nil then
+ Exit;
+ for Event in TThreadedTimer(InternalThreadedTimer).FOnTimer do
+ Event(TThreadedTimer(InternalThreadedTimer));
+end;
+
+const
+ TimerRate = 30;
+
+procedure TAnimationThread.Execute;
+const
+ Delay = 1 / TimerRate;
+var
+ A, B: Double;
+begin
+ A := TimeQuery;
+ FreeOnTerminate := True;
+ while InternalThread = Self do
+ begin
+ Synchronize(Animate);
+ if InternalThread <> Self then
+ Exit;
+ B := TimeQuery - A;
+ while B < Delay do
+ begin
+ B := (Delay - B) * 1000;
+ Sleep(Round(B));
+ B := TimeQuery - A;
+ end;
+ A := TimeQuery - (B - Delay);
+ end;
+end;
+
+{ TAnimationTimer }
+
+constructor TAnimationTimer.Create(AOwner: TComponent);
+begin
+ inherited Create(AOwner);
+ ThreadedTimer.OnTimer.Add(Timer);
+end;
+
+destructor TAnimationTimer.Destroy;
+begin
+ Enabled := False;
+ ThreadedTimer.OnTimer.Remove(Timer);
+ inherited Destroy;
+end;
+
+procedure TAnimationTimer.Timer(Sender: TObject);
+begin
+ if FEnabled and Assigned(FOnTimer) then
+ FOnTimer(Self);
+end;
+
+procedure TAnimationTimer.SetEnabled(Value: Boolean);
+begin
+ if FEnabled = Value then Exit;
+ FEnabled := Value;
+ if csDesigning in ComponentState then Exit;
+ if FEnabled then
+ ThreadedTimer.Enable
+ else
+ ThreadedTimer.Disable;
+end;
+
+{ TAnimator }
+
+procedure TAnimator.Animate(var Prop: Float; Target: Float; const Easing: string; Duration: Double = 0.25);
+var
+ E: TEasing;
+begin
+ E := nil;
+ if Easings.KeyExists(Easing) then
+ E := Easings[Easing];
+ Animate(nil, Prop, Target, E, Duration);
+end;
+
+procedure TAnimator.Animate(var Prop: Float; Target: Float; Easing: TEasing = nil; Duration: Double = 0.25);
+begin
+ Animate(nil, Prop, Target, Easing, Duration);
+end;
+
+procedure TAnimator.Animate(NotifyObject: TObject; var Prop: Float; Target: Float;
+ const Easing: string; Duration: Double = 0.25);
+var
+ E: TEasing;
+begin
+ E := nil;
+ if Easings.KeyExists(Easing) then
+ E := Easings[Easing];
+ Animate(NotifyObject, Prop, Target, E, Duration);
+end;
+
+procedure TAnimator.Animate(NotifyObject: TObject; var Prop: Float; Target: Float;
+ Easing: TEasing = nil; Duration: Double = 0.25);
+var
+ Notify: IFloatPropertyNotify;
+ Event: TNotifyEvent;
+ Item: TAnimationItem;
+begin
+ Stop(Prop);
+ if (NotifyObject <> nil) and (NotifyObject is IFloatPropertyNotify) then
+ Notify := NotifyObject as IFloatPropertyNotify
+ else
+ Notify := nil;
+ if Duration <= 0 then
+ begin
+ Prop := Target;
+ if Notify <> nil then
+ Notify.PropChange(@Prop);
+ Exit;
+ end;
+ Item.Notify := Notify;
+ Item.Prop := @Prop;
+ Item.StartTarget := Prop;
+ Item.StopTarget := Target;
+ Item.StartTime := TimeQuery;
+ Item.StopTime := Item.StartTime + Duration;
+ if @Easing = nil then
+ Easing := TEasingDefaults.Easy;
+ Item.Easing := Easing;
+ if FAnimations.Length = 0 then
+ for Event in FOnStart do
+ Event(Self);
+ FAnimations.Push(Item);
+end;
+
+procedure TAnimator.Stop(var Prop: Float);
+var
+ Item: PAnimationItem;
+ I: Integer;
+begin
+ FAnimated := True;
+ for I := FAnimations.Length - 1 downto 0 do
+ begin
+ Item := @FAnimations.Items[I];
+ if Item.Prop = @Prop then
+ begin
+ if Item.Notify <> nil then
+ Item.Notify.PropChange(Item.Prop);
+ FAnimations.Delete(I);
+ Exit;
+ end;
+ end;
+end;
+
+procedure TAnimator.Step;
+var
+ Event: TNotifyEvent;
+ Time: Double;
+ Percent: Float;
+ Item: PAnimationItem;
+ I: Integer;
+begin
+ Time := TimeQuery;
+ FAnimated := FAnimations.Length > 0;
+ if not FAnimated then
+ begin
+ for Event in FOnStop do
+ Event(Self);
+ Exit;
+ end;
+ for I := FAnimations.Length - 1 downto 0 do
+ begin
+ Item := @FAnimations.Items[I];
+ if Time >= Item.StopTime then
+ begin
+ Item.Prop^ := Item.StopTarget;
+ if Item.Notify <> nil then
+ Item.Notify.PropChange(Item.Prop);
+ FAnimations.Delete(I);
+ Continue;
+ end;
+ Percent := (Time - Item.StartTime) / (Item.StopTime - Item.StartTime);
+ Item.Prop^ := Interpolate(Item.Easing, Percent, Item.StartTarget, Item.StopTarget);
+ if Item.Notify <> nil then
+ Item.Notify.PropChange(Item.Prop);
+ end;
+end;
+
+finalization
+ InternalThreadedTimer.Free;
+ InternalEasings.Free;
+ InternalAnimator.Free;
+end.
+
diff --git a/source/codebot.collections.pas b/source/codebot/codebot.collections.pas
similarity index 85%
rename from source/codebot.collections.pas
rename to source/codebot/codebot.collections.pas
index 869c062..93d572d 100644
--- a/source/codebot.collections.pas
+++ b/source/codebot/codebot.collections.pas
@@ -2,7 +2,7 @@
(* *)
(* Codebot Pascal Library *)
(* http://cross.codebot.org *)
-(* Modified September 2013 *)
+(* Modified August 2019 *)
(* *)
(********************************************************)
@@ -17,9 +17,18 @@ interface
SysUtils, Classes,
Codebot.System;
-type
{doc off}
- TListEnumerator = class(TInterfacedObject, IEnumerator)
+type
+ IIndexedEnumerator = interface(IEnumerator)
+ ['{4F6365A5-B833-4E35-BD2B-9C64C363CC4B}']
+ function GetEnumerator: IIndexedEnumerator;
+ function GetCount: Integer;
+ function GetItem(Index: Integer): T;
+ property Count: Integer read GetCount;
+ property Item[Index: Integer]: T read GetItem; default;
+ end;
+
+ TListEnumerator = class(TInterfacedObject, IEnumerator, IIndexedEnumerator)
private
FItems: TArrayList;
FPosition: Integer;
@@ -29,6 +38,11 @@ TListEnumerator = class(TInterfacedObject, IEnumerator)
function GetCurrent: T;
function MoveNext: Boolean;
procedure Reset;
+ function GetEnumerator: IIndexedEnumerator;
+ function GetCount: Integer;
+ function GetItem(Index: Integer): T;
+ property Count: Integer read GetCount;
+ property Item[Index: Integer]: T read GetItem; default;
end;
{doc on}
@@ -44,7 +58,6 @@ TList = class(TObject)
{ Get the enumerator for the list }
function GetEnumerator: IEnumerator;
private
- FItems: TArrayList;
FCount: Integer;
FCapacity: Integer;
procedure QuickSort(Compare: TListCompare; L, R: Integer);
@@ -56,7 +69,9 @@ TList = class(TObject)
procedure SetCapacity(Value: Integer);
function GetItem(Index: Integer): ItemType;
procedure SetItem(Index: Integer; const Value: ItemType);
+ function GetDirect(Index: Integer): PItemType;
protected
+ FItems: TArrayList;
{ Allows list types to take action on add }
procedure AddItem(constref Item: ItemType); virtual;
{ Allows list types to take action on delete }
@@ -97,6 +112,8 @@ TList = class(TObject)
Remarks
When setting the existing item will be deleted }
property Item[Index: Integer]: ItemType read GetItem write SetItem; default;
+ { Retreive a direct reference to the item }
+ property Direct[Index: Integer]: PItemType read GetDirect;
end;
{ TListDuplicates allows, ignores, or generates errors which a matching value is
@@ -140,7 +157,7 @@ TObjectList = class(TIndexedList)
{ Returns true if the list owns the objects }
function RequiresDelete: Boolean; override;
public
- { Create the lsit optionally owning objects added to it }
+ { Create the list optionally owning objects added to it }
constructor Create(OwnsObjects: Boolean);
{ Returns the index of the object or -1 if it cannot be found }
function IndexOf(const Item: ItemType): Integer; override;
@@ -218,6 +235,8 @@ TKeyValue = class
{ IList }
+ TFindProc = function(Item: T; var Match): Boolean;
+
IList = interface(IEnumerable)
['{79BFA1EC-6CEA-42FA-A602-2FC727436CC0}']
function GetCapacity: Integer;
@@ -227,8 +246,10 @@ TKeyValue = class
procedure Put(I: Integer; Item: T);
procedure Clear;
procedure Delete(Index: Integer);
+ procedure Sort(Compare: TCompare);
procedure Exchange(Index1, Index2: Integer);
function First: T;
+ function Find(FindProc: TFindProc; var Match): T;
function IndexOf(Item: T): Integer;
function Add(Item: T): Integer;
function Last: T;
@@ -239,6 +260,8 @@ TKeyValue = class
property Items[Index: Integer]: T read Get write Put; default;
end;
+{ TReferences }
+
TReferences = class(TInterfacedObject, IList)
private
FList: TList;
@@ -257,9 +280,11 @@ TReferences = class(TInterfacedObject, IList)
procedure Put(I: Integer; Item: T);
procedure Clear;
procedure Delete(Index: Integer);
+ procedure Sort(Compare: TCompare);
procedure Exchange(Index1, Index2: Integer);
function First: T;
function IndexOf(Item: T): Integer; virtual; abstract;
+ function Find(FindProc: TFindProc; var Match): T;
function Add(Item: T): Integer;
function Last: T;
function Remove(Item: T): Integer;
@@ -292,6 +317,27 @@ TInterfaces = class(TReferences)
function IndexOf(Item: T): Integer; override;
end;
+{ TAggregateStream }
+
+ TAggregateStream = class(TStream)
+ private
+ FStreams: TList;
+ FOwns: TList;
+ FIndex: Integer;
+ FSize: LargeInt;
+ procedure Reset;
+ protected
+ function GetSize: Int64; override;
+ public
+ constructor Create;
+ destructor Destroy; override;
+ procedure Clear;
+ procedure AddText(const Text: string);
+ procedure AddFile(const FileName: string);
+ procedure AddStream(Stream: TStream; OwnsStream: Boolean = True);
+ function Read(var Buffer; Count: Longint): Longint; override;
+ end;
+
{docignore}
function FindObject(constref A, B: TObject): Integer;
@@ -329,6 +375,21 @@ procedure TListEnumerator.Reset;
FPosition := -1;
end;
+function TListEnumerator.GetEnumerator: IIndexedEnumerator;
+begin
+ Result := Self;
+end;
+
+function TListEnumerator.GetCount: Integer;
+begin
+ Result := FCount;
+end;
+
+function TListEnumerator.GetItem(Index: Integer): T;
+begin
+ Result := FItems[Index];
+end;
+
{ TList }
function TList.GetEnumerator: IEnumerator;
@@ -408,6 +469,8 @@ procedure TList.Compact;
I := FCount;
if I < ActualMinCapacity then
I := ActualMinCapacity;
+ if FCount = 0 then
+ I := 0;
if I < FCapacity then
begin
FCapacity := I;
@@ -555,6 +618,12 @@ function TList.GetItem(Index: Integer): ItemType;
Result := FItems[Index];
end;
+function TList.GetDirect(Index: Integer): PItemType;
+begin
+ CheckBounds('GetDirect', Index);
+ Result := @FItems.Items[Index];
+end;
+
procedure TList.SetItem(Index: Integer; const Value: ItemType);
begin
CheckBounds('SetItem', Index);
@@ -622,7 +691,7 @@ procedure TObjectList.DeleteItem(var Item: ItemType);
begin
if FOwnsObjects then
Item.Free;
- Item := nil;
+ Item := TObject(nil);
end;
function TObjectList.RequiresDelete: Boolean;
@@ -882,6 +951,11 @@ procedure TReferences.Delete(Index: Integer);
FList.Delete(Index);
end;
+procedure TReferences.Sort(Compare: TCompare);
+begin
+ FList.Sort(Compare);
+end;
+
procedure TReferences.Exchange(Index1, Index2: Integer);
begin
FList.Exchange(Index1, Index2);
@@ -892,6 +966,16 @@ function TReferences.First: T;
Result := FList.First;
end;
+function TReferences.Find(FindProc: TFindProc; var Match): T;
+var
+ I: Integer;
+begin
+ for I := 0 to FList.Count - 1 do
+ if FindProc(FList[I], Match) then
+ Exit(FList[I]);
+ Result := Default(T);
+end;
+
function TReferences.Add(Item: T): Integer;
begin
AddItem(AsPointer(Item));
@@ -980,5 +1064,91 @@ function TInterfaces.IndexOf(Item: T): Integer;
Result := FList.Find(TCompare(@FindInterface), Item);
end;
+{ TAggregateStream }
+
+constructor TAggregateStream.Create;
+begin
+ inherited Create;
+ FStreams := TList.Create;
+ FOwns := TList.Create;
+ Reset;
+end;
+
+destructor TAggregateStream.Destroy;
+begin
+ Clear;
+ FStreams.Free;
+ FOwns.Free;
+ inherited Destroy;
+end;
+
+procedure TAggregateStream.Reset;
+begin
+ FIndex := -1;
+ FSize := -1;
+end;
+
+function TAggregateStream.GetSize: Int64;
+var
+ S: TStream;
+ I: Integer;
+begin
+ if FSize > -1 then
+ Exit(FSize);
+ FSize := 0;
+ for S in FStreams do
+ Inc(FSize, S.Size - S.Position);
+ Result := FSize;
+end;
+
+procedure TAggregateStream.Clear;
+var
+ I: Integer;
+begin
+ Reset;
+ for I := 0 to FOwns.Count - 1 do
+ if FOwns[I] then
+ FStreams[I].Free;
+ FStreams.Clear;
+ FOwns.Clear;
+end;
+
+procedure TAggregateStream.AddText(const Text: string);
+begin
+ AddStream(TStringStream.Create(Text));
+end;
+
+procedure TAggregateStream.AddFile(const FileName: string);
+begin
+ AddStream(TFileStream.Create(FileName, fmOpenRead));
+end;
+
+procedure TAggregateStream.AddStream(Stream: TStream; OwnsStream: Boolean = True);
+begin
+ Reset;
+ FStreams.Add(Stream);
+ FOwns.Add(OwnsStream);
+end;
+
+function TAggregateStream.Read(var Buffer; Count: Integer): Integer;
+var
+ S: TStream;
+begin
+ Result := 0;
+ if Count < 1 then
+ Exit;
+ if FIndex < 0 then
+ Inc(FIndex);
+ if FIndex > FStreams.Count - 1 then
+ Exit;
+ S := FStreams[FIndex];
+ Result := S.Read(Buffer, Count);
+ if Result < 1 then
+ begin
+ Inc(FIndex);
+ Result := Read(Buffer, Count);
+ end;
+end;
+
end.
diff --git a/source/codebot.constants.pas b/source/codebot/codebot.constants.pas
similarity index 96%
rename from source/codebot.constants.pas
rename to source/codebot/codebot.constants.pas
index eaf7ff4..1854080 100644
--- a/source/codebot.constants.pas
+++ b/source/codebot/codebot.constants.pas
@@ -2,7 +2,7 @@
(* *)
(* Codebot Pascal Library *)
(* http://cross.codebot.org *)
-(* Modified September 2013 *)
+(* Modified August 2019 *)
(* *)
(********************************************************)
diff --git a/source/codebot.core.pas b/source/codebot/codebot.core.pas
similarity index 93%
rename from source/codebot.core.pas
rename to source/codebot/codebot.core.pas
index fbf34d9..cd567fa 100644
--- a/source/codebot.core.pas
+++ b/source/codebot/codebot.core.pas
@@ -2,7 +2,7 @@
(* *)
(* Codebot Pascal Library *)
(* http://cross.codebot.org *)
-(* Modified March 2015 *)
+(* Modified August 2019 *)
(* *)
(********************************************************)
@@ -14,6 +14,9 @@
interface
uses
+ {$ifdef unix}
+ CThreads,
+ {$endif}
DynLibs;
type
diff --git a/source/codebot.cryptography.pas b/source/codebot/codebot.cryptography.pas
similarity index 53%
rename from source/codebot.cryptography.pas
rename to source/codebot/codebot.cryptography.pas
index 01ee52b..c5d8fb8 100644
--- a/source/codebot.cryptography.pas
+++ b/source/codebot/codebot.cryptography.pas
@@ -2,7 +2,7 @@
(* *)
(* Codebot Pascal Library *)
(* http://cross.codebot.org *)
-(* Modified September 2013 *)
+(* Modified September 2023 *)
(* *)
(********************************************************)
@@ -51,6 +51,16 @@ function AuthBuffer(const Key: string; Kind: THashKind; var Buffer; BufferSize:
function AuthStream(const Key: string; Kind: THashKind; Stream: TStream): TDigest;
{ Compute the hmac digest of a file }
function AuthFile(const Key: string; Kind: THashKind; const FileName: string): TDigest;
+
+{ TDigestHelper }
+
+type
+ TDigestHelper = record helper for TDigest
+ public
+ { Compute the next hmac digest of a string using the current digest as the key }
+ function AuthNext(Kind: THashKind; const S: string): TDigest;
+ end;
+
{$endregion}
{$region encryption}
@@ -65,144 +75,80 @@ function DecryptSequence(const S: string): string;
implementation
{$region hashing}
-function DigestToStr(const Digest: TDigest): string;
-begin
- Result := HexEncode(Digest);
-end;
-
-type
- THashMethods = record
- Context: array[0..500] of Byte;
- Digest: TDigest;
- Init: function(var Context): LongBool; cdecl;
- Update: function(var Context; Data: Pointer; Size: Cardinal): LongBool; cdecl;
- Final: function(var Digest; var Context): LongBool; cdecl;
- end;
+const
+ BufferSize = 4096;
- TAuthMethod = record
- Digest: TDigest;
- Method: TEVPMethod;
- end;
+var
+ HashInitialized: Boolean;
+ HashMethods: array[THashKind] of TEVPMethod;
-function GetHashMethods(Kind: THashKind; out Methods: THashMethods): Boolean;
+procedure Init;
begin
- OpenSSLInit(True);
- Result := True;
- case Kind of
- hashMD5:
- begin
- Methods.Digest := TBuffer.Create(SizeOf(TMD5Digest));
- Methods.Init := @MD5_Init;
- Methods.Update := @MD5_Update;
- Methods.Final := @MD5_Final;
- end;
- hashSHA1:
- begin
- Methods.Digest := TBuffer.Create(SizeOf(TSHA1Digest));
- Methods.Init := @SHA1_Init;
- Methods.Update := @SHA1_Update;
- Methods.Final := @SHA1_Final;
- end;
- hashSHA256:
- begin
- Methods.Digest := TBuffer.Create(SizeOf(TSHA256Digest));
- Methods.Init := @SHA256_Init;
- Methods.Update := @SHA256_Update;
- Methods.Final := @SHA256_Final;
- end;
- hashSHA512:
- begin
- Methods.Digest := TBuffer.Create(SizeOf(TSHA512Digest));
- Methods.Init := @SHA512_Init;
- Methods.Update := @SHA512_Update;
- Methods.Final := @SHA512_Final;
- end;
- else
- Methods.Digest := TBuffer.Create(0);
- Methods.Init := nil;
- Methods.Update := nil;
- Methods.Final := nil;
- Result := False;
- end;
+ if HashInitialized then
+ Exit;
+ InitCrypto(True);
+ HashMethods[hashMD5] := EVP_md5;
+ HashMethods[hashSHA1] := EVP_sha1;
+ HashMethods[hashSHA256] := EVP_sha256;
+ HashMethods[hashSHA512] := EVP_sha512;
+ HashInitialized := True;
end;
-function GetAuthMethod(Kind: THashKind; out Method: TAuthMethod): Boolean;
+function DigestToStr(const Digest: TDigest): string;
begin
- OpenSSLInit(True);
- Result := True;
- case Kind of
- hashMD5:
- begin
- Method.Digest := TBuffer.Create(SizeOf(TMD5Digest));
- Method.Method := EVP_md5;
- end;
- hashSHA1:
- begin
- Method.Digest := TBuffer.Create(SizeOf(TSHA1Digest));
- Method.Method := EVP_sha1;
- end;
- hashSHA256:
- begin
- Method.Digest := TBuffer.Create(SizeOf(TSHA256Digest));
- Method.Method := EVP_sha256;
- end;
- hashSHA512:
- begin
- Method.Digest := TBuffer.Create(SizeOf(TSHA512Digest));
- Method.Method := EVP_sha512;
- end;
- else
- Method.Digest := TBuffer.Create(0);
- Method.Method := nil;
- Result := False;
- end;
+ Result := HexEncode(Digest);
end;
function HashString(Kind: THashKind; const S: string): TDigest;
begin
- Result := HashBuffer(Kind, PAnsiChar(S)^, Length(S));
+ Result := HashBuffer(Kind, PChar(S)^, Cardinal(Length(S)));
end;
function HashBuffer(Kind: THashKind; var Buffer; BufferSize: Cardinal): TDigest;
var
- Methods: THashMethods;
+ Ctx: TEVPMdCtx;
+ Size: Cardinal;
begin
- if GetHashMethods(Kind, Methods) then
- begin
- Methods.Init(Methods.Context);
- Methods.Update(Methods.Context, @Buffer, BufferSize);
- if not Methods.Final(Methods.Digest.Data^, Methods.Context) then
- Methods.Digest := TDigest.Create(0);
+ Init;
+ Result := TDigest.Create(EVP_MAX_MD_SIZE);
+ Ctx := EVP_MD_CTX_new;
+ try
+ EVP_DigestInit_ex(Ctx, HashMethods[Kind]);
+ EVP_DigestUpdate(Ctx, @Buffer, BufferSize);
+ EVP_DigestFinal(Ctx, Result.Data, Size);
+ Result.Size := LongInt(Size);
+ finally
+ EVP_MD_CTX_free(Ctx);
end;
- Result := Methods.Digest;
end;
function HashStream(Kind: THashKind; Stream: TStream): TDigest;
-const
- BufferSize = $10000;
-var
- Buffer: TBuffer;
- Bytes: LongInt;
-
- function ReadBuffer: Boolean;
- begin
- Bytes := Stream.Read(Buffer.Data^, BufferSize);
- Result := Bytes > 0;
- end;
-
var
- Methods: THashMethods;
+ Ctx: TEVPMdCtx;
+ Size: Cardinal;
+ Bytes: Pointer;
+ BytesRead: LongInt;
begin
- if GetHashMethods(Kind, Methods) then
- begin
- Buffer := TBuffer.Create(BufferSize);
- Methods.Init(Methods.Context);
- while ReadBuffer do
- Methods.Update(Methods.Context, Buffer, Bytes);
- if not Methods.Final(Methods.Digest.Data^, Methods.Context) then
- Methods.Digest := TDigest.Create(0);
+ Init;
+ Result := TDigest.Create(EVP_MAX_MD_SIZE);
+ Bytes := GetMem(BufferSize);
+ Ctx := EVP_MD_CTX_new;
+ try
+ EVP_DigestInit_ex(Ctx, HashMethods[Kind]);
+ BytesRead := Stream.Read(Bytes^, BufferSize);
+ while BytesRead > 0 do
+ begin
+ EVP_DigestUpdate(Ctx, Bytes, Cardinal(BytesRead));
+ BytesRead := Stream.Read(Bytes^, BufferSize);
+ end;
+ if EVP_DigestFinal(Ctx, Result.Data, Size) then
+ Result.Size := LongInt(Size)
+ else
+ Result.Size := 0;
+ finally
+ EVP_MD_CTX_free(Ctx);
+ FreeMem(Bytes);
end;
- Result := Methods.Digest;
end;
function HashFile(Kind: THashKind; const FileName: string): TDigest;
@@ -219,65 +165,56 @@ function HashFile(Kind: THashKind; const FileName: string): TDigest;
function AuthString(const Key: string; Kind: THashKind; const S: string): TDigest;
begin
- Result := AuthBuffer(Key, Kind, Pointer(S)^, Length(S));
+ Result := AuthBuffer(Key, Kind, Pointer(S)^, Cardinal(Length(S)));
end;
function AuthBuffer(const Key: string; Kind: THashKind; var Buffer; BufferSize: Cardinal): TDigest;
var
- Method: TAuthMethod;
- Context: THMACCtx;
- I: LongWord;
+ Ctx: THMACCtx;
+ Size: Cardinal;
begin
- if GetAuthMethod(Kind, Method) then
- begin
- HMAC_CTX_init(Context);
- try
- HMAC_Init_ex(Context, Pointer(Key), Length(Key), Method.Method, nil);
- HMAC_Update(Context, @Buffer, BufferSize);
- I := Method.Digest.Size;
- if not HMAC_Final(Context, Method.Digest, I) then
- Method.Digest := TDigest.Create(0);
- finally
- HMAC_CTX_cleanup(Context);
- end;
+ Init;
+ Result := TDigest.Create(EVP_MAX_MD_SIZE);
+ Ctx := HMAC_CTX_new;
+ try
+ HMAC_Init_ex(Ctx, Pointer(Key), Length(Key), HashMethods[Kind]);
+ HMAC_Update(Ctx, @Buffer, BufferSize);
+ if HMAC_Final(Ctx, Result.Data, Size) then
+ Result.Size := LongInt(Size)
+ else
+ Result.Size := 0;
+ finally
+ HMAC_CTX_free(Ctx);
end;
- Result := Method.Digest;
end;
function AuthStream(const Key: string; Kind: THashKind; Stream: TStream): TDigest;
-const
- BufferSize = $10000;
-var
- Buffer: TBuffer;
- Bytes: LongInt;
-
- function ReadBuffer: Boolean;
- begin
- Bytes := Stream.Read(Buffer.Data^, BufferSize);
- Result := Bytes > 0;
- end;
-
var
- Method: TAuthMethod;
- Context: THMACCtx;
- I: LongWord;
+ Ctx: THMACCtx;
+ Size: Cardinal;
+ Bytes: Pointer;
+ BytesRead: LongInt;
begin
- if GetAuthMethod(Kind, Method) then
- begin
- Buffer := TBuffer.Create(BufferSize);
- HMAC_CTX_init(Context);
- try
- HMAC_Init_ex(Context, Pointer(Key), Length(Key), Method.Method, nil);
- while ReadBuffer do
- HMAC_Update(Context, Buffer, BufferSize);
- I := Method.Digest.Size;
- if not HMAC_Final(Context, Method.Digest, I) then
- Method.Digest := TDigest.Create(0);
- finally
- HMAC_CTX_cleanup(Context);
+ Init;
+ Result := TDigest.Create(EVP_MAX_MD_SIZE);
+ Bytes := GetMem(BufferSize);
+ Ctx := HMAC_CTX_new;
+ try
+ HMAC_Init_ex(Ctx, Pointer(Key), Length(Key), HashMethods[Kind]);
+ BytesRead := Stream.Read(Bytes^, BufferSize);
+ while BytesRead > 0 do
+ begin
+ HMAC_Update(Ctx, Bytes, Cardinal(BytesRead));
+ BytesRead := Stream.Read(Bytes^, BufferSize);
end;
+ if HMAC_Final(Ctx, Result.Data, Size) then
+ Result.Size := LongInt(Size)
+ else
+ Result.Size := 0;
+ finally
+ HMAC_CTX_free(Ctx);
+ FreeMem(Bytes);
end;
- Result := Method.Digest;
end;
function AuthFile(const Key: string; Kind: THashKind; const FileName: string): TDigest;
@@ -291,6 +228,29 @@ function AuthFile(const Key: string; Kind: THashKind; const FileName: string): T
Stream.Free;
end;
end;
+
+{ TDigestHelper }
+
+function TDigestHelper.AuthNext(Kind: THashKind; const S: string): TDigest;
+var
+ Ctx: THMACCtx;
+ Size: Cardinal;
+begin
+ Init;
+ Result := TDigest.Create(EVP_MAX_MD_SIZE);
+ Ctx := HMAC_CTX_new;
+ try
+ HMAC_Init_ex(Ctx, Self.Data, Self.Size, HashMethods[Kind]);
+ HMAC_Update(Ctx, Pointer(S), Cardinal(Length(S)));
+ if HMAC_Final(Ctx, Result.Data, Size) then
+ Result.Size := LongInt(Size)
+ else
+ Result.Size := 0;
+ finally
+ HMAC_CTX_free(Ctx);
+ end;
+end;
+
{$endregion}
{$region encryption}
diff --git a/source/codebot.geometry.pas b/source/codebot/codebot.geometry.pas
similarity index 86%
rename from source/codebot.geometry.pas
rename to source/codebot/codebot.geometry.pas
index 7d82113..3c8282e 100644
--- a/source/codebot.geometry.pas
+++ b/source/codebot/codebot.geometry.pas
@@ -84,40 +84,49 @@ TVec2 = record
See also
}
- TVec3 = record
- public
- {doc off}
- class operator Negative(const A: TVec3): TVec3; inline;
- class operator Equal(const A, B: TVec3): Boolean; inline;
- class operator NotEqual(const A, B: TVec3): Boolean; inline;
- class operator Add(const A, B: TVec3): TVec3; inline;
- class operator Subtract(const A, B: TVec3): TVec3; inline;
- class operator Multiply(const A, B: TVec3): TVec3; inline;
- class operator Divide(const A, B: TVec3): TVec3; inline;
- function Equals(const Value: TVec3): Boolean; inline;
- function Cross(const V: TVec3): TVec3;
- function Dot(const V: TVec3): Float;
- function Distance: Float;
- procedure Normalize;
- {doc on}
- public
- case Integer of
- 0: (X, Y, Z: Float);
- 1: (R, G, B: Float);
- 2: (Red, Green, Blue: Float);
- 3: (Heading, Pitch, Roll: Float);
- 4: (Hue, Saturation, Lightness: Float);
- 5: (Vec1: TVec1);
- 6: (Vec2: TVec2);
- 7: (V: array[0..2] of Float);
- end;
- {doc ignore}
- PVec3 = ^TVec3;
- {doc ignore}
- TVec3Array = TArray;
- { TDirection represents a heading, pitch, and roll }
- TDirection = TVec3;
-
+ { TVec3 is a three component vector
+ See also
+ }
+
+ TVec3 = record
+ public
+ {doc off}
+ class operator Negative(const A: TVec3): TVec3; inline;
+ class operator Equal(const A, B: TVec3): Boolean; inline;
+ class operator NotEqual(const A, B: TVec3): Boolean; inline;
+ class operator Add(const A, B: TVec3): TVec3; inline;
+ class operator Subtract(const A, B: TVec3): TVec3; inline;
+ class operator Multiply(const A, B: TVec3): TVec3; overload; inline;
+ class operator Multiply(const A: TVec3; B: Float): TVec3; overload; inline;
+ class operator Divide(const A, B: TVec3): TVec3; overload; inline;
+ class operator Divide(const A: TVec3; B: Float): TVec3; overload; inline;
+ function Equals(const Value: TVec3): Boolean; inline;
+ function Angle: TVec2;
+ function Blend(const V: TVec3; Percent: Float): TVec3;
+ function Cross(const V: TVec3): TVec3;
+ function Dot(const V: TVec3): Float;
+ function Distance: Float; overload;
+ function Distance(X, Y, Z: Float): Float; overload;
+ function Distance(const V: TVec3): Float; overload;
+ procedure Normalize;
+ {doc on}
+ public
+ case Integer of
+ 0: (X, Y, Z: Float);
+ 1: (R, G, B: Float);
+ 2: (Red, Green, Blue: Float);
+ 3: (Pitch, Heading, Roll: Float);
+ 4: (Hue, Saturation, Lightness: Float);
+ 5: (V1: TVec1);
+ 6: (V2: TVec2);
+ 7: (V: array[0..2] of Float);
+ end;
+ {doc ignore}
+ PVec3 = ^TVec3;
+ {doc ignore}
+ TVec3Array = TArray;
+ { TDirection represents a heading, pitch, and roll }
+ TDirection = TVec3;
{ TVec4 is a four component vector
See also
@@ -196,8 +205,14 @@ TMatrix4x4 = record
procedure Scale(X, Y, Z: Float);
procedure ScaleAt(X, Y, Z: Float; const Pivot: TVec3);
procedure Translate(X, Y, Z: Float);
+
+ function Transform(const V: TVec2): TVec2; overload;
+ function Transform(const V: TVec3): TVec3; overload;
function Transform(const M: TMatrix4x4): TMatrix4x4; overload;
- function Transform(const P: TVec3): TVec3; overload;
+ procedure Perspective(FoV, AspectRatio, NearPlane, FarPlane: Float);
+ procedure Frustum(Left, Right, Top, Bottom, NearPlane, FarPlane: Float);
+ procedure LookAt(Eye, Center, Up: TVec3);
+
case Integer of
0: (M: array[0..3, 0..3] of Float);
1: (M0, M1, M2, M3: array[0..3] of Float);
@@ -314,7 +329,7 @@ function Bezier2(const P0, P1, P2, P3: TVec2): TBezier2;
const
StockDirection: TDirection = (
- Heading: 0; Pitch: 0; Roll: 0);
+ Pitch: 0; Heading: 0; Roll: 0);
StockMatrix: TMatrix = (M: (
(1, 0, 0, 0),
(0, 1, 0, 0),
@@ -429,14 +444,14 @@ function TVec2.Distance: Float;
function TVec2.Angle: Float;
const
- Origin: TVec2 = ();
+ Origin: TVec2 = (X: 0; Y: 0);
begin
Result := Origin.Angle(Self);
end;
function TVec2.Angle(X, Y: Float): Float;
begin
- Result := Angle(Vec2(X, Y));
+ Result := Angle(Vec2(X, Y){%H-});
end;
function TVec2.Angle(const V: TVec2): Float;
@@ -456,8 +471,11 @@ function TVec2.Angle(const V: TVec2): Float;
end;
function TVec2.Distance(X, Y: Float): Float;
+var
+ V: TVec2;
begin
- Result := (Self - Vec2(X, Y)).Distance;
+ V := Vec2(X, Y);
+ Result := (Self - V).Distance;
end;
function TVec2.Distance(const V: TVec2): Float;
@@ -594,6 +612,13 @@ function TVec2.Rotate(const V: TVec2; Angle: Float): TVec2;
Result.Z := A.Z * B.Z;
end;
+class operator TVec3.Multiply(const A: TVec3; B: Float): TVec3;
+begin
+ Result.X := A.X * B;
+ Result.Y := A.Y * B;
+ Result.Z := A.Z * B;
+end;
+
class operator TVec3.Divide(const A, B: TVec3): TVec3;
begin
Result.X := A.X / B.X;
@@ -601,11 +626,31 @@ function TVec2.Rotate(const V: TVec2; Angle: Float): TVec2;
Result.Z := A.Z / B.Z;
end;
+class operator TVec3.Divide(const A: TVec3; B: Float): TVec3;
+begin
+ Result.X := A.X / B;
+ Result.Y := A.Y / B;
+ Result.Z := A.Z / B;
+end;
+
function TVec3.Equals(const Value: TVec3): Boolean;
begin
Result := Self = Value;
end;
+function TVec3.Angle: TVec2;
+begin
+ Result.X := Vec2(X, Z).Angle;
+ Result.Y := Vec2(Z, Y).Angle;
+end;
+
+function TVec3.Blend(const V: TVec3; Percent: Float): TVec3;
+begin
+ Result.X := X * (1 - Percent) + V.X * Percent;
+ Result.Y := Y * (1 - Percent) + V.Y * Percent;
+ Result.Z := Z * (1 - Percent) + V.Z * Percent;
+end;
+
function TVec3.Cross(const V: TVec3): TVec3;
begin
Result.X := (Y * V.Z) - (V.Y * Z);
@@ -620,14 +665,24 @@ function TVec3.Dot(const V: TVec3): Float;
function TVec3.Distance: Float;
begin
- Result := Sqrt(X * X + Y * Y + Z + Z);
+ Result := Sqrt(X * X + Y * Y + Z * Z);
+end;
+
+function TVec3.Distance(X, Y, Z: Float): Float;
+begin
+ Result := (Self - Vec3(X, Y, Z)).Distance;
+end;
+
+function TVec3.Distance(const V: TVec3): Float;
+begin
+ Result := (Self - V).Distance;
end;
procedure TVec3.Normalize;
var
D: Float;
begin
- D := Sqrt(X * X + Y * Y + Z + Z);
+ D := Sqrt(X * X + Y * Y + Z * Z);
if D > 0 then
begin
D := 1 / D;
@@ -1091,14 +1146,93 @@ procedure TMatrix4x4.Translate(X, Y, Z: Float);
Self := Self * T;
end;
+function TMatrix4x4.Transform(const V: TVec2): TVec2;
+var
+ A: TVec3;
+begin
+ A.X := V.X;
+ A.Y := V.Y;
+ A.Z := 0;
+ A := Self * A;
+ Result.X := A.X;
+ Result.Y := A.Y;
+end;
+
+function TMatrix4x4.Transform(const V: TVec3): TVec3;
+begin
+ Result := Self * V;
+end;
+
function TMatrix4x4.Transform(const M: TMatrix4x4): TMatrix4x4;
begin
Result := Self * M;
end;
-function TMatrix4x4.Transform(const P: TVec3): TVec3;
+procedure TMatrix4x4.Perspective(FoV, AspectRatio, NearPlane, FarPlane: Float);
+var
+ XMax, YMax: Float;
begin
- Result := Self * P;
+ YMax := NearPlane * Tan(FoV * PI / 360);
+ XMax := YMax * AspectRatio;
+ Frustum(-XMax, XMax, YMax, -YMax, NearPlane, FarPlane);
+end;
+
+procedure TMatrix4x4.Frustum(Left, Right, Top, Bottom, NearPlane, FarPlane: Float);
+var
+ F1, F2, F3, F4: Float;
+begin
+ F1 := 2.0 * NearPlane;
+ F2 := Right - Left;
+ F3 := Top - Bottom;
+ F4 := FarPlane - NearPlane;
+ V[0] := F1 / F2;
+ V[1] := 0;
+ V[2] := 0;
+ V[3] := 0;
+ V[4] := 0;
+ V[5] := F1 / F3;
+ V[6] := 0;
+ V[7] := 0;
+ V[8] := (Right + Left) / F2;
+ V[9] := (Top + Bottom) / F3;
+ V[10] := (-FarPlane - NearPlane) / F4;
+ V[11] := -1;
+ V[12] := 0;
+ V[13] := 0;
+ V[14] := (-F1 * FarPlane) / F4;
+ V[15] := 0;
+end;
+
+{ from https://developer.tizen.org/community/code-snippet/native-code-snippet/set-lookat-matrix-opengl-es-2.0 }
+
+procedure TMatrix4x4.LookAt(Eye, Center, Up: TVec3);
+var
+ F, S, U: TVec3;
+begin
+ F := Center - Eye;
+ F.Normalize;
+ S := F.Cross(Up);
+ S.Normalize;
+ if (S.V[0] = 0) and (S.V[1] = 0) and (S.V[2] = 0) then
+ Exit;
+ U := S.Cross(F);
+ V[0] := S.X;
+ V[1] := U.X;
+ V[2] := -F.X;
+ V[3] := 0;
+ V[4] := S.Y;
+ V[5] := U.Y;
+ V[6] := -F.Y;
+ V[7] := 0;
+ V[8] := S.Z;
+ V[9] := U.Z;
+ V[10] := -F.Z;
+ V[11] := 0;
+ V[12] := 0;
+ V[13] := 0;
+ V[14] := 0;
+ V[15] := 1;
+ Translate(-Eye.X, -Eye.Y, -Eye.Z);
end;
class operator TQuaternion.Explicit(const A: TQuaternion): TMatrix4x4;
@@ -1254,19 +1388,19 @@ function TLine2.Intersects(const Line: TLine2): Boolean;
const
Sigma = 0.001;
var
- A, B: Single;
+ A, B: Single;
begin
Result := False;
- A := (P1.X - P0.X) * (Line.P1.Y - Line.P0.Y) - (P1.Y - P0.Y) * (Line.P1.X - Line.P0.X);
- if (Abs(A) < Sigma) then
- Exit;
- B := ((P0.Y - Line.P0.Y) * (Line.P1.X - Line.P0.X) - (P0.X - Line.P0.X) * (Line.P1.Y - Line.P0.Y)) / A;
- if (B > 0.0) and (B < 1.0) then
- begin
- B := ((P0.Y - Line.P0.Y) * (P1.X - P0.X) - (P0.X - Line.P0.X) * (P1.Y - P0.Y)) / A;
- if (B > 0.0) and (B < 1.0) then
- Result := True;
- end;
+ A := (P1.X - P0.X) * (Line.P1.Y - Line.P0.Y) - (P1.Y - P0.Y) * (Line.P1.X - Line.P0.X);
+ if (Abs(A) < Sigma) then
+ Exit;
+ B := ((P0.Y - Line.P0.Y) * (Line.P1.X - Line.P0.X) - (P0.X - Line.P0.X) * (Line.P1.Y - Line.P0.Y)) / A;
+ if (B > 0.0) and (B < 1.0) then
+ begin
+ B := ((P0.Y - Line.P0.Y) * (P1.X - P0.X) - (P0.X - Line.P0.X) * (P1.Y - P0.Y)) / A;
+ if (B > 0.0) and (B < 1.0) then
+ Result := True;
+ end;
end;
{ TCurve2 }
diff --git a/source/codebot.graphics.linux.surfacecairo.pas b/source/codebot/codebot.graphics.linux.surfacecairo.pas
similarity index 90%
rename from source/codebot.graphics.linux.surfacecairo.pas
rename to source/codebot/codebot.graphics.linux.surfacecairo.pas
index 8ead705..b246404 100644
--- a/source/codebot.graphics.linux.surfacecairo.pas
+++ b/source/codebot/codebot.graphics.linux.surfacecairo.pas
@@ -2,7 +2,7 @@
(* *)
(* Codebot Pascal Library *)
(* http://cross.codebot.org *)
-(* Modified September 2013 *)
+(* Modified February 2020 *)
(* *)
(********************************************************)
@@ -17,9 +17,7 @@ interface
uses
SysUtils, Classes, Graphics, Controls,
Codebot.System,
- Codebot.Collections,
- Codebot.Graphics.Types,
- Codebot.Forms.Management;
+ Codebot.Graphics.Types;
{ New object routines }
@@ -38,14 +36,20 @@ function NewSurfaceCairo(Control: TWinControl): ISurface; overload;
function NewBitmapCairo(BitmapBuffer: Pointer): IBitmap; overload;
function NewBitmapCairo(Width, Height: Integer): IBitmap; overload;
function NewSplashCairo: ISplash;
+function NewScreenCaptureGtk: IBitmap;
{$endif}
implementation
{$ifdef linux}
uses
- glib2, gdk2, gtk2, gtk2def, gtk2proc, gtk2int, gdk2pixbuf, gtk2extra,
- cairo, pango, pangocairo;
+ GLib2, Gdk2Pixbuf, Cairo, Pango, PangoCairo,
+ {$ifdef lclgtk2}
+ Gdk2, Gtk2, Gtk2Def, Gtk2Proc, Gtk2Int, Gtk2Extra;
+ {$endif}
+ {$ifdef lclgtk3}
+ LazGdk3, LazGtk3, Gtk3Objects;
+ {$endif}
const
Delta = 0.5;
@@ -61,7 +65,6 @@ implementation
TCairoLineJoin = cairo_line_join_t;
TCairoMatrix = cairo_matrix_t;
PCairoMatrix = Pcairo_matrix_t;
- TCairoFontOptions = cairo_font_options_t;
PCairoFontOptions = Pcairo_font_options_t;
TCairoAntiAlias = cairo_antialias_t;
TCairoFilter = cairo_filter_t;
@@ -85,15 +88,19 @@ GdkPixbufFormat = record
PGdkPixbufFormat = ^GdkPixbufFormat;
GdkPixbufSaveFunc = function(buffer: PGChar; count: GSize; error: PPGError;
- data: GPointer): GBoolean; cdecl;
+ user_data: GPointer): GBoolean; cdecl;
function gdk_pixbuf_loader_get_format(loader: PGdkPixbufLoader): PGdkPixbufFormat; cdecl; external gdkpixbuflib;
function gdk_pixbuf_save_to_callback(pixbuf: PGdkPixbuf; save_func: GdkPixbufSaveFunc;
- data: gpointer; _type: PGChar; error: PPGError): GBoolean; cdecl; external gdkpixbuflib;
+ user_data: gpointer; _type: PGChar; error: PPGError; args: Pointer): GBoolean; cdecl; external gdkpixbuflib;
+function gdk_pixbuf_save_to_callbackv(pixbuf: PGdkPixbuf; save_func: GdkPixbufSaveFunc;
+ user_data: gpointer; _type: PGChar; option_keys, option_values: PPgchar; error: PPGError): GBoolean; cdecl; external gdkpixbuflib;
{ Extra cairo routines }
+{$ifdef lclgtk2}
procedure gdk_cairo_reset_clip(cr: Pcairo_t; drawable: PGdkDrawable); cdecl; external gdklib;
+{$endif}
{ Extra pango routines }
@@ -104,6 +111,7 @@ procedure pango_layout_set_ellipsize(layout: PPangoLayout;
ellipsize: TPangoEllipsizeMode); cdecl; external pangolib;
function pango_layout_get_ellipsize(layout: PPangoLayout): TPangoEllipsizeMode; cdecl; external pangolib;
function pango_layout_is_ellipsized(layout: PPangoLayout): GBoolean; cdecl; external pangolib;
+function pango_attr_letter_spacing_new(letter_spacing: Integer): PPangoAttribute; cdecl; external pangolib;
type
TCairoMatrixHelper = record helper for TCairoMatrix
@@ -349,6 +357,9 @@ TRadialGradientBrushCairo = class(TGradientBrushCairo, IRadialGradientBrush)
{ TFontCairo }
TFontCairo = class(TInterfacedObject, IFont)
+ private
+ class var FDefaultFont: TFont;
+ class function GetDefaultFont: Graphics.TFont;
private
FDesc: PPangoFontDescription;
FName: string;
@@ -356,6 +367,7 @@ TFontCairo = class(TInterfacedObject, IFont)
FQuality: TFontQuality;
FStyle: TFontStyles;
FSize: Float;
+ FKerning: Float;
public
constructor Create(Font: TFont); overload;
constructor Create(const FontName: string; FontSize: Integer = 10); overload;
@@ -370,11 +382,14 @@ TFontCairo = class(TInterfacedObject, IFont)
procedure SetStyle(Value: TFontStyles);
function GetSize: Float;
procedure SetSize(Value: Float);
+ function GetKerning: Float;
+ procedure SetKerning(Value: Float);
property Name: string read GetName write SetName;
property Color: TColorB read GetColor write SetColor;
property Quality: TFontQuality read GetQuality write SetQuality;
property Style: TFontStyles read GetStyle write SetStyle;
property Size: Float read GetSize write SetSize;
+ property Kerning: Float read GetKerning write SetKerning;
end;
{ TPathCairo }
@@ -405,6 +420,7 @@ TSurfacePathCairo = class(TInterfacedObject, IPath)
{ TSurfacePathClipCairo }
+{$ifdef lclgtk2}
TSurfacePathClipCairo = class(TSurfacePathCairo)
private
FDrawable: PGdkDrawable;
@@ -413,6 +429,7 @@ TSurfacePathClipCairo = class(TSurfacePathCairo)
constructor Create(Cairo: PCairo; Drawable: PGdkDrawable; Clip: TRectI);
procedure Unclip; override;
end;
+{$endif}
TBitmapCairo = class;
@@ -420,6 +437,7 @@ TBitmapCairo = class;
TSurfaceCairo = class(TInterfacedObject, ISurface)
private
+ FOwned: Boolean;
FCairo: PCairo;
FPath: IPath;
FPathCairo: TSurfacePathCairo;
@@ -439,6 +457,7 @@ TSurfaceCairo = class(TInterfacedObject, ISurface)
function GetMatrix: IMatrix;
procedure SetMatrix(Value: IMatrix);
function GetPath: IPath;
+ function GetHandle: Pointer;
procedure Flush; virtual;
procedure Clear; overload;
procedure Clear(Color: TColorB); overload;
@@ -469,6 +488,7 @@ TSurfaceCairo = class(TInterfacedObject, ISurface)
{ TClipSurfaceCairo }
+{$ifdef lclgtk2}
TClipSurfaceCairo = class(TSurfaceCairo)
{ TODO: Acquire brush for pattern brushes setting origins to clip }
{ TODO: Consider reworking clipping multiply matrix to use translate only }
@@ -488,6 +508,7 @@ TControlSurfaceCairo = class(TSurfaceCairo)
constructor Create(Control: TWinControl);
procedure Flush; override;
end;
+{$endif}
{ TBitmapSurfaceCairo }
@@ -509,10 +530,15 @@ TBitmapCairo = class(TInterfacedObject, IBitmap)
FSurface: ISurface;
FSurfaceCairo: TBitmapSurfaceCairo;
FFormat: TImageFormat;
+ FNeedsFlip: Boolean;
procedure Flush;
procedure FlipPixels;
procedure Premultiply;
procedure SetBuffer(Value: PGdkPixbuf);
+ function GetDirty: Boolean;
+ procedure SetDirty(Value: Boolean);
+ protected
+ property Dirty: Boolean read GetDirty write SetDirty;
public
constructor Create(B: PGdkPixbuf = nil);
destructor Destroy; override;
@@ -1057,23 +1083,43 @@ function TRadialGradientBrushCairo.HandleNeeded: Boolean;
{ TFontCairo }
+class function TFontCairo.GetDefaultFont: Graphics.TFont;
+var
+ Items: StringArray;
+ S: string;
+ P: PChar;
+begin
+ Result := FDefaultFont;
+ if Result <> nil then
+ Exit;
+ FDefaultFont := Graphics.TFont.Create;
+ g_object_get(gtk_settings_get_default, 'gtk-font-name', [@P, nil]);
+ S := P;
+ g_free(P);
+ Items := S.Split(' ');
+ FDefaultFont.Size := StrToInt(Items.Pop);
+ FDefaultFont.Name := Items.Join(' ');
+ Result := FDefaultFont;
+end;
+
constructor TFontCairo.Create(Font: TFont);
begin
inherited Create;
FDesc := pango_font_description_new;
if Font = nil then
- Font := FormManager.DefaulFont;
+ Font := GetDefaultFont;
if Font.Name <> 'default' then
SetName(Font.Name)
else
- SetName(FormManager.DefaulFont.Name);
- if Font.Size > 4 then
- SetSize(Font.Size)
- else
- SetSize(FormManager.DefaulFont.Size);
+ SetName(GetDefaultFont.Name);
Quality := Font.Quality;
Color := Font.Color;
Style := Font.Style;
+ FSize := 0;
+ if Font.Size > 4 then
+ SetSize(Font.Size)
+ else
+ SetSize(GetDefaultFont.Size);
end;
constructor TFontCairo.Create(const FontName: string; FontSize: Integer = 10);
@@ -1163,6 +1209,16 @@ procedure TFontCairo.SetSize(Value: Float);
end;
end;
+function TFontCairo.GetKerning: Float;
+begin
+ Result := FKerning;
+end;
+
+procedure TFontCairo.SetKerning(Value: Float);
+begin
+ FKerning := Value;
+end;
+
{ TPathCairo }
constructor TPathCairo.Create(Path: PCairoPath);
@@ -1244,6 +1300,7 @@ procedure TSurfacePathCairo.Unclip;
{ TSurfacePathClipCairo }
+{$ifdef lclgtk2}
constructor TSurfacePathClipCairo.Create(Cairo: PCairo; Drawable: PGdkDrawable; Clip: TRectI);
begin
inherited Create(Cairo);
@@ -1271,12 +1328,14 @@ procedure TSurfacePathClipCairo.Unclip;
cairo_clip(FCairo);
cairo_set_matrix(FCairo, @OldMat);
end;
+{$endif}
{ TSurfaceCairo }
constructor TSurfaceCairo.Create(C: PCairo = nil);
begin
inherited Create;
+ FOwned := True;
FCairo := C;
FMatrix := TMatrixCairo.Create;
end;
@@ -1310,8 +1369,16 @@ procedure TSurfaceCairo.HandleRelease;
if FPathCairo <> nil then
FPathCairo.FCairo := nil;
if FCairo <> nil then
- cairo_destroy(FCairo);
- FCairo := nil;
+ if FOwned then
+ begin
+ cairo_destroy(FCairo);
+ FCairo := nil;
+ end
+ else
+ begin
+ FMatrix.Identity;
+ cairo_set_matrix(FCairo, FMatrix.AtMatrix);
+ end;
end;
function TSurfaceCairo.LayoutAvailable: Boolean;
@@ -1439,6 +1506,11 @@ function TSurfaceCairo.GetPath: IPath;
Result := FPath;
end;
+function TSurfaceCairo.GetHandle: Pointer;
+begin
+ Result := FCairo;
+end;
+
procedure TSurfaceCairo.Flush;
var
S: PCairoSurface;
@@ -1682,6 +1754,8 @@ procedure TSurfaceCairo.TextOut(Font: IFont; const Text: string; const Rect: TRe
W, H: LongInt;
M: TCairoMatrix;
C: TColorF;
+ L: PPangoAttrList;
+ A: PPangoAttribute;
Options: PCairoFontOptions;
begin
if SurfaceOptions.ErrorCorrection or Immediate then
@@ -1710,7 +1784,11 @@ procedure TSurfaceCairo.TextOut(Font: IFont; const Text: string; const Rect: TRe
{ Ellipses }
case Direction of
drLeft, drUp, drRight, drDown, drCenter:
+ begin
pango_layout_set_ellipsize(FLayout, PANGO_ELLIPSIZE_END);
+ //pango_layout_set_width(FLayout, -1);
+ //pango_layout_set_height(FLayout, -1);
+ end
else
pango_layout_set_ellipsize(FLayout, PANGO_ELLIPSIZE_NONE);
end;
@@ -1720,11 +1798,19 @@ procedure TSurfaceCairo.TextOut(Font: IFont; const Text: string; const Rect: TRe
{ Placement }
case Direction of
drUp, drWrap, drFlow:
- cairo_translate(FCairo, R.X + Delta, R.Y + Delta);
+ cairo_translate(FCairo, R.X, R.Y);
drLeft, drRight, drCenter, drFill:
- cairo_translate(FCairo, R.X + Delta, R.Y + (R.Height - H) div 2 + Delta);
+ cairo_translate(FCairo, R.X, R.Y + (R.Height - H) div 2);
else
- cairo_translate(FCairo, R.X + Delta, Rect.Y + R.Height - H + Delta);
+ cairo_translate(FCairo, R.X, Rect.Y + R.Height - H);
+ end;
+ { Kerning }
+ if Font.Kerning <> 0 then
+ begin
+ L := pango_attr_list_new;
+ A := pango_attr_letter_spacing_new(Round(Font.Kerning));
+ pango_attr_list_insert(L, A);
+ pango_layout_set_attributes(FLayout, L)
end;
pango_cairo_update_layout(FCairo, FLayout);
Options := cairo_font_options_create;
@@ -1742,6 +1828,8 @@ procedure TSurfaceCairo.TextOut(Font: IFont; const Text: string; const Rect: TRe
end
else
pango_cairo_layout_path(FCairo, FLayout);
+ if Font.Kerning <> 0 then
+ pango_attr_list_unref(L);
cairo_set_matrix(FCairo, @M);
cairo_font_options_destroy(Options);
end;
@@ -1855,6 +1943,7 @@ procedure TSurfaceCairo.FillRoundRect(Brush: IBrush; const Rect: TRectF; Radius:
{ TClipSurfaceCairo }
+{$ifdef lclgtk2}
constructor TClipSurfaceCairo.Create(Drawable: PGdkDrawable; const Clip: TRectI);
begin
inherited Create;
@@ -1882,7 +1971,7 @@ function TControlSurfaceCairo.HandleAvailable: Boolean;
begin
if FDrawable = nil then
begin
- Widget := GTK_WIDGET(Pointer(FControl.Handle));
+ Widget := GTK_WIDGET({%H-}Pointer(FControl.Handle));
Widget := GetFixedWidget(Widget);
FDrawable := GetControlWindow(Widget);
end;
@@ -1912,6 +2001,7 @@ procedure TControlSurfaceCairo.Flush;
{ Without the call below everything is slow }
gdk_flush;
end;
+{$endif}
{ TBitmapSurfaceCairo }
@@ -1919,6 +2009,7 @@ constructor TBitmapSurfaceCairo.Create(Bitmap: TBitmapCairo);
begin
inherited Create;
FBitmap := Bitmap;
+ FDirty := True;
end;
function TBitmapSurfaceCairo.HandleAvailable: Boolean;
@@ -1937,12 +2028,13 @@ function TBitmapSurfaceCairo.HandleAvailable: Boolean;
W, H, W * SizeOf(TColorB));
FCairo := cairo_create(S);
cairo_surface_destroy(S);
- FDirty := False;
+ FDirty := False;
end;
if FCairo = nil then
FDirty := False;
- if FDirty then
+ if FDirty and (FBitmap <> nil) and (not FBitmap.Empty) then
begin
+ FBitmap.FlipPixels;
S := cairo_get_target(FCairo);
cairo_surface_mark_dirty(S);
FDirty := False;
@@ -1983,7 +2075,11 @@ procedure TBitmapCairo.FlipPixels;
begin
if Empty then
Exit;
+ if not FNeedsFlip then
+ Exit;
+ FNeedsFlip := False;
Flush;
+ Dirty := True;
P := Pixels;
I := Width * Height;
while I > 0 do
@@ -2042,6 +2138,21 @@ procedure TBitmapCairo.SetBuffer(Value: PGdkPixbuf);
FBuffer := Value;
if FSurfaceCairo <> nil then
FSurfaceCairo.HandleRelease;
+ Dirty := True;
+end;
+
+function TBitmapCairo.GetDirty: Boolean;
+begin
+ if FSurfaceCairo = nil then
+ Result := True
+ else
+ Result := FSurfaceCairo.FDirty;
+end;
+
+procedure TBitmapCairo.SetDirty(Value: Boolean);
+begin
+ if FSurfaceCairo <> nil then
+ FSurfaceCairo.FDirty := Value;
end;
function TBitmapCairo.Clone: IBitmap;
@@ -2049,7 +2160,11 @@ function TBitmapCairo.Clone: IBitmap;
if FBuffer = nil then
Result := TBitmapCairo.Create
else
+ begin
+ if not Dirty then
+ FlipPixels;
Result := TBitmapCairo.Create(gdk_pixbuf_copy(FBuffer));
+ end;
(Result as TBitmapCairo).FFormat := FFormat;
end;
@@ -2106,9 +2221,9 @@ function TBitmapCairo.GetPixels: PPixel;
else
begin
Flush;
+ if not Dirty then
+ FlipPixels;
Result := Pointer(gdk_pixbuf_get_pixels(FBuffer));
- if FSurfaceCairo <> nil then
- FSurfaceCairo.FDirty := True;
end;
end;
@@ -2127,6 +2242,8 @@ function TBitmapCairo.Resample(Width, Height: Integer; Quality: TResampleQuality
if Empty then
Exit(nil);
Flush;
+ if not Dirty then
+ FlipPixels;
B := gdk_pixbuf_scale_simple(FBuffer, Width, Height, Sampling[Quality]);
if B = nil then
Exit(nil);
@@ -2168,11 +2285,29 @@ procedure TBitmapCairo.SetSize(Width, Height: Integer);
end;
end;
+function GetStr(const S: string): PChar;
+var
+ I: Integer;
+begin
+ I := Length(S);
+ Result := GetMem(I + 8);
+ FillChar(Result^, I + 8, 0);
+ Move(PChar(S)^, Result^, I);
+end;
+
+procedure FreeStr(const S: PChar);
+begin
+ FreeMem(S);
+end;
+
procedure TBitmapCairo.LoadFromFile(const FileName: string);
var
+ A: PChar;
B, C: PGdkPixbuf;
begin
- B := gdk_pixbuf_new_from_file(PAnsiChar(FileName), nil);
+ A := GetStr(FileName);
+ B := gdk_pixbuf_new_from_file(A, nil);
+ FreeStr(A);
if B <> nil then
begin
FFormat := StrToImageFormat(ExtractFileExt(FileName));
@@ -2184,8 +2319,11 @@ procedure TBitmapCairo.LoadFromFile(const FileName: string);
g_object_unref(B);
SetBuffer(C);
end;
- FlipPixels;
Premultiply;
+ Surface;
+ FNeedsFlip := True;
+ FlipPixels;
+ Dirty := False;
end;
end;
@@ -2224,8 +2362,11 @@ procedure TBitmapCairo.LoadFromStream(Stream: TStream);
F := gdk_pixbuf_loader_get_format(Loader);
if F <> nil then
FFormat := StrToImageFormat(F.name);
- FlipPixels;
Premultiply;
+ Surface;
+ FNeedsFlip := True;
+ FlipPixels;
+ Dirty := False;
end;
finally
FreeMem(Data);
@@ -2235,6 +2376,7 @@ procedure TBitmapCairo.LoadFromStream(Stream: TStream);
procedure TBitmapCairo.SaveToFile(const FileName: string);
var
+ A, B: PChar;
S: string;
begin
if not Empty then
@@ -2242,16 +2384,22 @@ procedure TBitmapCairo.SaveToFile(const FileName: string);
S := ExtractFileExt(FileName);
FFormat := StrToImageFormat(S);
S := ImageFormatToStr(FFormat);
+ FNeedsFlip := True;
FlipPixels;
- gdk_pixbuf_save(FBuffer, PChar(FileName), PChar(S), nil);
+ A := GetStr(FileName);
+ B := GetStr(S);
+ gdk_pixbuf_save(FBuffer, A, B, nil);
+ FreeStr(B);
+ FreeStr(A);
+ FNeedsFlip := True;
FlipPixels;
end;
end;
function SaveCallback(buffer: PGChar; count: GSize; error: PPGError;
- data: GPointer): GBoolean; cdecl;
+ user_data: GPointer): GBoolean; cdecl;
var
- Stream: TStream absolute data;
+ Stream: TStream absolute user_data;
begin
Stream.Write(buffer^, count);
Result := True;
@@ -2263,15 +2411,14 @@ procedure TBitmapCairo.SaveToStream(Stream: TStream);
begin
if not Empty then
begin
- { For some unknow reason this WriteLn causes the IDE to realize property data }
- WriteLn('bitmap save start');
if not (FFormat in [fmBmp, fmJpeg, fmPng, fmTiff]) then
FFormat := fmPng;
S := ImageFormatToStr(FFormat);
+ FNeedsFlip := True;
FlipPixels;
- gdk_pixbuf_save_to_callback(FBuffer, SaveCallback, Stream, PChar(S), nil);
+ gdk_pixbuf_save_to_callback(FBuffer, SaveCallback, Stream, PChar(S), nil, nil);
+ FNeedsFlip := True;
FlipPixels;
- WriteLn('bitmap save complete');
end;
end;
@@ -2327,6 +2474,7 @@ function NewFontCairo(Font: TFont = nil): IFont;
Result := TFontCairo.Create(Font);
end;
+{$ifdef lclgtk2}
function CanvasToDrawable(Canvas: TCanvas; out Rect: TRectI): Pointer;
var
Root: PGdkWindow;
@@ -2377,10 +2525,46 @@ function NewSurfaceCairo(Control: TWinControl): ISurface;
begin
Result := TControlSurfaceCairo.Create(Control);
end;
+{$endif}
+
+{$ifdef lclgtk3}
+function NewSurfaceCairo(Canvas: TCanvas): ISurface;
+var
+ Obj: TObject;
+ P: PCairo;
+begin
+ Result := nil;
+ Obj := TObject(Canvas.Handle);
+ if Obj is TGtk3DeviceContext then
+ begin
+ P := PCairo(TGtk3DeviceContext(Obj).pcr);
+ Result := TSurfaceCairo.Create(P);
+ (Result as TSurfaceCairo).FOwned := False;
+ end;
+end;
+
+function NewSurfaceCairo(Control: TWinControl): ISurface;
+var
+ Obj: TObject;
+ P: PCairo;
+begin
+ Result := nil;
+ if Control is TCustomControl then
+ begin
+ Obj := TObject(TCustomControl(Control).Canvas.Handle);
+ if Obj is TGtk3DeviceContext then
+ begin
+ P := PCairo(TGtk3DeviceContext(Obj).pcr);
+ Result := TSurfaceCairo.Create(P);
+ (Result as TSurfaceCairo).FOwned := False;
+ end
+ end;
+end;
+{$endif}
function NewBitmapCairo(BitmapBuffer: Pointer): IBitmap;
begin
- TBitmapCairo.Create(PGdkPixmap(BitmapBuffer));
+ Result := TBitmapCairo.Create(BitmapBuffer);
end;
function NewBitmapCairo(Width, Height: Integer): IBitmap;
@@ -2391,9 +2575,10 @@ function NewBitmapCairo(Width, Height: Integer): IBitmap;
{ TSplashCairo }
+{$ifdef lclgtk2}
type
TSplashCairo = class(TInterfacedObject, ISplash)
- private
+ private
FClipped: Boolean;
FBitmap: IBitmap;
FWidget: PGtkWidget;
@@ -2414,7 +2599,7 @@ TSplashCairo = class(TInterfacedObject, ISplash)
procedure Update;
end;
-procedure gdk_window_input_shape_combine_mask (window: PGdkWindow;
+procedure gdk_window_input_shape_combine_mask(window: PGdkWindow;
mask: PGdkBitmap; x, y: GInt); cdecl; external gdklib;
function gtk_widget_get_window(widget: PGtkWidget): PGdkWindow; cdecl; external gtklib;
@@ -2543,7 +2728,7 @@ procedure TSplashCairo.SetVisible(Value: Boolean);
function TSplashCairo.GetHandle: IntPtr;
begin
- Result := IntPtr(FWidget);
+ Result := {%H-}IntPtr(FWidget);
end;
procedure TSplashCairo.Move(X, Y: Integer);
@@ -2566,6 +2751,48 @@ function NewSplashCairo: ISplash;
begin
Result := TSplashCairo.Create;
end;
+
+function NewScreenCaptureGtk: IBitmap;
+var
+ R: PGdkWindow;
+ X, Y, W, H: Integer;
+ B: TBitmapCairo;
+begin
+ R := gdk_get_default_root_window;
+ gdk_window_get_origin(R, @X, @Y);
+ gdk_drawable_get_size(R, @W, @H);
+ Result := NewBitmapCairo(W, H);
+ B := Result as TBitmapCairo;
+ gdk_pixbuf_get_from_drawable(B.FBuffer, R, nil, X, Y, 0, 0, W, H);
+ B.FNeedsFlip := True;
+ B.FlipPixels;
+end;
+{$endif}
+
+{$ifdef lclgtk3}
+function NewSplashCairo: ISplash;
+begin
+ Result := nil;
+end;
+
+function NewScreenCaptureGtk: IBitmap;
+var
+ R: PGdkWindow;
+ X, Y, W, H: Integer;
+ P: PGdkPixbuf;
+ B: TBitmapCairo;
+begin
+ R := gdk_get_default_root_window;
+ gdk_window_get_origin(R, @X, @Y);
+ W := gdk_window_get_width(R);
+ H := gdk_window_get_height(R);
+ P := gdk_pixbuf_get_from_window(R, X, Y, W, H);
+ Result := TBitmapCairo.Create(P);
+ B := Result as TBitmapCairo;
+ B.FNeedsFlip := True;
+ B.FlipPixels;
+end;
+{$endif}
{$endif}
end.
diff --git a/source/codebot.graphics.pas b/source/codebot/codebot.graphics.pas
similarity index 78%
rename from source/codebot.graphics.pas
rename to source/codebot/codebot.graphics.pas
index c327485..8964d24 100644
--- a/source/codebot.graphics.pas
+++ b/source/codebot/codebot.graphics.pas
@@ -2,7 +2,7 @@
(* *)
(* Codebot Pascal Library *)
(* http://cross.codebot.org *)
-(* Modified March 2015 *)
+(* Modified February 2020 *)
(* *)
(********************************************************)
@@ -14,17 +14,18 @@
interface
uses
- Classes, SysUtils, Graphics, Controls,
+ Classes, SysUtils, Graphics, Controls, Forms, LClIntf, LCLType,
Codebot.System,
+ Codebot.Text,
Codebot.Graphics.Types,
Codebot.Animation;
{ Create a new matrix }
function NewMatrix: IMatrix;
{ Create a new pen using a brush as the color }
-function NewPen(Brush: IBrush; Width: Float = 1): IPen; overload;
+function NewPen(Brush: IBrush; Width: Float = 1; Join: TLineJoin = jnMiter): IPen; overload;
{ Create a new solid color pen }
-function NewPen(Color: TColorB; Width: Float = 1): IPen; overload;
+function NewPen(Color: TColorB; Width: Float = 1; Join: TLineJoin = jnMiter): IPen; overload;
{ Create a new solid color brush }
function NewBrush(Color: TColorB): ISolidBrush; overload;
{ Create a new bitmap pattern brush }
@@ -47,6 +48,8 @@ function NewSurface(Control: TWinControl): ISurface; overload;
function NewBitmap(Width: Integer = 0; Height: Integer = 0): IBitmap;
{ Create a new splash screen }
function NewSplash: ISplash;
+{ Create a new bitmap from the screen }
+function NewScreenCapture: IBitmap;
{ TSurfaceBitmap is a TGraphic representation of an IBitmap
See also
@@ -109,8 +112,10 @@ TSurfaceBitmap = class(TGraphic)
procedure SaveToStream(Stream: TStream); override;
{ Output the mime types to a TStrings }
procedure GetSupportedSourceMimeTypes(List: TStrings); override;
- { Convert the image to shades of a color }
+ { Convert the image to a solid color }
procedure Colorize(Color: TColorB);
+ { Convert the image to shades of a color }
+ //procedure Screen(Color: TColorB);
{ Convert the image to grayscale when 1 }
procedure Desaturate(Percent: Float);
{ Convert the image to white when 1 }
@@ -169,6 +174,8 @@ TImageStrip = class(TComponent)
procedure Assign(Source: TPersistent); override;
procedure BeginUpdate;
procedure EndUpdate;
+ { Colorize the underlying bitmap }
+ procedure Colorize(Color: TColorB);
{ Copy the underlying bitmap object }
procedure CopyTo(Bitmap: IBitmap);
{ Use a quaility resampling }
@@ -201,6 +208,13 @@ TImageStrip = class(TComponent)
property OnChange: INotifyDelegate read GetOnChange;
end;
+{ TBitmapHelper }
+
+ TBitmapHelper = class helper for TBitmap
+ public
+ procedure Colorize(Color: TColorB);
+ end;
+
{ Drawing events }
TNotifyIndexEvent = procedure (Sender: TObject; Index: Integer) of object;
@@ -219,6 +233,7 @@ TImageStrip = class(TComponent)
procedure FillRectColor(Surface: ISurface; const Rect: TRectI; Color: TColorB; Radius: Float = 0);
procedure StrokeRectColor(Surface: ISurface; const Rect: TRectI; Color: TColorB; Radius: Float = 0);
procedure FillRectState(Surface: ISurface; const Rect: TRectI; State: TDrawState);
+procedure FillRectStateOutlined(Surface: ISurface; const Rect: TRectI; State: TDrawState);
procedure FillRectSelected(Surface: ISurface; const Rect: TRectI; Radius: Float = 0);
function DrawDummyBitmap(Width, Height: Integer): IBitmap;
function DrawHueLinear(Width, Height: Integer): IBitmap;
@@ -226,11 +241,18 @@ function DrawHueRadial(Width, Height: Integer): IBitmap;
function DrawSaturationBox(Width, Height: Integer; Hue: Float): IBitmap;
function DrawDesaturationBox(Width, Height: Integer; Hue: Float): IBitmap;
procedure DrawShadow(Surface: ISurface; const Rect: TRectI; Direction: TDirection);
+function DrawTextIcons(const S: string; Font: IFont; Width, Height: Integer): IBitmap;
-{ Draw an easing function as a graph }
+{ Draw an easing function as a graph }
procedure DrawEasing(Surface: ISurface; Font: IFont; Rect: TRectF;
Easing: TEasing; Reverse: Boolean; Time: Float);
+{ Load a cursor from a resource by name and associate it with a cursor id }
+procedure LoadCursor(const ResName: string; Cursor: TCursor);
+{ Copy the screen pixels into a bitmap }
+procedure CaptureScreen(Dest: TBitmap);
+{ Copy the screen pixels into a bitmap given a rectangle }
+procedure CaptureScreenRect(Rect: TRectI; Dest: TBitmap);
{ Brushes creates a series of bitmap batterns }
@@ -274,6 +296,7 @@ TDrawControlHelper = class helper for TControl
private
function GetCurrentColor: TColorB;
function GetParentCurrentColor: TColorB;
+ function GetParentEnabled: Boolean;
public
function TextHeight: Integer;
function TextSize(const Text: string): TPointI;
@@ -285,6 +308,7 @@ TDrawControlHelper = class helper for TControl
procedure DrawRectState(Surface: ISurface; const Rect: TRectI; State: TDrawState; Radius: Float = 0);
property CurrentColor: TColorB read GetCurrentColor;
property ParentCurrentColor: TColorB read GetParentCurrentColor;
+ property ParentEnabled: Boolean read GetParentEnabled;
end;
{ TTheme }
@@ -377,6 +401,40 @@ procedure ThemeNotifyAdd(Event: TMethodEvent);
procedure ThemeNotifyRemove(Event: TMethodEvent);
procedure ThemeNames(Strings: TStrings);
+type
+ TFilterFunction = function(Value: Single): Single;
+
+ TSamplingFilter = (sfNearest, sfLinear, sfCosine, sfHermite, sfQuadratic,
+ sfGaussian, sfSpline, sfLanczos, sfMitchell, sfCatmullRom);
+
+{ Default resampling filter used for bicubic resizing }
+
+const
+ DefaultCubicFilter = sfCatmullRom;
+
+{ Built-in filter functions }
+
+var
+ SamplingFilterFunctions : array[TSamplingFilter] of TFilterFunction;
+
+{ Default radii of built-in filter functions }
+
+ SamplingFilterRadii: array[TSamplingFilter] of Single;
+
+{ Resamples rectangle in source image to rectangle in destination image
+ with resampling. You can use custom sampling function and filter radius.
+
+ Set WrapEdges to True for seamlessly tileable images }
+
+procedure ResampleBitmap(Src: IBitmap; SrcX, SrcY, SrcWidth, SrcHeight: LongInt;
+ Dst: IBitmap; DstX, DstY, DstWidth, DstHeight: LongInt;
+ Filter: TFilterFunction; Radius: Single; WrapEdges: Boolean); overload;
+function ResampleBitmap(Bitmap: IBitmap; Width, Height: Integer;
+ Filter: TSamplingFilter = DefaultCubicFilter; WrapEdges:
+ Boolean = False): IBitmap; overload;
+
+function GraphicsEngine: string;
+
implementation
{$ifdef linux}
@@ -388,17 +446,21 @@ function NewMatrix: IMatrix;
Result := NewMatrixCairo;
end;
-function NewPen(Brush: IBrush; Width: Float): IPen;
+function NewPen(Brush: IBrush; Width: Float = 1; Join: TLineJoin = jnMiter): IPen; overload;
begin
Result := NewPenCairo(Brush, Width);
+ Result.LineJoin := Join;
+ Result.LineCap := JoinCaps[Join];
end;
-function NewPen(Color: TBGRA; Width: Float): IPen;
+function NewPen(Color: TColorB; Width: Float = 1; Join: TLineJoin = jnMiter): IPen;
begin
Result := NewPenCairo(Color, Width);
+ Result.LineJoin := Join;
+ Result.LineCap := JoinCaps[Join];
end;
-function NewBrush(Color: TBGRA): ISolidBrush;
+function NewBrush(Color: TColorB): ISolidBrush;
begin
Result := NewSolidBrushCairo(Color);
end;
@@ -431,6 +493,8 @@ function NewFont(const FontName: string; FontSize: Integer = 10): IFont;
function NewFont(Font: TFont = nil): IFont;
begin
Result := NewFontCairo(Font);
+ if (Font = nil) or (Font.Color = clDefault) then
+ Result.Color := ColorToRGB(clWindowText);
end;
function NewSurface(Canvas: TCanvas): ISurface;
@@ -452,6 +516,12 @@ function NewSplash: ISplash;
begin
Result := NewSplashCairo;
end;
+
+function NewScreenCapture: IBitmap;
+begin
+ Result := NewScreenCaptureGtk;
+end;
+
{$endif}
{$ifdef windows}
uses
@@ -467,23 +537,27 @@ function NewMatrix: IMatrix;
Result := NewMatrixGdi;
end;
-function NewPen(Brush: IBrush; Width: Float): IPen;
+function NewPen(Brush: IBrush; Width: Float = 1; Join: TLineJoin = jnMiter): IPen;
begin
if LoadD2D then
Result := NewPenD2D(Brush, Width)
else
Result := NewPenGdi(Brush, Width);
+ Result.LineJoin := Join;
+ Result.LineCap := JoinCaps[Join];
end;
-function NewPen(Color: TBGRA; Width: Float): IPen;
+function NewPen(Color: TColorB; Width: Float = 1; Join: TLineJoin = jnMiter): IPen;
begin
if LoadD2D then
Result := NewPenD2D(Color, Width)
else
Result := NewPenGdi(Color, Width);
+ Result.LineJoin := Join;
+ Result.LineCap := JoinCaps[Join];
end;
-function NewBrush(Color: TBGRA): ISolidBrush;
+function NewBrush(Color: TColorB): ISolidBrush;
begin
if LoadD2D then
Result := NewSolidBrushD2D(Color)
@@ -523,6 +597,20 @@ function NewBrush(const Rect: TRectF): IRadialGradientBrush;
Result := NewRadialGradientBrushGdi(Rect);
end;
+function NewFont(const FontName: string; FontSize: Integer = 10): IFont;
+var
+ F: TFont;
+begin
+ F := TFont.Create;
+ try
+ F.Name := FontName;
+ F.Size := FontSize;
+ Result := NewFont(F);
+ finally
+ F.Free;
+ end;
+end;
+
function NewFont(Font: TFont): IFont;
begin
if LoadD2D then
@@ -568,11 +656,16 @@ function NewBitmapGdiStub: IBitmap;
function NewSplash: ISplash;
begin
if LoadD2D then
- NewBitmapProc := NewBitmapD2DStub
- else
- NewBitmapProc := NewBitmapGdiStub;
+ NewBitmapProc := NewBitmapD2DStub
+ else
+ NewBitmapProc := NewBitmapGdiStub;
Result := NewSplashWin;
end;
+
+function NewScreenCapture: IBitmap;
+begin
+ Result := nil;
+end;
{$endif}
{ TSurfaceBitmap }
@@ -702,9 +795,18 @@ procedure TSurfaceBitmap.WriteData(Stream: TStream);
end;
procedure TSurfaceBitmap.DefineProperties(Filer: TFiler);
+
+ function CanWrite: Boolean;
+ begin
+ { TODO: Test whether adding form inherited flag on TSurfaceBitmap is needed }
+ Result := (not Empty) and (Filer.Ancestor is TSurfaceBitmap);
+ if Result then
+ Result := not Equals(TSurfaceBitmap(Filer.Ancestor));
+ end;
+
begin
inherited DefineProperties(Filer);
- Filer.DefineBinaryProperty('Data', ReadData, WriteData, not Empty);
+ Filer.DefineBinaryProperty('Data', ReadData, WriteData, CanWrite);
end;
function TSurfaceBitmap.GetTransparent: Boolean;
@@ -714,7 +816,6 @@ function TSurfaceBitmap.GetTransparent: Boolean;
procedure TSurfaceBitmap.SetTransparent(Value: Boolean);
begin
- Value := True;
end;
function TSurfaceBitmap.GetWidth: Integer;
@@ -1134,13 +1235,47 @@ function TImageStrip.GetSize: Integer;
Result := FBitmap.Frames[0].Height;
end;
+procedure TImageStrip.Colorize(Color: TColorB);
+var
+ A: Single;
+ P: PPixel;
+ I: Integer;
+begin
+ if FBitmap.Empty then
+ Exit;
+ P := FBitmap.Pixels;
+ for I := 1 to FBitmap.Width * FBitmap.Height do
+ begin
+ if P.Alpha = 0 then
+ begin
+ P.Red := 0;
+ P.Green := 0;
+ P.Blue := 0;
+ end
+ else if P.Alpha = $FF then
+ begin
+ P.Red := Color.Red;
+ P.Green := Color.Green;
+ P.Blue := Color.Blue;
+ end
+ else
+ begin
+ A := P.Alpha / $FF;
+ P.Red := Round(Color.Red * A);
+ P.Green := Round(Color.Green * A);
+ P.Blue := Round(Color.Blue * A);
+ end;
+ Inc(P);
+ end;
+end;
+
procedure TImageStrip.CopyTo(Bitmap: IBitmap);
var
B: IBitmap;
R: TRectI;
begin
Bitmap.Clear;
- if not FBitmap.Empty then
+ if not FBitmap.Empty then
begin
B := FBitmap.Bitmap;
R := B.ClientRect;
@@ -1435,6 +1570,40 @@ procedure TImageStrip.Assign(Source: TPersistent);
FBitmap.Assign(Source);
end;
+{ TBitmapHelper }
+
+procedure TBitmapHelper.Colorize(Color: TColorB);
+var
+ W, H, X, Y: Integer;
+ B: PByte;
+ A: Single;
+begin
+ if Self.PixelFormat <> pf32bit then
+ Exit;
+ W := Self.Width;
+ H := Self.Height;
+ if (W < 1) or (H < 1 ) then
+ Exit;
+ Self.BeginUpdate;
+ for Y := 0 to H - 1 do
+ begin
+ B := Self.RawImage.GetLineStart(Y);
+ for X := 0 to W - 1 do
+ begin
+ A := B[3] / 255;
+ B^ := Trunc(Color.Blue * A);
+ Inc(B);
+ B^ := Trunc(Color.Green * A);
+ Inc(B);
+ B^ := Trunc(Color.Red * A);
+ Inc(B);
+ Inc(B);
+ end;
+ end;
+ Self.EndUpdate;
+end;
+
+
procedure FillRectColor(Surface: ISurface; const Rect: TRectI; Color: TColorB; Radius: Float = 0);
begin
if Radius < 1 then
@@ -1465,6 +1634,28 @@ procedure FillRectState(Surface: ISurface; const Rect: TRectI; State: TDrawState
Surface.FillRect(NewBrush(clWindow), Rect);
end;
+procedure FillRectStateOutlined(Surface: ISurface; const Rect: TRectI; State: TDrawState);
+var
+ C: TColorB;
+begin
+ if dsSelected in State then
+ begin
+ C := clHighlight;
+ if dsFocused in State then
+ begin
+ Surface.FillRect(NewBrush(C.Blend(clWindow, 0.75)), Rect);
+ Surface.StrokeRect(NewPen(C.Blend(clWindow, 0.25)), Rect);
+ end
+ else
+ begin
+ Surface.FillRect(NewBrush(clWindow), Rect);
+ Surface.StrokeRect(NewPen(C.Blend(clWindow, 0.25)), Rect);
+ end;
+ end
+ else
+ Surface.FillRect(NewBrush(clWindow), Rect);
+end;
+
procedure FillRectSelected(Surface: ISurface; const Rect: TRectI; Radius: Float = 0);
var
C: TColorB;
@@ -1652,6 +1843,29 @@ procedure DrawShadow(Surface: ISurface; const Rect: TRectI; Direction: TDirectio
R.Top := R.Top + 1;
end;
end;
+ else
+ end;
+end;
+
+function DrawTextIcons(const S: string; Font: IFont; Width, Height: Integer): IBitmap;
+var
+ R: TRectI;
+ P: PChar;
+ C: string;
+ I: Integer;
+begin
+ I := UnicodeLength(S);
+ if I < 1 then
+ Exit(NewBitmap);
+ Result := NewBitmap(Width * I, Height);
+ R := TRectI.Create(Width, Height);
+ P := PChar(S);
+ while I > 0 do
+ begin
+ C := UnicodeToStr(UnicodeToChar(P));
+ Result.Surface.TextOut(Font, C, R, drCenter);
+ R.Offset(Width, 0);
+ Dec(I);
end;
end;
@@ -1660,7 +1874,7 @@ procedure DrawEasing(Surface: ISurface; Font: IFont; Rect: TRectF;
var
P: IPen;
R: TRectF;
- C: TColorB;
+ //C: TColorB;
X, Y: Float;
I, J: Integer;
begin
@@ -1706,7 +1920,7 @@ procedure DrawEasing(Surface: ISurface; Font: IFont; Rect: TRectF;
{ label the axis }
Y := Surface.TextSize(Font, 'Wg').Y;
R.Top := R.Top - Y;
- C := Theme.Font.Color;
+ //C := Theme.Font.Color;
Font.Color := clGray;
{ The left axis is the delta, or change over time }
Surface.TextOut(Font, 'delta', R, drWrap);
@@ -1715,7 +1929,48 @@ procedure DrawEasing(Surface: ISurface; Font: IFont; Rect: TRectF;
R.Height := Y;
{ The bottom axis is time }
Surface.TextOut(Font, 'time', R, drRight);
- Theme.Font.Color := C;
+ //Theme.Font.Color := C;
+end;
+
+procedure LoadCursor(const ResName: string; Cursor: TCursor);
+var
+ C: TCursorImage;
+begin
+ C := TCursorImage.Create;
+ try
+ C.LoadFromResourceName(HINSTANCE, ResName);
+ Screen.Cursors[Cursor] := C.ReleaseHandle;
+ finally
+ C.Free;
+ end;
+end;
+
+procedure CaptureScreen(Dest: TBitmap);
+var
+ DC: HDC;
+begin
+ DC := GetDC(0);
+ with Dest do
+ begin
+ Width := Screen.Width;
+ Height := Screen.Height;
+ end;
+ Dest.LoadFromDevice(DC);
+ ReleaseDC(0, DC);
+end;
+
+procedure CaptureScreenRect(Rect: TRectI; Dest: TBitmap);
+var
+ DC: HDC;
+begin
+ if Rect.Empty then
+ Exit;
+ DC := GetDC(0);
+ if (Dest.Width <> Rect.Width) or (Dest.Height <> Rect.Height) then
+ Dest.SetSize(Rect.Width, Rect.Height);
+ BitBlt(HDC(Dest.Canvas.Handle), 0, 0, Rect.Width, Rect.Height,
+ DC, Rect.Left, Rect.Top, SRCCOPY);
+ ReleaseDC(0, DC);
end;
type
@@ -1741,9 +1996,6 @@ procedure BrushesRegisterDefaults;
BrushNames.Add('Floor Tile', @Brushes.FloorTile);
BrushNames.Add('Snake Skin', @Brushes.SnakeSkin);
BrushNames.Add('Pipes', @Brushes.Pipes);
-
-
-
end;
function StrToBrush(Name: string; Foreground, Background: TColorB; PenWidth: Float = DefPenWidth; BrushSize: Integer = DefBrushSize): IBrush;
@@ -2186,6 +2438,19 @@ function TDrawControlHelper.GetParentCurrentColor: TColorB;
Result := clTransparent;
end;
+function TDrawControlHelper.GetParentEnabled: Boolean;
+var
+ C: TControl;
+begin
+ C := Self;
+ Result := Enabled;
+ while Result and (C.Parent <> nil) do
+ begin
+ C := C.Parent;
+ Result := C.Enabled;
+ end;
+end;
+
function TDrawControlHelper.TextHeight: Integer;
begin
if FontBitmap = nil then
@@ -2274,32 +2539,21 @@ procedure TDrawControlHelper.DrawBitmap(Surface: ISurface; Bitmap: IBitmap; X, Y
procedure TDrawControlHelper.DrawCaption(Surface: ISurface; const Caption: string; const Rect: TRectI; Enabled: Boolean = True);
var
F: IFont;
- C: TColorB;
- R: TRectI;
begin
F := NewFont(Self.Font);
- C := Font.Color;
- R := Rect;
- if not Enabled then
- begin
- R.Offset(1, 1);
- F.Color := clWhite;
- end;
- Surface.TextOut(F, Caption, R, drLeft);
if not Enabled then
- begin
- R.Offset(-1, -1);
- if THSL(C).Lightness > 0.5 then
- F.Color := C.Darken(0.5).Desaturate(0.5)
- else
- F.Color := C.Lighten(0.5).Desaturate(0.5);
- Surface.TextOut(F, Caption, R, drLeft);
- end
+ F.Color := ColorToRGB(clGrayText);
+ Surface.TextOut(F, Caption, Rect, drLeft);
end;
procedure TDrawControlHelper.DrawText(Surface: ISurface; const Text: string; const Rect: TRectI; Direction: TDirection);
+var
+ F: IFont;
begin
- Surface.TextOut(NewFont(Self.Font), Text, Rect, Direction);
+ F := NewFont(Self.Font);
+ if not Enabled then
+ F.Color := ColorToRGB(clGrayText);
+ Surface.TextOut(F, Text, Rect, Direction);
end;
procedure TDrawControlHelper.DrawTextState(Surface: ISurface; const Text: string; const Rect: TRectI; State: TDrawState; Radius: Float = 0);
@@ -2499,19 +2753,18 @@ class function TTheme.GetSelected: Boolean;
class procedure TDefaultTheme.DrawButton(const Rect: TRectI);
begin
-
end;
class procedure TDefaultTheme.DrawButtonThin(const Rect: TRectI);
const
- Radius = 3;
+ Radius = 2;
var
R: TRectI;
C: TColorB;
G: IGradientBrush;
begin
R := Rect;
- C := Control.CurrentColor;
+ C := clBtnShadow;
if dsPressed in State then
begin
G := NewBrush(0, 0, 0, R.Height);
@@ -2524,13 +2777,12 @@ class procedure TDefaultTheme.DrawButtonThin(const Rect: TRectI);
begin
G := NewBrush(R.Left, R.Top, R.Left, R.Bottom);
C := Control.CurrentColor;
- G.AddStop(C.Lighten(0.5), 0);
- G.AddStop(C.Darken(0.2), 1);
+ G.AddStop(C.Lighten(0.4), 0);
+ G.AddStop(C.Darken(0.1), 1);
R.Inflate(-1, -1);
Surface.FillRect(G, R);
- Surface.StrokeRect(NewPen(clWhite), R);
R.Inflate(1, 1);
- Surface.StrokeRoundRect(NewPen(clBtnShadow), Rect, Radius);
+ Surface.StrokeRoundRect(NewPen(C.Darken(0.2)), Rect, Radius);
end;
end;
@@ -2642,10 +2894,11 @@ class procedure TDefaultTheme.DrawHeaderColumn(const Rect: TRectI; Sort: TSortin
begin
C := clHighlight;
H := THSL(C);
- H.Lightness := 0.925;
+ H.Lightness := 0.5;
C := H;
+ C.Alpha := 170;
B.AddStop(C, 0.4);
- C := C.Lighten(0.6);
+ C := C.Lighten(0.4);
B.AddStop(C, 0.5);
end
else
@@ -2653,19 +2906,19 @@ class procedure TDefaultTheme.DrawHeaderColumn(const Rect: TRectI; Sort: TSortin
C := Control.CurrentColor;
B.AddStop(C.Fade(0.8).Darken(0.1), 0);
B.AddStop(C, 0.5);
- B.AddStop(C.Lighten(0.8), 0.75);
+ B.AddStop(C.Lighten(0.1), 0.75);
end;
Surface.FillRect(B, R);
if dsBackground in State then
Exit;
- R.Inflate(-1, -1);
- R.Bottom := Rect.Bottom + 1;
- StrokeRectColor(Surface, R, clWhite);
+ //R.Inflate(-1, -1);
+ //R.Bottom := Rect.Bottom + 1;
+ //StrokeRectColor(Surface, R, clBtnFace);
R := Rect;
R.Inflate(0, 5);
R.Left := -5;
- C := clBtnShadow;
- C := C.Lighten(0.5);
+ C := clBtnFace;
+ C := C.Lighten(0.3);
StrokeRectColor(Surface, R, C);
C := clBtnShadow;
C := C.Lighten(0.4);
@@ -2679,9 +2932,10 @@ class procedure TDefaultTheme.DrawHeaderColumn(const Rect: TRectI; Sort: TSortin
else if dsSelected in State then
begin
C := clHighlight;
- C := C.Lighten(0.5);
+ C := C.Lighten(0.25);
R := Rect;
R.Left := R.Left - 1;
+ if R.Left < 0 then R.Left := 0;
StrokeRectColor(Surface, R, C);
C := clHighlight;
C := C.Lighten(0.25);
@@ -2728,10 +2982,11 @@ class procedure TDefaultTheme.DrawHeader(Height: Integer = DefaulHeaderHeight);
R := Control.ClientRect;
R.Height := Height;
B := NewBrush(0, 0, 0, R.Height);
- C := Control.CurrentColor;
- B.AddStop(C.Fade(0.8).Darken(0.1), 0);
- B.AddStop(C, 0.5);
- B.AddStop(C.Lighten(0.8), 1);
+ C := clTransparent;
+ B.AddStop(C, 0.8);
+ C := clBlack;
+ C.Alpha := 100;
+ B.AddStop(C, 1);
Surface.FillRect(B, R);
end;
@@ -2898,7 +3153,9 @@ class procedure TRedmondTheme.DrawEditBorder(const Rect: TRectI);
class procedure TRedmondTheme.DrawHeaderColumn(const Rect: TRectI; Sort: TSortingOrder = soNone);
begin
-
+ Surface.MoveTo(Rect.Right - 0.5, Rect.Top);
+ Surface.LineTo(Rect.Right - 0.5, Rect.Bottom);
+ Surface.Stroke(NewPen(clBtnShadow));
end;
class procedure TRedmondTheme.DrawHeader(Height: Integer = DefaulHeaderHeight);
@@ -2921,6 +3178,485 @@ class procedure TRedmondTheme.DrawFooterGrip;
end;
+{ Type of custom sampling function}
+
+type
+ TPointRec = record
+ Pos: LongInt;
+ Weight: Single;
+ end;
+
+ TCluster = array of TPointRec;
+ TMappingTable = array of TCluster;
+
+var
+ FullEdge: Boolean = True;
+
+function ClampInt(Number: LongInt; Min, Max: LongInt): LongInt;
+begin
+ Result := Number;
+ if Result < Min then
+ Result := Min
+ else if Result > Max then
+ Result := Max;
+end;
+
+{ The following resampling code is modified and extended code from Graphics32
+ library by Alex A. Denisov }
+
+function BuildMappingTable(DstLow, DstHigh, SrcLow, SrcHigh, SrcImageWidth: LongInt;
+ Filter: TFilterFunction; Radius: Single; WrapEdges: Boolean): TMappingTable;
+var
+ I, J, K, N: LongInt;
+ Left, Right, SrcWidth, DstWidth: LongInt;
+ Weight, Scale, Center, Count: Single;
+begin
+ Result := nil;
+ K := 0;
+ SrcWidth := SrcHigh - SrcLow;
+ DstWidth := DstHigh - DstLow;
+ if SrcWidth = 1 then
+ begin
+ SetLength(Result, DstWidth);
+ for I := 0 to DstWidth - 1 do
+ begin
+ SetLength(Result[I], 1);
+ Result[I][0].Pos := 0;
+ Result[I][0].Weight := 1.0;
+ end;
+ Exit;
+ end
+ else if (SrcWidth = 0) or (DstWidth = 0) then
+ Exit;
+ if FullEdge then
+ Scale := DstWidth / SrcWidth
+ else
+ Scale := (DstWidth - 1) / (SrcWidth - 1);
+ SetLength(Result, DstWidth);
+ if Scale = 0.0 then
+ begin
+ Assert(Length(Result) = 1);
+ SetLength(Result[0], 1);
+ Result[0][0].Pos := (SrcLow + SrcHigh) div 2;
+ Result[0][0].Weight := 1.0;
+ end
+ else if Scale < 1.0 then
+ begin
+ Radius := Radius / Scale;
+ for I := 0 to DstWidth - 1 do
+ begin
+ if FullEdge then
+ Center := SrcLow - 0.5 + (I + 0.5) / Scale
+ else
+ Center := SrcLow + I / Scale;
+ Left := Round(Floor(Center - Radius));
+ Right := Round(Ceil(Center + Radius));
+ Count := -1.0;
+ for J := Left to Right do
+ begin
+ Weight := Filter((Center - J) * Scale) * Scale;
+ if Weight <> 0.0 then
+ begin
+ Count := Count + Weight;
+ K := Length(Result[I]);
+ SetLength(Result[I], K + 1);
+ Result[I][K].Pos := ClampInt(J, SrcLow, SrcHigh - 1);
+ Result[I][K].Weight := Weight;
+ end;
+ end;
+ if Length(Result[I]) = 0 then
+ begin
+ SetLength(Result[I], 1);
+ Result[I][0].Pos := Round(Floor(Center));
+ Result[I][0].Weight := 1.0;
+ end
+ else if Count <> 0.0 then
+ Result[I][K div 2].Weight := Result[I][K div 2].Weight - Count;
+ end;
+ end
+ else // if Scale > 1.0 then
+ begin
+ // Super-sampling - scales from smaller to bigger
+ Scale := 1.0 / Scale;
+ for I := 0 to DstWidth - 1 do
+ begin
+ if FullEdge then
+ Center := SrcLow - 0.5 + (I + 0.5) * Scale
+ else
+ Center := SrcLow + I * Scale;
+ Left := Round(Floor(Center - Radius));
+ Right := Round(Ceil(Center + Radius));
+ Count := -1.0;
+ for J := Left to Right do
+ begin
+ Weight := Filter(Center - J);
+ if Weight <> 0.0 then
+ begin
+ Count := Count + Weight;
+ K := Length(Result[I]);
+ SetLength(Result[I], K + 1);
+ if WrapEdges then
+ begin
+ if J < 0 then
+ N := SrcImageWidth + J
+ else if J >= SrcImageWidth then
+ N := J - SrcImageWidth
+ else
+ N := ClampInt(J, SrcLow, SrcHigh - 1);
+ end
+ else
+ N := ClampInt(J, SrcLow, SrcHigh - 1);
+ Result[I][K].Pos := N;
+ Result[I][K].Weight := Weight;
+ end;
+ end;
+ if Count <> 0.0 then
+ Result[I][K div 2].Weight := Result[I][K div 2].Weight - Count;
+ end;
+ end;
+end;
+
+procedure FindExtremes(const Map: TMappingTable; out MinPos, MaxPos: LongInt);
+var
+ I, J: LongInt;
+begin
+ MinPos := 0;
+ MaxPos := 0;
+ if Length(Map) > 0 then
+ begin
+ MinPos := Map[0][0].Pos;
+ MaxPos := MinPos;
+ for I := 0 to Length(Map) - 1 do
+ for J := 0 to Length(Map[I]) - 1 do
+ begin
+ if MinPos > Map[I][J].Pos then
+ MinPos := Map[I][J].Pos;
+ if MaxPos < Map[I][J].Pos then
+ MaxPos := Map[I][J].Pos;
+ end;
+ end;
+end;
+
+{ Filter function for nearest filtering. Also known as box filter }
+
+function FilterNearest(Value: Single): Single;
+begin
+ if (Value > -0.5) and (Value <= 0.5) then
+ Result := 1
+ else
+ Result := 0;
+end;
+
+{ Filter function for linear filtering. Also known as triangle or Bartlett filter }
+
+function FilterLinear(Value: Single): Single;
+begin
+ if Value < 0.0 then
+ Value := -Value;
+ if Value < 1.0 then
+ Result := 1.0 - Value
+ else
+ Result := 0.0;
+end;
+
+{ Cosine filter }
+
+function FilterCosine(Value: Single): Single;
+begin
+ Result := 0;
+ if Abs(Value) < 1 then
+ Result := (Cos(Value * Pi) + 1) / 2;
+end;
+
+{ Hermite filter }
+
+function FilterHermite(Value: Single): Single;
+begin
+ if Value < 0.0 then
+ Value := -Value;
+ if Value < 1 then
+ Result := (2 * Value - 3) * Sqr(Value) + 1
+ else
+ Result := 0;
+end;
+
+{ Quadratic filter. Also known as Bell }
+
+function FilterQuadratic(Value: Single): Single;
+begin
+ if Value < 0.0 then
+ Value := -Value;
+ if Value < 0.5 then
+ Result := 0.75 - Sqr(Value)
+ else
+ if Value < 1.5 then
+ begin
+ Value := Value - 1.5;
+ Result := 0.5 * Sqr(Value);
+ end
+ else
+ Result := 0.0;
+end;
+
+{ Gaussian filter }
+
+function FilterGaussian(Value: Single): Single;
+begin
+ Result := Exp(-2.0 * Sqr(Value)) * Sqrt(2.0 / Pi);
+end;
+
+{ 4th order (cubic) b-spline filter }
+
+function FilterSpline(Value: Single): Single;
+var
+ Temp: Single;
+begin
+ if Value < 0.0 then
+ Value := -Value;
+ if Value < 1.0 then
+ begin
+ Temp := Sqr(Value);
+ Result := 0.5 * Temp * Value - Temp + 2.0 / 3.0;
+ end
+ else
+ if Value < 2.0 then
+ begin
+ Value := 2.0 - Value;
+ Result := Sqr(Value) * Value / 6.0;
+ end
+ else
+ Result := 0.0;
+end;
+
+{ Lanczos-windowed sinc filter }
+
+function FilterLanczos(Value: Single): Single;
+
+ function SinC(Value: Single): Single;
+ begin
+ if Value <> 0.0 then
+ begin
+ Value := Value * Pi;
+ Result := Sin(Value) / Value;
+ end
+ else
+ Result := 1.0;
+ end;
+
+begin
+ if Value < 0.0 then
+ Value := -Value;
+ if Value < 3.0 then
+ Result := SinC(Value) * SinC(Value / 3.0)
+ else
+ Result := 0.0;
+end;
+
+{ Micthell cubic filter }
+
+function FilterMitchell(Value: Single): Single;
+const
+ B = 1.0 / 3.0;
+ C = 1.0 / 3.0;
+var
+ Temp: Single;
+begin
+ if Value < 0.0 then
+ Value := -Value;
+ Temp := Sqr(Value);
+ if Value < 1.0 then
+ begin
+ Value := (((12.0 - 9.0 * B - 6.0 * C) * (Value * Temp)) +
+ ((-18.0 + 12.0 * B + 6.0 * C) * Temp) +
+ (6.0 - 2.0 * B));
+ Result := Value / 6.0;
+ end
+ else
+ if Value < 2.0 then
+ begin
+ Value := (((-B - 6.0 * C) * (Value * Temp)) +
+ ((6.0 * B + 30.0 * C) * Temp) +
+ ((-12.0 * B - 48.0 * C) * Value) +
+ (8.0 * B + 24.0 * C));
+ Result := Value / 6.0;
+ end
+ else
+ Result := 0.0;
+end;
+
+{ CatmullRom spline filter }
+
+function FilterCatmullRom(Value: Single): Single;
+begin
+ if Value < 0.0 then
+ Value := -Value;
+ if Value < 1.0 then
+ Result := 0.5 * (2.0 + Sqr(Value) * (-5.0 + 3.0 * Value))
+ else
+ if Value < 2.0 then
+ Result := 0.5 * (4.0 + Value * (-8.0 + Value * (5.0 - Value)))
+ else
+ Result := 0.0;
+end;
+
+var
+ InitResampleDone: Boolean;
+
+procedure InitResample;
+begin
+ if InitResampleDone then
+ Exit;
+ InitResampleDone := True;
+ SamplingFilterFunctions[sfNearest] := FilterNearest;
+ SamplingFilterFunctions[sfLinear] := FilterLinear;
+ SamplingFilterFunctions[sfCosine] := FilterCosine;
+ SamplingFilterFunctions[sfHermite] := FilterHermite;
+ SamplingFilterFunctions[sfQuadratic] := FilterQuadratic;
+ SamplingFilterFunctions[sfGaussian] := FilterGaussian;
+ SamplingFilterFunctions[sfSpline] := FilterSpline;
+ SamplingFilterFunctions[sfLanczos] := FilterLanczos;
+ SamplingFilterFunctions[sfMitchell] := FilterMitchell;
+ SamplingFilterFunctions[sfCatmullRom] := FilterCatmullRom;
+ SamplingFilterRadii[sfNearest] := 1.0;
+ SamplingFilterRadii[sfLinear] := 1.0;
+ SamplingFilterRadii[sfCosine] := 1.0;
+ SamplingFilterRadii[sfHermite] := 1.0;
+ SamplingFilterRadii[sfQuadratic] := 1.5;
+ SamplingFilterRadii[sfGaussian] := 1.25;
+ SamplingFilterRadii[sfSpline] := 2.0;
+ SamplingFilterRadii[sfLanczos] := 3.0;
+ SamplingFilterRadii[sfMitchell] := 2.0;
+ SamplingFilterRadii[sfCatmullRom] := 2.0;
+end;
+
+procedure ResampleBitmap(Src: IBitmap; SrcX, SrcY, SrcWidth, SrcHeight: LongInt;
+ Dst: IBitmap; DstX, DstY, DstWidth, DstHeight: LongInt;
+ Filter: TFilterFunction; Radius: Single; WrapEdges: Boolean);
+type
+ TBufferItem = record
+ A, R, G, B: Integer;
+ end;
+ TByteArray = array[0..High(LongWord) div 4] of Byte;
+ PByteArray = ^TByteArray;
+
+var
+ MapX, MapY: TMappingTable;
+ MinX, MaxX: Integer;
+ LineBufferInt: array of TBufferItem;
+ ClusterX, ClusterY: TCluster;
+ Speed, Weight, AccumA, AccumR, AccumG, AccumB: Integer;
+ SrcColor: TPixel;
+ Pixels: PPixel;
+ SrcPixels: array of PByteArray;
+ DstPixels: array of PByteArray;
+ I, J, X, Y: Integer;
+begin
+ InitResample;
+ if (Src.Width < 2) or (Src.Height < 2) or (Dst.Width < 2) or (Dst.Height < 2) then Exit;
+ MapX := BuildMappingTable(DstX, DstX + DstWidth , SrcX, SrcX + SrcWidth , Src.Width , Filter, Radius, WrapEdges);
+ MapY := BuildMappingTable(DstY, DstY + DstHeight, SrcY, SrcY + SrcHeight, Src.Height, Filter, Radius, WrapEdges);
+ ClusterX := nil;
+ ClusterY := nil;
+ SetLength(SrcPixels{%H-}, Src.Height);
+ Pixels := Src.Pixels;
+ for I := 0 to Src.Height - 1 do
+ begin
+ SrcPixels[I] := PByteArray(Pixels);
+ Inc(Pixels, Src.Width);
+ end;
+ SetLength(DstPixels{%H-}, Dst.Height);
+ Pixels := Dst.Pixels;
+ for I := 0 to Dst.Height - 1 do
+ begin
+ DstPixels[I] := PByteArray(Pixels);
+ Inc(Pixels, Dst.Width);
+ end;
+ FindExtremes(MapX, MinX, MaxX);
+ SetLength(LineBufferInt{%H-}, MaxX - MinX + 1);
+ for J := 0 to DstHeight - 1 do
+ begin
+ ClusterY := MapY[J];
+ for X := MinX to MaxX do
+ begin
+ AccumA := 0;
+ AccumR := 0;
+ AccumG := 0;
+ AccumB := 0;
+ for Y := 0 to Length(ClusterY) - 1 do
+ begin
+ Weight := Round(256 * ClusterY[Y].Weight);
+ Speed := X * 4;
+ AccumB := AccumB + SrcPixels[ClusterY[Y].Pos][Speed] * Weight;
+ AccumG := AccumG + SrcPixels[ClusterY[Y].Pos][Speed + 1] * Weight;
+ AccumR := AccumR + SrcPixels[ClusterY[Y].Pos][Speed + 2] * Weight;
+ AccumA := AccumA + SrcPixels[ClusterY[Y].Pos][Speed + 3] * Weight;
+ end;
+ with LineBufferInt[X - MinX] do
+ begin
+ A := AccumA;
+ R := AccumR;
+ G := AccumG;
+ B := AccumB;
+ end;
+ end;
+ for I := 0 to DstWidth - 1 do
+ begin
+ ClusterX := MapX[I];
+ AccumA := 0;
+ AccumR := 0;
+ AccumG := 0;
+ AccumB := 0;
+ for X := 0 to Length(ClusterX) - 1 do
+ begin
+ Weight := Round(256 * ClusterX[X].Weight);
+ with LineBufferInt[ClusterX[X].Pos - MinX] do
+ begin
+ AccumB := AccumB + B * Weight;
+ AccumG := AccumG + G * Weight;
+ AccumR := AccumR + R * Weight;
+ AccumA := AccumA + A * Weight;
+ end;
+ end;
+ SrcColor.Blue := ClampInt(AccumB, 0, $00FF0000) shr 16;
+ SrcColor.Green := ClampInt(AccumG, 0, $00FF0000) shr 16;
+ SrcColor.Red := ClampInt(AccumR, 0, $00FF0000) shr 16;
+ SrcColor.Alpha := ClampInt(AccumA, 0, $00FF0000) shr 16;
+ PLongWord(@DstPixels[J]^[(I + DstX) * 4])^ := PLongWord(@SrcColor)^;
+ end;
+ end;
+end;
+
+function ResampleBitmap(Bitmap: IBitmap; Width, Height: Integer;
+ Filter: TSamplingFilter = DefaultCubicFilter; WrapEdges: Boolean = False): IBitmap;
+
+ function IsEmpty(B: IBitmap): Boolean;
+ begin
+ Result := (B.Width < 1) or (B.Height < 1);
+ end;
+
+begin
+ InitResample;
+ Result := NewBitmap(Width, Height);
+ if IsEmpty(Bitmap) or IsEmpty(Result) then
+ Exit;
+ ResampleBitmap(Bitmap, 0, 0, Bitmap.Width, Bitmap.Height,
+ Result, 0, 0, Result.Width, Result.Height,
+ SamplingFilterFunctions[Filter], SamplingFilterRadii[Filter], WrapEdges);
+end;
+
+function GraphicsEngine: string;
+begin
+ {$ifdef linux}
+ Result := 'Cairo';
+ {$endif}
+ {$ifdef windows}
+ if LoadD2D then
+ Result := 'Direct2D'
+ else
+ Result := 'GDI+';
+ {$endif}
+end;
+
initialization
ThemeRegisiter(TDefaultTheme);
ThemeRegisiter(TRedmondTheme);
diff --git a/source/codebot.graphics.types.pas b/source/codebot/codebot.graphics.types.pas
similarity index 99%
rename from source/codebot.graphics.types.pas
rename to source/codebot/codebot.graphics.types.pas
index baf9335..c80af83 100644
--- a/source/codebot.graphics.types.pas
+++ b/source/codebot/codebot.graphics.types.pas
@@ -1,14 +1,15 @@
(********************************************************)
(* *)
-(* Codebot.Cross Pascal Library *)
+(* Codebot Pascal Library *)
(* http://cross.codebot.org *)
-(* Modified March 2015 *)
+(* Modified February 2020 *)
(* *)
(********************************************************)
{ }
unit Codebot.Graphics.Types;
+{$WARN 3177 off : Some fields coming after "$1" were not initialized}
{$i codebot.inc}
interface
@@ -119,6 +120,10 @@ TRectI = record
end;
PRectI = ^TRectI;
+{ TButtonRects is useful for virtualized buttons }
+
+ TButtonRects = TArrayList;
+
{ TPointF }
TPointF = record
@@ -278,7 +283,7 @@ THSL = record
{ TColorB }
TColorB = packed record
- public
+ public
Blue, Green, Red, Alpha: Byte;
class operator Implicit(Value: TColorB): TColorAlpha;
class operator Implicit(Value: TColorAlpha): TColorB;
@@ -614,11 +619,14 @@ function RadToDeg(R: Float): Float;
procedure SetStyle(Value: TFontStyles);
function GetSize: Float;
procedure SetSize(Value: Float);
+ function GetKerning: Float;
+ procedure SetKerning(Value: Float);
property Name: string read GetName write SetName;
property Color: TColorB read GetColor write SetColor;
property Quality: TFontQuality read GetQuality write SetQuality;
property Style: TFontStyles read GetStyle write SetStyle;
property Size: Float read GetSize write SetSize;
+ property Kerning: Float read GetKerning write SetKerning;
end;
{ IPathData can be obtained by cloning a path }
@@ -655,6 +663,7 @@ function RadToDeg(R: Float): Float;
function GetMatrix: IMatrix;
procedure SetMatrix(Value: IMatrix);
function GetPath: IPath;
+ function GetHandle: Pointer;
{ Wait for drawing operations to complete }
procedure Flush;
{ Fill the entire surface with a color }
@@ -706,6 +715,8 @@ function RadToDeg(R: Float): Float;
property Matrix: IMatrix read GetMatrix write SetMatrix;
{ The current path which can be stroked or filled }
property Path: IPath read GetPath;
+ { Handle }
+ property Handle: Pointer read GetHandle;
end;
{ IBitmap can load and save images as well as allow ISurface drawing in memory }
@@ -714,7 +725,6 @@ function RadToDeg(R: Float): Float;
IBitmap = interface(ICloneable)
['{DB935633-A218-4181-96A2-B0808697150F}']
- function Clone: IBitmap;
function GetEmpty: Boolean;
function GetSurface: ISurface;
function GetClientRect: TRectI;
@@ -792,6 +802,9 @@ TSurfaceOptions = record
GammaCorrection: False;
);
+const
+ JoinCaps: array[TLineJoin] of TLineCap = (cpButt, cpRound, cpButt);
+
implementation
const
@@ -1793,8 +1806,6 @@ class function THSL.Create(H, S, L: Float): THSL;
end;
class operator TColorB.Implicit(Value: TColorAlpha): TColorB;
-var
- B: TColorB absolute Value;
begin
Result.Blue := Value.Blue;
Result.Green := Value.Green;
diff --git a/source/codebot.graphics.windows.imagebitmap.pas b/source/codebot/codebot.graphics.windows.imagebitmap.pas
similarity index 99%
rename from source/codebot.graphics.windows.imagebitmap.pas
rename to source/codebot/codebot.graphics.windows.imagebitmap.pas
index 363fbd4..c4ebacb 100644
--- a/source/codebot.graphics.windows.imagebitmap.pas
+++ b/source/codebot/codebot.graphics.windows.imagebitmap.pas
@@ -382,7 +382,7 @@ procedure TImageBitmap.Blit(DC: HDC; const Rect: TRect; const Borders: TRect; Op
procedure TImageBitmap.Resize(AWidth, AHeight: Integer);
const
Formats: array[Boolean] of DWORD =
- (PixelFormat24bppRGB, PixelFormat32bppARGB);
+ (PixelFormat24bppRGB, PixelFormat32bppARGB);
var
B: TFastBitmap;
G: IGdiGraphics;
@@ -587,7 +587,7 @@ function TSharedStream.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64;
Result := FStream.Seek(O, Origin) - FStart;
end;
else
- Result := 0;
+ Result := 0{%H-};
end;
end;
@@ -760,7 +760,7 @@ procedure TImageBitmap.Save(Stream: TStream; const AFormat: TImageBitmapFormat);
OleCheck(FFactory.CreateBitmapFromMemory(FWidth, FHeight,
PixelFormat, ScanlineStride(FBitmap),
ScanlineStride(FBitmap) * FHeight, Bits, BitmapInstance));
- S := Format;
+ S := {%H-}Format;
OleCheck(WICMapShortNameToGuid(PWideChar(S), G));
BitmapSource := BitmapInstance;
OleCheck(FFactory.CreateEncoder(G, nil, BitmapEncoder));
@@ -797,7 +797,7 @@ procedure TImageBitmap.Save(Stream: TStream; const AFormat: TImageBitmapFormat);
procedure SaveGdiBitmap;
const
Formats: array[Boolean] of DWORD =
- (PixelFormat24bppRGB, PixelFormat32bppARGB);
+ (PixelFormat24bppRGB, PixelFormat32bppARGB);
var
B: IGdiBitmap;
G: TGUID;
diff --git a/source/codebot.graphics.windows.interfacedbitmap.pas b/source/codebot/codebot.graphics.windows.interfacedbitmap.pas
similarity index 99%
rename from source/codebot.graphics.windows.interfacedbitmap.pas
rename to source/codebot/codebot.graphics.windows.interfacedbitmap.pas
index 86ea24b..db80bb8 100644
--- a/source/codebot.graphics.windows.interfacedbitmap.pas
+++ b/source/codebot/codebot.graphics.windows.interfacedbitmap.pas
@@ -286,7 +286,7 @@ TSplashWin = class(TInterfacedObject, ISplash)
procedure SetOpacity(Value: Byte);
function GetVisible: Boolean;
procedure SetVisible(Value: Boolean);
- function GetHandle: THandle;
+ function GetHandle: IntPtr;
procedure Move(X, Y: Integer);
procedure Update;
end;
@@ -385,9 +385,9 @@ procedure TSplashWin.SetVisible(Value: Boolean);
end;
end;
-function TSplashWin.GetHandle: THandle;
+function TSplashWin.GetHandle: IntPtr;
begin
- Result := THandle(FWindow);
+ Result := IntPtr(FWindow);
end;
procedure TSplashWin.Move(X, Y: Integer);
diff --git a/source/codebot.graphics.windows.surfaced2d.pas b/source/codebot/codebot.graphics.windows.surfaced2d.pas
similarity index 98%
rename from source/codebot.graphics.windows.surfaced2d.pas
rename to source/codebot/codebot.graphics.windows.surfaced2d.pas
index b82a663..8a50594 100644
--- a/source/codebot.graphics.windows.surfaced2d.pas
+++ b/source/codebot/codebot.graphics.windows.surfaced2d.pas
@@ -15,7 +15,7 @@ interface
{$ifdef windows}
uses
- SysUtils, Classes, Graphics, Controls, ActiveX, Windows,
+ SysUtils, Classes, Graphics, Controls, Windows,
Codebot.System,
Codebot.Collections,
Codebot.Graphics.Types,
@@ -229,6 +229,7 @@ TFontD2D = class(TInterfacedObject, IFont)
public
constructor Create(F: TFont);
function GetName: string;
+ procedure SetName(const Value: string);
function GetColor: TColorB;
procedure SetColor(Value: TColorB);
function GetQuality: TFontQuality;
@@ -237,7 +238,7 @@ TFontD2D = class(TInterfacedObject, IFont)
procedure SetStyle(Value: TFontStyles);
function GetSize: Float;
procedure SetSize(Value: Float);
- property Name: string read GetName;
+ property Name: string read GetName write SetName;
property Color: TColorB read GetColor write SetColor;
property Quality: TFontQuality read GetQuality write SetQuality;
property Style: TFontStyles read GetStyle write SetStyle;
@@ -321,6 +322,7 @@ TSurfaceD2D = class(TInterfacedObject, ISurface)
function GetMatrix: IMatrix;
procedure SetMatrix(Value: IMatrix);
function GetPath: IPath;
+ function GetHandle: Pointer;
procedure Flush; virtual;
procedure Clear(Color: TColorB);
procedure CopyTo(const Source: TRectF; Surface: ISurface; const Dest: TRectF;
@@ -674,7 +676,7 @@ function CreateLinearGradientBrush(Target: ID2D1RenderTarget; const A, B: TPoint
S := Stops.Data;
I := Stops.Length;
end;
- { D2D1_GAMMA_1_0 is not supported by cairo }
+ { D2D1_GAMMA_1_0 is not supported by cairo }
if SurfaceOptions.GammaCorrection then
Gamma := D2D1_GAMMA_1_0
else
@@ -1316,6 +1318,11 @@ function TFontD2D.GetName: string;
Result := FName;
end;
+procedure TFontD2D.SetName(const Value: string);
+begin
+ FName := Value;
+end;
+
function TFontD2D.GetColor: TColorB;
begin
Result := FColor;
@@ -1328,12 +1335,12 @@ procedure TFontD2D.SetColor(Value: TColorB);
function TFontD2D.GetQuality: TFontQuality;
begin
- Result := FQuality;
+ Result := FQuality;
end;
procedure TFontD2D.SetQuality(Value: TFontQuality);
begin
- FQuality := Value;
+ FQuality := Value;
end;
function TFontD2D.GetStyle: TFontStyles;
@@ -1504,8 +1511,6 @@ function TSurfacePathD2D.ClipStack: IList;
end;
procedure TSurfacePathD2D.SaveClipStack;
-var
- I: Integer;
begin
if not HandleAvailable then
Exit;
@@ -1710,6 +1715,11 @@ function TSurfaceD2D.GetPath: IPath;
Result := FPath;
end;
+function TSurfaceD2D.GetHandle: Pointer;
+begin
+ Result := Self;
+end;
+
procedure TSurfaceD2D.Draw;
begin
if not FDrawing then
@@ -2214,11 +2224,11 @@ procedure TSurfaceD2D.TextOut(Font: IFont; const Text: string; const Rect: TRect
const
TrimChar: TDWriteTrimming = (granularity: DWRITE_TRIMMING_GRANULARITY_CHARACTER);
RenderingModes: array[TFontQuality] of DWORD = (DWRITE_RENDERING_MODE_DEFAULT,
- DWRITE_RENDERING_MODE_ALIASED, DWRITE_RENDERING_MODE_CLEARTYPE_GDI_CLASSIC, DWRITE_RENDERING_MODE_ALIASED,
- DWRITE_RENDERING_MODE_CLEARTYPE_GDI_CLASSIC, DWRITE_RENDERING_MODE_CLEARTYPE_GDI_CLASSIC,
- DWRITE_RENDERING_MODE_CLEARTYPE_NATURAL);
+ DWRITE_RENDERING_MODE_ALIASED, DWRITE_RENDERING_MODE_CLEARTYPE_GDI_CLASSIC, DWRITE_RENDERING_MODE_ALIASED,
+ DWRITE_RENDERING_MODE_CLEARTYPE_GDI_CLASSIC, DWRITE_RENDERING_MODE_CLEARTYPE_GDI_CLASSIC,
+ DWRITE_RENDERING_MODE_CLEARTYPE_NATURAL);
AntialiasModes: array[TFontQuality] of DWORD = (D2D1_TEXT_ANTIALIAS_MODE_DEFAULT,
- D2D1_TEXT_ANTIALIAS_MODE_ALIASED, D2D1_TEXT_ANTIALIAS_MODE_GRAYSCALE,
+ D2D1_TEXT_ANTIALIAS_MODE_ALIASED, D2D1_TEXT_ANTIALIAS_MODE_GRAYSCALE,
D2D1_TEXT_ANTIALIAS_MODE_ALIASED, D2D1_TEXT_ANTIALIAS_MODE_GRAYSCALE,
D2D1_TEXT_ANTIALIAS_MODE_CLEARTYPE, D2D1_TEXT_ANTIALIAS_MODE_CLEARTYPE);
var
@@ -2239,7 +2249,7 @@ procedure TSurfaceD2D.TextOut(Font: IFont; const Text: string; const Rect: TRect
Path.Remove;
if Rect.Empty or (Text = '') then
Exit;
- Draw;
+ Draw;
Path.Add;
FontObj := Font as TFontD2D;
{ It's hard to tell if CreateGdiTextLayout makes any difference }
@@ -2314,9 +2324,9 @@ procedure ApplyMatrix(Brush: ID2D1Brush; Matrix: IMatrix; out State: TD2D1Matrix
begin
State := MatrixIdentity;
if Brush = nil then
- Exit;
+ Exit;
M := (Matrix as TMatrixD2D).FMatrix;
- Brush.GetTransform(State);
+ Brush.GetTransform(State);
M := MatrixMultiply(State, M);
Brush.SetTransform(M);
end;
@@ -2324,14 +2334,14 @@ procedure ApplyMatrix(Brush: ID2D1Brush; Matrix: IMatrix; out State: TD2D1Matrix
procedure RestoreMatrix(Brush: ID2D1Brush; State: TD2D1Matrix3x2F);
begin
if Brush = nil then
- Exit;
+ Exit;
Brush.SetTransform(State);
end;
function PenWidth(Matrix: IMatrix; Width: Float): Float;
const
- A: TPointF = (X: 1; Y : 0);
- B: TPointF = (X: 0; Y : 0);
+ A: TPointF = (X: 1; Y : 0);
+ B: TPointF = (X: 0; Y : 0);
begin
Result := Matrix.Transform(A).Dist(Matrix.Transform(B));
Result := Abs(Result * Width);
@@ -2354,15 +2364,15 @@ procedure TSurfaceD2D.FillOrStroke(Brush: IBrush; Pen: IPen; Preserve: Boolean);
begin
Acquired := AcquireBrush(Brush, B);
if Acquired then
- ApplyMatrix(B, GetMatrix, State);
- end
- else
+ ApplyMatrix(B, GetMatrix, State);
+ end
+ else
begin
Acquired := AcquirePen(Pen, B, S);
if Acquired then
- ApplyMatrix(B, GetMatrix, State);
- end;
- if not Acquired then
+ ApplyMatrix(B, GetMatrix, State);
+ end;
+ if not Acquired then
Exit;
Draw;
P := Path;
@@ -2378,10 +2388,10 @@ procedure TSurfaceD2D.FillOrStroke(Brush: IBrush; Pen: IPen; Preserve: Boolean);
FTarget.FillGeometry(G, B)
else
FTarget.DrawGeometry(G, B, PenWidth(GetMatrix, Pen.Width), S);
- if not Preserve then
+ if not Preserve then
P.Remove;
if B <> nil then
- RestoreMatrix(B, State);
+ RestoreMatrix(B, State);
end;
procedure TSurfaceD2D.Stroke(Pen: IPen; Preserve: Boolean = False);
@@ -2638,7 +2648,7 @@ function NewSurfaceD2D(Canvas: TCanvas): ISurface;
if Canvas = nil then
begin
if ScreenDC = 0 then
- ScreenDC := GetDC(0);
+ ScreenDC := GetDC(0);
GetWindowRect(GetDesktopWindow, R);
T.BindDC(ScreenDC, TRectI.Create(R.Right - R.Left, R.Bottom - R.Top));
end
diff --git a/source/codebot.graphics.windows.surfacegdiplus.pas b/source/codebot/codebot.graphics.windows.surfacegdiplus.pas
similarity index 97%
rename from source/codebot.graphics.windows.surfacegdiplus.pas
rename to source/codebot/codebot.graphics.windows.surfacegdiplus.pas
index c3c1d85..91f0deb 100644
--- a/source/codebot.graphics.windows.surfacegdiplus.pas
+++ b/source/codebot/codebot.graphics.windows.surfacegdiplus.pas
@@ -208,7 +208,7 @@ TBitmapBrushGdi = class(TBrushGdi, IBitmapBrush)
public
constructor Create(Bitmap: IBitmap);
procedure SetOpacity(Value: Byte); override;
- end;
+ end;
{ TFontGdi }
@@ -223,6 +223,7 @@ TFontGdi = class(TInterfacedObject, IFont)
constructor Create(F: TFont);
destructor Destroy; override;
function GetName: string;
+ procedure SetName(const Value: string);
function GetColor: TColorB;
procedure SetColor(Value: TColorB);
function GetQuality: TFontQuality;
@@ -231,7 +232,7 @@ TFontGdi = class(TInterfacedObject, IFont)
procedure SetStyle(Value: TFontStyles);
function GetSize: Float;
procedure SetSize(Value: Float);
- property Name: string read GetName;
+ property Name: string read GetName write SetName;
property Color: TColorB read GetColor write SetColor;
property Quality: TFontQuality read GetQuality write SetQuality;
property Style: TFontStyles read GetStyle write SetStyle;
@@ -316,6 +317,7 @@ TSurfaceGdi = class(TInterfacedObject, ISurface)
function GetMatrix: IMatrix;
procedure SetMatrix(Value: IMatrix);
function GetPath: IPath;
+ function GetHandle: Pointer;
procedure Flush; virtual;
procedure Clear(Color: TColorB);
procedure CopyTo(const Source: TRectF; Surface: ISurface; const Dest: TRectF;
@@ -715,7 +717,7 @@ constructor TGradientBrushGdi.Create(const Origin: TPointF);
function TGradientBrushGdi.HandleAvailable: Boolean;
begin
- Result := (not FStops.IsEmpty) and (FOpacity > 0);
+ Result := (not FStops.IsEmpty) and (FOpacity > 0);
if not Result then
Exit;
if FBrush = nil then
@@ -824,7 +826,7 @@ function TLinearGradientBrushGdi.HandleAvailable: Boolean;
FGradient.SetWrapMode(Modes[FWrap]);
{ Gamma correction is not supported by cairo }
if SurfaceOptions.GammaCorrection then
- FGradient.SetGammaCorrection(True);
+ FGradient.SetGammaCorrection(True);
FBrush := FGradient;
Matrix.FChanged := True;
end;
@@ -917,7 +919,7 @@ function TRadialGradientBrushGdi.HandleAvailable: Boolean;
FGradient.SetCenterPoint(CenterPoint);
FGradient.SetInterpolationColors(Colors.Data, Offsets.Data, Colors.Length);
if SurfaceOptions.GammaCorrection then
- FGradient.SetGammaCorrection(True);
+ FGradient.SetGammaCorrection(True);
FBrush := FGradient;
Matrix.FChanged := True;
end;
@@ -989,8 +991,6 @@ destructor TFontGdi.Destroy;
end;
function TFontGdi.Font: IGdiFont;
-const
- Bytes: array[Boolean] of Byte = (0, 1);
var
DC: HDC;
begin
@@ -1008,6 +1008,11 @@ function TFontGdi.GetName: string;
Result := FFontObject.Name;
end;
+procedure TFontGdi.SetName(const Value: string);
+begin
+ FFontObject.Name := Value;
+end;
+
function TFontGdi.GetColor: TColorB;
begin
Result := FColor;
@@ -1025,7 +1030,7 @@ function TFontGdi.GetQuality: TFontQuality;
procedure TFontGdi.SetQuality(Value: TFontQuality);
begin
- FQuality := Value;
+ FQuality := Value;
end;
function TFontGdi.GetStyle: TFontStyles;
@@ -1082,7 +1087,7 @@ function TSurfacePathGdi.HandleAvailable: Boolean;
procedure TSurfacePathGdi.HandleRelease;
begin
FData := nil;
- FFigure := nil;
+ FFigure := nil;
FOrigin.X := 0;
FOrigin.Y := 0;
FClosed := False;
@@ -1302,6 +1307,11 @@ function TSurfaceGdi.GetPath: IPath;
Result := FPath;
end;
+function TSurfaceGdi.GetHandle: Pointer;
+begin
+ Result := Self;
+end;
+
procedure TSurfaceGdi.Flush;
begin
if not HandleAvailable then
@@ -1555,8 +1565,8 @@ procedure TSurfaceGdi.TextOut(Font: IFont; const Text: string; const Rect: TRect
Direction: TDirection; Immediate: Boolean = True);
const
TextHints: array[TFontQuality] of TTextRenderingHint = (
- TextRenderingHintSystemDefault, TextRenderingHintSingleBitPerPixelGridFit,
- TextRenderingHintAntiAliasGridFit, TextRenderingHintSingleBitPerPixelGridFit,
+ TextRenderingHintSystemDefault, TextRenderingHintSingleBitPerPixelGridFit,
+ TextRenderingHintAntiAliasGridFit, TextRenderingHintSingleBitPerPixelGridFit,
TextRenderingHintAntiAliasGridFit, TextRenderingHintClearTypeGridFit,
TextRenderingHintClearTypeGridFit);
var
@@ -1631,9 +1641,9 @@ procedure ApplyMatrix(Brush: IGdiBrush; Matrix: IMatrix; out State: IGdiMatrix);
begin
State := NewGdiMatrix;
if Brush = nil then
- Exit;
+ Exit;
M := (Matrix as TMatrixGdi).FMatrix.Clone;
- State := Brush.GetTransform;
+ State := Brush.GetTransform;
M.Multiply(State);
Brush.SetTransform(M);
end;
@@ -1641,14 +1651,14 @@ procedure ApplyMatrix(Brush: IGdiBrush; Matrix: IMatrix; out State: IGdiMatrix);
procedure RestoreMatrix(Brush: IGdiBrush; State: IGdiMatrix);
begin
if Brush = nil then
- Exit;
+ Exit;
Brush.SetTransform(State);
end;
function PenWidth(Matrix: IMatrix; Width: Float): Float;
const
- A: TPointF = (X: 1; Y : 0);
- B: TPointF = (X: 0; Y : 0);
+ A: TPointF = (X: 1; Y : 0);
+ B: TPointF = (X: 0; Y : 0);
begin
Result := Matrix.Transform(A).Dist(Matrix.Transform(B));
Result := Abs(Result * Width);
@@ -1671,22 +1681,22 @@ procedure TSurfaceGdi.FillOrStroke(Brush: IBrush; Pen: IPen; Preserve: Boolean);
ApplyMatrix((Brush as TBrushGdi).FBrush, GetMatrix, State);
FGraphics.FillPath((Brush as TBrushGdi).FBrush, P.FData);
RestoreMatrix((Brush as TBrushGdi).FBrush, State);
- end
- else if (Pen is TPenGdi) and (Pen as TPenGdi).HandleAvailable then
+ end
+ else if (Pen is TPenGdi) and (Pen as TPenGdi).HandleAvailable then
begin
W := Pen.Width;
Pen.Width := PenWidth(GetMatrix, W);
if Pen.Brush <> nil then
begin
- ApplyMatrix((Pen.Brush as TBrushGdi).FBrush, GetMatrix, State);
- FGraphics.DrawPath((Pen as TPenGdi).FPen, P.FData);
+ ApplyMatrix((Pen.Brush as TBrushGdi).FBrush, GetMatrix, State);
+ FGraphics.DrawPath((Pen as TPenGdi).FPen, P.FData);
RestoreMatrix((Pen.Brush as TBrushGdi).FBrush, State);
- end
+ end
else
- FGraphics.DrawPath((Pen as TPenGdi).FPen, P.FData);
+ FGraphics.DrawPath((Pen as TPenGdi).FPen, P.FData);
Pen.Width := W;
- end;
- if not Preserve then
+ end;
+ if not Preserve then
P.Remove;
end;
diff --git a/source/codebot/codebot.inc b/source/codebot/codebot.inc
new file mode 100644
index 0000000..c8a4d81
--- /dev/null
+++ b/source/codebot/codebot.inc
@@ -0,0 +1,40 @@
+{$mode delphi}
+{$modeswitch multihelpers}
+
+{$z4}
+{$macro on}
+
+{$WARN 3177 off : Some fields coming after "$1" were not initialized}
+{$WARN 5024 off : Parameter "$1" not used}
+{$WARN 5094 off : Function result variable of a managed type does not seem to be initialized}
+{$WARN 6058 off : Call to subroutine "$1" marked as inline is not inlined}
+{$WARN 6060 off : }
+
+{$ifdef linux}
+ {$define apicall := cdecl}
+ {$ifdef lclgtk2}
+ {$define platformok}
+ {$endif}
+ {$ifdef lclgtk3}
+ {$define platformok}
+ {$endif}
+{$endif}
+
+{$ifdef windows}
+ {$define apicall := stdcall}
+ {$ifdef lclwin32}
+ {$define platformok}
+ {$endif}
+{$endif}
+
+{$ifndef platformok}
+'This library requires windows win32, linux gtk2, or linux gtk3 widgetsets'
+{$endif}
+{$ifndef fpc}
+'This library requires the free pascal compiler'
+{$endif}
+{$if fpc_fullversion < 30000}
+'This library requires the free pascal 3 or greater'
+{$endif}
+
+
diff --git a/source/codebot.interop.linux.xml2.pas b/source/codebot/codebot.interop.linux.xml2.pas
similarity index 87%
rename from source/codebot.interop.linux.xml2.pas
rename to source/codebot/codebot.interop.linux.xml2.pas
index 817796e..6b2fe33 100644
--- a/source/codebot.interop.linux.xml2.pas
+++ b/source/codebot/codebot.interop.linux.xml2.pas
@@ -2,7 +2,7 @@
(* *)
(* Codebot Pascal Library *)
(* http://cross.codebot.org *)
-(* Modified November 2015 *)
+(* Modified August 2019 *)
(* *)
(********************************************************)
@@ -61,7 +61,6 @@ interface
xmlCharEncodingHandlerPtr = ^xmlCharEncodingHandler;
xmlDictPtr = Pointer;
xmlHashTablePtr = Pointer;
- xmlStructuredErrorFunc = Pointer;
xmlCharEncoding = (
XML_CHAR_ENCODING_ERROR = -1, (* No char encoding detected *)
@@ -100,11 +99,11 @@ xmlCharEncodingHandler = record
end;
(*
- * xmlBufferAllocationScheme:
- *
- * A buffer allocation scheme can be defined to either match exactly the
- * need or double it's allocated size each time it is found too small.
- *)
+ * xmlBufferAllocationScheme:
+ *
+ * A buffer allocation scheme can be defined to either match exactly the
+ * need or double it's allocated size each time it is found too small.
+ *)
xmlBufferAllocationScheme = (
XML_BUFFER_ALLOC_DOUBLEIT,
XML_BUFFER_ALLOC_EXACT,
@@ -112,10 +111,10 @@ xmlCharEncodingHandler = record
);
(*
- * xmlBuffer:
- *
- * A buffer structure.
- *)
+ * xmlBuffer:
+ *
+ * A buffer structure.
+ *)
xmlBuffer = record
content: xmlCharPtr; (* The buffer content UTF8 *)
use: cuint; (* The buffer size used *)
@@ -124,14 +123,14 @@ xmlBuffer = record
end;
(*
- * The different element types carried by an XML tree.
- *
- * NOTE: This is synchronized with DOM Level1 values
- * See http://www.w3.org/TR/REC-DOM-Level-1/
- *
- * Actually this had diverged a bit, and now XML_DOCUMENT_TYPE_NODE should
- * be deprecated to use an XML_DTD_NODE.
- *)
+ * The different element types carried by an XML tree.
+ *
+ * NOTE: This is synchronized with DOM Level1 values
+ * See http://www.w3.org/TR/REC-DOM-Level-1/
+ *
+ * Actually this had diverged a bit, and now XML_DOCUMENT_TYPE_NODE should
+ * be deprecated to use an XML_DTD_NODE.
+ *)
xmlElementType = (
XML_ELEMENT_NODE = 1,
XML_ATTRIBUTE_NODE = 2,
@@ -156,10 +155,10 @@ xmlBuffer = record
);
(*
- * xmlNotation:
- *
- * A DTD Notation definition.
- *)
+ * xmlNotation:
+ *
+ * A DTD Notation definition.
+ *)
xmlNotation = record
name: xmlCharPtr; (* Notation name *)
PublicID: xmlCharPtr; (* Public identifier, if any *)
@@ -167,10 +166,10 @@ xmlNotation = record
end;
(*
- * xmlAttributeType:
- *
- * A DTD Attribute type definition.
- *)
+ * xmlAttributeType:
+ *
+ * A DTD Attribute type definition.
+ *)
xmlAttributeType = (
XML_ATTRIBUTE_CDATA = 1,
XML_ATTRIBUTE_ID,
@@ -185,10 +184,10 @@ xmlNotation = record
);
(*
- * xmlAttributeDefault:
- *
- * A DTD Attribute default definition.
- *)
+ * xmlAttributeDefault:
+ *
+ * A DTD Attribute default definition.
+ *)
xmlAttributeDefault = (
XML_ATTRIBUTE_NONE = 1,
XML_ATTRIBUTE_REQUIRED,
@@ -197,20 +196,20 @@ xmlNotation = record
);
(*
- * xmlEnumeration:
- *
- * List structure used when there is an enumeration in DTDs.
- *)
+ * xmlEnumeration:
+ *
+ * List structure used when there is an enumeration in DTDs.
+ *)
xmlEnumeration = record
next: xmlEnumerationPtr; (* next one *)
name: xmlCharPtr;
end;
(*
- * xmlAttribute:
- *
- * An Attribute declaration in a DTD.
- *)
+ * xmlAttribute:
+ *
+ * An Attribute declaration in a DTD.
+ *)
xmlAttribute = record
_private: pointer; (* application data *)
_type: xmlElementType; (* XML_ATTRIBUTE_DECL, must be second ! *)
@@ -231,10 +230,10 @@ xmlAttribute = record
end;
(*
- * xmlElementContentType:
- *
- * Possible definitions of element content types.
- *)
+ * xmlElementContentType:
+ *
+ * Possible definitions of element content types.
+ *)
xmlElementContentType = (
XML_ELEMENT_CONTENT_PCDATA = 1,
XML_ELEMENT_CONTENT_ELEMENT,
@@ -243,10 +242,10 @@ xmlAttribute = record
);
(*
- * xmlElementContentOccur:
- *
- * Possible definitions of element content occurrences.
- *)
+ * xmlElementContentOccur:
+ *
+ * Possible definitions of element content occurrences.
+ *)
xmlElementContentOccur = (
XML_ELEMENT_CONTENT_ONCE = 1,
XML_ELEMENT_CONTENT_OPT,
@@ -255,11 +254,11 @@ xmlAttribute = record
);
(*
- * xmlElementContent:
- *
- * An XML Element content as stored after parsing an element definition
- * in a DTD.
- *)
+ * xmlElementContent:
+ *
+ * An XML Element content as stored after parsing an element definition
+ * in a DTD.
+ *)
xmlElementContent = record
_type: xmlElementContentType; (* PCDATA, ELEMENT, SEQ or OR *)
ocur: xmlElementContentOccur; (* ONCE, OPT, MULT or PLUS *)
@@ -271,10 +270,10 @@ xmlElementContent = record
end;
(*
- * xmlElementTypeVal:
- *
- * The different possibilities for an element content type.
- *)
+ * xmlElementTypeVal:
+ *
+ * The different possibilities for an element content type.
+ *)
xmlElementTypeVal = (
XML_ELEMENT_TYPE_UNDEFINED = 0,
XML_ELEMENT_TYPE_EMPTY = 1,
@@ -284,10 +283,10 @@ xmlElementContent = record
);
(*
- * xmlElement:
- *
- * An XML Element declaration from a DTD.
- *)
+ * xmlElement:
+ *
+ * An XML Element declaration from a DTD.
+ *)
xmlElement = record
_private: pointer; (* application data *)
_type: xmlElementType; (* XML_ELEMENT_DECL, must be second ! *)
@@ -308,14 +307,14 @@ xmlElement = record
xmlNsType = xmlElementType;
(*
- * xmlNs:
- *
- * An XML namespace.
- * Note that prefix == NULL is valid, it defines the default namespace
- * within the subtree (until overridden).
- *
- * xmlNsType is unified with xmlElementType.
- *)
+ * xmlNs:
+ *
+ * An XML namespace.
+ * Note that prefix == NULL is valid, it defines the default namespace
+ * within the subtree (until overridden).
+ *
+ * xmlNsType is unified with xmlElementType.
+ *)
xmlNs = record
next: xmlNsPtr; (* next Ns link for this node *)
_type: xmlNsType; (* global or local *)
@@ -326,11 +325,11 @@ xmlNs = record
end;
(*
- * xmlDtd:
- *
- * An XML DTD, as defined by }
+unit Codebot.Interop.OpenSSL;
+
+{$i codebot.inc}
+
+interface
+
+uses
+ Codebot.Core;
+
+const
+ 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;
+ SSL_ERROR_ZERO_RETURN = 6;
+ SSL_ERROR_WANT_CONNECT = 7;
+ SSL_ERROR_WANT_ACCEPT = 8;
+
+ SSL_CTRL_SET_TLSEXT_HOSTNAME = 55;
+ TLSEXT_NAMETYPE_host_name = 0;
+
+ SSL_FILETYPE_ASN1 = 2;
+ SSL_FILETYPE_PEM = 1;
+ EVP_PKEY_RSA = 6;
+
+ EVP_MAX_MD_SIZE = 64;
+ EVP_MAX_KEY_LENGTH = 64;
+ EVP_MAX_IV_LENGTH = 16;
+ EVP_MAX_BLOCK_LENGTH = 32;
+
+type
+ TSSLCtxPrivate = record end;
+ TSSLCtx = ^TSSLCtxPrivate;
+
+ TSSLPrivate = record end;
+ TSSL = ^TSSLPrivate;
+
+ TSSLMethodPrivate = record end;
+ TSSLMethod = ^TSSLMethodPrivate;
+
+ TEVPMethodPrivate = record end;
+ TEVPMethod = ^TEVPMethodPrivate;
+
+ TEVPMdCtxPrivate = record end;
+ TEVPMdCtx = ^TEVPMdCtxPrivate;
+
+ THMACCtxPrivate = record end;
+ THMACCtx = ^THMACCtxPrivate;
+
+ X509 = Pointer;
+ TX509 = X509;
+
+ EVP_PKEY = Pointer;
+ TEVPPKey = EVP_PKEY;
+
+ RSA = Pointer;
+ TRSA = RSA;
+
+{ OpenSSL routines }
+
+var
+ TLS_method: function: TSSLMethod; cdecl;
+ TLS_client_method: function: TSSLMethod; cdecl;
+ TLS_server_method: function: TSSLMethod; cdecl;
+ SSL_CTX_new: function(method: TSSLMethod): TSSLCtx; cdecl;
+ SSL_CTX_free: procedure(context: TSSLCtx); cdecl;
+ SSL_new: function(context: TSSLCtx): TSSL; cdecl;
+ SSL_shutdown: function(ssl: TSSL): LongInt; cdecl;
+ SSL_free: procedure(ssl: TSSL); cdecl;
+ SSL_ctrl: function(ssl: TSSL; cmd: Integer; arg: LongInt; param: Pointer): LongInt; cdecl;
+ SSL_set_fd: function(ssl: TSSL; socket: LongInt): LongInt; cdecl;
+ SSL_accept: function(ssl: TSSL): LongInt; cdecl;
+ SSL_connect: function(ssl: TSSL): LongInt; cdecl;
+ SSL_write: function(ssl: TSSL; buffer: Pointer; size: LongWord): LongInt; cdecl;
+ SSL_read: function(ssl: TSSL; buffer: Pointer; size: LongWord): LongInt; cdecl;
+ SSL_get_error: function(ssl: TSSL; ret_code: Integer): Integer; cdecl;
+ SSL_CTX_use_certificate: function(context: TSSLCtx; x: TX509): LongInt; cdecl;
+ SSL_CTX_use_certificate_ASN1: function(context: TSSLCtx; len: LongInt; data: PChar): LongInt; cdecl;
+ SSL_CTX_use_certificate_file: function(context: TSSLCtx; filename: PChar; kind: LongInt): LongInt; cdecl;
+ SSL_use_certificate: function(ssl: TSSL; x: TX509): LongInt; cdecl;
+ SSL_use_certificate_ASN1: function(ssl: TSSL; data: PChar; len: LongInt): LongInt; cdecl;
+ SSL_use_certificate_file: function(ssl: TSSL; filename: PChar; kind: LongInt): LongInt; cdecl;
+ SSL_CTX_use_certificate_chain_file: function(context: TSSLCtx; filename: PChar): LongInt; cdecl;
+ SSL_use_certificate_chain_file: function(ssl: TSSL; filename: PChar): LongInt; cdecl;
+ SSL_CTX_use_PrivateKey: function(context: TSSLCtx; key: TEVPPKey): LongInt; cdecl;
+ SSL_CTX_use_PrivateKey_ASN1: function(pk: LongInt; context: TSSLCtx; data: PChar; len: NativeInt): LongInt; cdecl;
+ SSL_CTX_use_PrivateKey_file: function(context: TSSLCtx; filename: PChar; kind: LongInt): LongInt; cdecl;
+ SSL_CTX_use_RSAPrivateKey: function(context: TSSLCtx; rsa: TRSA): LongInt; cdecl;
+ SSL_CTX_use_RSAPrivateKey_ASN1: function(context: TSSLCtx; data: PChar; len: NativeInt): LongInt; cdecl;
+ SSL_CTX_use_RSAPrivateKey_file: function(context: TSSLCtx; filename: PChar; kind: LongInt): LongInt; cdecl;
+ SSL_use_PrivateKey: function(ssl: TSSL; pkey: TEVPPKey): LongInt; cdecl;
+ SSL_use_PrivateKey_ASN1: function(pk: LongInt; ssl: TSSL; data: PChar; len: NativeInt): LongInt; cdecl;
+ SSL_use_PrivateKey_file: function(ssl: TSSL; filename: PChar; kind: LongInt): LongInt; cdecl;
+ SSL_use_RSAPrivateKey: function(ssl: TSSL; rsa: TRSA): LongInt; cdecl;
+ SSL_use_RSAPrivateKey_ASN1: function(ssl: TSSL; data: PChar; len: NativeInt): LongInt; cdecl;
+ SSL_use_RSAPrivateKey_file: function(ssl: TSSL; filename: PChar; kind: LongInt): LongInt; cdecl;
+ SSL_CTX_check_private_key: function(context: TSSLCtx): LongInt; cdecl;
+ SSL_check_private_key: function(ssl: TSSL): LongInt; cdecl;
+
+{ Hashing routines }
+
+ EVP_md5: function: TEVPMethod; cdecl;
+ EVP_sha1: function: TEVPMethod; cdecl;
+ EVP_sha256: function: TEVPMethod; cdecl;
+ EVP_sha512: function: TEVPMethod; cdecl;
+
+ EVP_MD_CTX_new: function: TEVPMdCtx; cdecl;
+ EVP_MD_CTX_reset: function(ctx: TEVPMdCtx): Integer; cdecl;
+ EVP_MD_CTX_free: procedure(ctx: TEVPMdCtx); cdecl;
+
+ EVP_DigestInit_ex: function(ctx: TEVPMdCtx; method: TEVPMethod; engine: Pointer = nil): LongBool; cdecl;
+ EVP_DigestUpdate: function(ctx: TEVPMdCtx; data: Pointer; dataLen: Cardinal): LongBool; cdecl;
+ EVP_DigestFinal: function(ctx: TEVPMdCtx; digest: Pointer; out digestLen: Cardinal): LongBool; cdecl;
+
+ HMAC_CTX_new: function: THMACCtx; cdecl;
+ HMAC_CTX_reset: function(ctx: THMACCtx): Integer; cdecl;
+ HMAC_CTX_free: procedure(ctx: THMACCtx); cdecl;
+
+ HMAC_Init_ex: function(ctx: THMACCtx; key: Pointer; keyLen: Cardinal; method: TEVPMethod;
+ engine: Pointer = nil): LongBool; cdecl;
+ HMAC_Update: function(ctx: THMACCtx; data: Pointer; dataLen: Cardinal): LongBool; cdecl;
+ HMAC_Final: function(ctx: THMACCtx; digest: Pointer; out digestLen: Cardinal): LongBool; cdecl;
+
+ HMAC: function(method: TEVPMethod; key: Pointer; keyLen: Cardinal; data: Pointer; dataLen: Cardinal;
+ digest: Pointer; out digestLen: Cardinal): Pointer; cdecl;
+
+const
+{$ifdef windows}
+ libssl = 'libssl32.dll';
+ libcrypto = 'libeay32.dll';
+{$endif}
+{$ifdef linux}
+ libssl = 'libssl.so.3';
+ libcrypto = 'libcrypto.so.3';
+{$endif}
+
+function InitSSL(ThrowExceptions: Boolean = False): Boolean;
+function InitCrypto(ThrowExceptions: Boolean = False): Boolean;
+
+implementation
+
+var
+ LoadedSSL: Boolean;
+ InitializedSSL: Boolean;
+ LoadedCrypto: Boolean;
+ InitializedCrypto: Boolean;
+
+function InitSSL(ThrowExceptions: Boolean = False): Boolean;
+var
+ FailedModuleName: string;
+ FailedProcName: string;
+ Module: HModule;
+
+ procedure CheckExceptions;
+ begin
+ if (not InitializedSSL) and (ThrowExceptions) then
+ LibraryExceptProc(FailedModuleName, FailedProcName);
+ end;
+
+ function TryLoad(const ProcName: string; var Proc: Pointer): Boolean;
+ begin
+ FailedProcName := ProcName;
+ Proc := LibraryGetProc(Module, ProcName);
+ Result := Proc <> nil;
+ if not Result then
+ begin
+ CheckExceptions;
+ end;
+ end;
+
+begin
+ ThrowExceptions := ThrowExceptions and (@LibraryGetProc <> nil);
+ if LoadedSSL then
+ begin
+ CheckExceptions;
+ Exit(InitializedSSL);
+ end;
+ LoadedSSL:= True;
+ if InitializedSSL then
+ Exit(True);
+ Result := False;
+ FailedModuleName := libssl;
+ FailedProcName := '';
+ Module := LibraryLoad(libssl);
+ if Module = ModuleNil then
+ begin
+ CheckExceptions;
+ Exit;
+ end;
+ Result :=
+ TryLoad('TLS_method', @TLS_method) and
+ TryLoad('TLS_client_method', @TLS_client_method) and
+ TryLoad('TLS_server_method', @TLS_server_method) and
+ TryLoad('SSL_CTX_new', @SSL_CTX_new) and
+ TryLoad('SSL_CTX_free', @SSL_CTX_free) and
+ TryLoad('SSL_new', @SSL_new) and
+ TryLoad('SSL_shutdown', @SSL_shutdown) and
+ TryLoad('SSL_free', @SSL_free) and
+ TryLoad('SSL_ctrl', @SSL_ctrl) and
+ TryLoad('SSL_set_fd', @SSL_set_fd) and
+ TryLoad('SSL_accept', @SSL_accept) and
+ TryLoad('SSL_connect', @SSL_connect) and
+ TryLoad('SSL_write', @SSL_write) and
+ TryLoad('SSL_read', @SSL_read) and
+ TryLoad('SSL_get_error', @SSL_get_error) and
+ TryLoad('SSL_CTX_use_certificate', @SSL_CTX_use_certificate) and
+ TryLoad('SSL_CTX_use_certificate_ASN1', @SSL_CTX_use_certificate_ASN1) and
+ TryLoad('SSL_CTX_use_certificate_file', @SSL_CTX_use_certificate_file) and
+ TryLoad('SSL_use_certificate', @SSL_use_certificate) and
+ TryLoad('SSL_use_certificate_ASN1', @SSL_use_certificate_ASN1) and
+ TryLoad('SSL_use_certificate_file', @SSL_use_certificate_file) and
+ TryLoad('SSL_CTX_use_certificate_chain_file', @SSL_CTX_use_certificate_chain_file) and
+ TryLoad('SSL_CTX_use_PrivateKey', @SSL_CTX_use_PrivateKey) and
+ TryLoad('SSL_CTX_use_PrivateKey_ASN1', @SSL_CTX_use_PrivateKey_ASN1) and
+ TryLoad('SSL_CTX_use_PrivateKey_file', @SSL_CTX_use_PrivateKey_file) and
+ TryLoad('SSL_CTX_use_RSAPrivateKey', @SSL_CTX_use_RSAPrivateKey) and
+ TryLoad('SSL_CTX_use_RSAPrivateKey_ASN1', @SSL_CTX_use_RSAPrivateKey_ASN1) and
+ TryLoad('SSL_CTX_use_RSAPrivateKey_file', @SSL_CTX_use_RSAPrivateKey_file) and
+ TryLoad('SSL_use_PrivateKey', @SSL_use_PrivateKey) and
+ TryLoad('SSL_use_PrivateKey_ASN1', @SSL_use_PrivateKey_ASN1) and
+ TryLoad('SSL_use_PrivateKey_file', @SSL_use_PrivateKey_file) and
+ TryLoad('SSL_use_RSAPrivateKey', @SSL_use_RSAPrivateKey) and
+ TryLoad('SSL_use_RSAPrivateKey_ASN1', @SSL_use_RSAPrivateKey_ASN1) and
+ TryLoad('SSL_use_RSAPrivateKey_file', @SSL_use_RSAPrivateKey_file) and
+ TryLoad('SSL_CTX_check_private_key', @SSL_CTX_check_private_key) and
+ TryLoad('SSL_check_private_key', @SSL_check_private_key);
+ InitializedSSL := Result;
+end;
+
+function InitCrypto(ThrowExceptions: Boolean = False): Boolean;
+var
+ FailedModuleName: string;
+ FailedProcName: string;
+ Module: HModule;
+
+ procedure CheckExceptions;
+ begin
+ if (not InitializedCrypto) and (ThrowExceptions) then
+ LibraryExceptProc(FailedModuleName, FailedProcName);
+ end;
+
+ function TryLoad(const ProcName: string; var Proc: Pointer): Boolean;
+ begin
+ FailedProcName := ProcName;
+ Proc := LibraryGetProc(Module, ProcName);
+ Result := Proc <> nil;
+ if not Result then
+ begin
+ CheckExceptions;
+ end;
+ end;
+
+begin
+ ThrowExceptions := ThrowExceptions and (@LibraryGetProc <> nil);
+ if LoadedCrypto then
+ begin
+ CheckExceptions;
+ Exit(InitializedCrypto);
+ end;
+ LoadedCrypto:= True;
+ if InitializedCrypto then
+ Exit(True);
+ Result := False;
+ FailedModuleName := libcrypto;
+ FailedProcName := '';
+ Module := LibraryLoad(FailedModuleName);
+ if Module = ModuleNil then
+ begin
+ CheckExceptions;
+ Exit;
+ end;
+ Result :=
+ TryLoad('EVP_md5', @EVP_md5) and
+ TryLoad('EVP_sha1', @EVP_sha1) and
+ TryLoad('EVP_sha256', @EVP_sha256) and
+ TryLoad('EVP_sha512', @EVP_sha512) and
+ TryLoad('EVP_MD_CTX_new', @EVP_MD_CTX_new) and
+ TryLoad('EVP_MD_CTX_reset', @EVP_MD_CTX_reset) and
+ TryLoad('EVP_MD_CTX_free', @EVP_MD_CTX_free) and
+ TryLoad('EVP_DigestInit_ex', @EVP_DigestInit_ex) and
+ TryLoad('EVP_DigestUpdate', @EVP_DigestUpdate) and
+ TryLoad('EVP_DigestFinal', @EVP_DigestFinal) and
+ TryLoad('HMAC_CTX_new', @HMAC_CTX_new) and
+ TryLoad('HMAC_CTX_reset', @HMAC_CTX_reset) and
+ TryLoad('HMAC_CTX_free', @HMAC_CTX_free) and
+ TryLoad('HMAC_Init_ex', @HMAC_Init_ex) and
+ TryLoad('HMAC_Update', @HMAC_Update) and
+ TryLoad('HMAC_Final', @HMAC_Final) and
+ TryLoad('HMAC', @HMAC);
+ InitializedCrypto := Result;
+end;
+
+end.
diff --git a/source/codebot.interop.sockets.pas b/source/codebot/codebot.interop.sockets.pas
similarity index 97%
rename from source/codebot.interop.sockets.pas
rename to source/codebot/codebot.interop.sockets.pas
index ac945a3..66eb559 100644
--- a/source/codebot.interop.sockets.pas
+++ b/source/codebot/codebot.interop.sockets.pas
@@ -2,7 +2,7 @@
(* *)
(* Codebot Pascal Library *)
(* http://cross.codebot.org *)
-(* Modified September 2013 *)
+(* Modified August 2019 *)
(* *)
(********************************************************)
@@ -67,19 +67,29 @@ TInAddr = record
PSockAddrIn = ^TSockAddrIn;
TSockAddrIn = packed record
case LongInt of
- 0: (
+ 0: (
sin_family: Word;
sin_port: Word;
sin_addr: TInAddr;
sin_zero: array[0..7] of AnsiChar);
1: (
sa_family: Word;
- sa_data: array[0..13] of AnsiChar)
+ sa_data: array[0..13] of AnsiChar);
end;
PSockAddr = ^TSockAddr;
TSockAddr = TSockAddrIn;
+ {$ifdef unix}
+ TUnixAddrIn = packed record
+ family: Word;
+ path: array[0..107] of AnsiChar;
+ end;
+
+ PUnixAddr = ^TUnixAddr;
+ TUnixAddr = TUnixAddrIn;
+ {$endif}
+
PHostEnt = ^THostEnt;
THostEnt = record
h_name: PAnsiChar;
@@ -301,8 +311,8 @@ TProtoEnt = record
type
PSockProto = ^TSockProto;
TSockProto = record
- sp_family: Word;
- sp_protocol: Word;
+ sp_family: Word;
+ sp_protocol: Word;
end;
const
@@ -478,7 +488,7 @@ function fcntl(s: TSocketHandle; cmd, arg: LongInt): LongInt; apicall; libsocket
function socket(af, struct, protocol: LongInt): TSocketHandle; apicall; libsocket;
function shutdown(s: TSocketHandle; how: LongInt): LongInt; apicall; libsocket;
-function connect(s: TSocketHandle; addr: PSockAddr; namelen: LongInt): TSocketHandle; apicall; libsocket;
+function connect(s: TSocketHandle; addr: PSockAddr; namelen: LongInt): TSocketHandle; apicall; libsocket; overload;
function bind(s: TSocketHandle; addr: PSockAddr; namelen: LongInt): LongInt; apicall; libsocket;
function listen(s: TSocketHandle; backlog: LongInt): LongInt; apicall; libsocket;
function accept(s: TSocketHandle; addr: PSockAddr; var addrlen: LongInt): TSocketHandle; apicall; libsocket;
diff --git a/source/codebot.interop.windows.direct2d.pas b/source/codebot/codebot.interop.windows.direct2d.pas
similarity index 99%
rename from source/codebot.interop.windows.direct2d.pas
rename to source/codebot/codebot.interop.windows.direct2d.pas
index de90269..0e9d1a3 100644
--- a/source/codebot.interop.windows.direct2d.pas
+++ b/source/codebot/codebot.interop.windows.direct2d.pas
@@ -14,6 +14,8 @@
interface
{$ifdef windows}
+{$WARN 3057 off : An inherited method is hidden by "$1"}
+
uses
Windows,
Codebot.Core,
diff --git a/source/codebot.interop.windows.gdiplus.pas b/source/codebot/codebot.interop.windows.gdiplus.pas
similarity index 99%
rename from source/codebot.interop.windows.gdiplus.pas
rename to source/codebot/codebot.interop.windows.gdiplus.pas
index 8e88e3e..957cdf1 100644
--- a/source/codebot.interop.windows.gdiplus.pas
+++ b/source/codebot/codebot.interop.windows.gdiplus.pas
@@ -3122,7 +3122,7 @@ function BitmapResize(Bitmap: TFastBitmap; Width, Height: Integer; Quality: Inte
EmptyBitmap: TFastBitmap = ();
const
Formats: array[Boolean] of DWORD =
- (PixelFormat24bppRGB, PixelFormat32bppARGB);
+ (PixelFormat24bppRGB, PixelFormat32bppARGB);
var
B: TFastBitmap;
G: IGdiGraphics;
@@ -7048,7 +7048,7 @@ function TGdiBrush.GetType: TBrushType;
function TGdiBrush.GetTransform: IGdiMatrix;
begin
- Result := TGdiMatrix.Create;
+ Result := TGdiMatrix.Create;
end;
procedure TGdiBrush.SetTransform(Value: IGdiMatrix);
@@ -7058,27 +7058,27 @@ procedure TGdiBrush.SetTransform(Value: IGdiMatrix);
function TGdiBrush.ResetTransform: TStatus;
begin
- Result := Ok;
+ Result := Ok;
end;
function TGdiBrush.MultiplyTransform(Matrix: IGdiMatrix; Order: TGdiMatrixOrder = MatrixOrderPrepend): TStatus;
begin
- Result := Ok;
+ Result := Ok;
end;
function TGdiBrush.TranslateTransform(DX, DY: Single; Order: TGdiMatrixOrder = MatrixOrderPrepend): TStatus;
begin
- Result := Ok;
+ Result := Ok;
end;
function TGdiBrush.ScaleTransform(SX, SY: Single; Order: TGdiMatrixOrder = MatrixOrderPrepend): TStatus;
begin
- Result := Ok;
+ Result := Ok;
end;
function TGdiBrush.RotateTransform(Angle: Single; Order: TGdiMatrixOrder = MatrixOrderPrepend): TStatus;
begin
- Result := Ok;
+ Result := Ok;
end;
{ TGdiSolidBrush }
@@ -11903,7 +11903,7 @@ function NewGdiCheckerBrush(C1, C2: TGdiArgb; Size: Integer): IGdiTextureBrush;
F: IGdiSolidBrush;
R: TGdiRectF;
begin
- B := TGdiBitmap.Create(Size * 2, Size * 2);
+ B := TGdiBitmap.Create(Integer(Size * 2), Integer(Size * 2));
G := TGdiGraphics.Create(B);
F := TGdiSolidBrush.Create(C1);
R.X := 0;
diff --git a/source/codebot.interop.windows.imagecodecs.pas b/source/codebot/codebot.interop.windows.imagecodecs.pas
similarity index 100%
rename from source/codebot.interop.windows.imagecodecs.pas
rename to source/codebot/codebot.interop.windows.imagecodecs.pas
diff --git a/source/codebot.interop.windows.msxml.pas b/source/codebot/codebot.interop.windows.msxml.pas
similarity index 94%
rename from source/codebot.interop.windows.msxml.pas
rename to source/codebot/codebot.interop.windows.msxml.pas
index 653efb5..eba8f77 100644
--- a/source/codebot.interop.windows.msxml.pas
+++ b/source/codebot/codebot.interop.windows.msxml.pas
@@ -2,7 +2,7 @@
(* *)
(* Codebot Pascal Library *)
(* http://cross.codebot.org *)
-(* Modified September 2013 *)
+(* Modified August 2019 *)
(* *)
(********************************************************)
@@ -440,9 +440,9 @@ interface
function formatIndex(lIndex: Integer; const bstrFormat: WideString): WideString; safecall;
function formatNumber(dblNumber: Double; const bstrFormat: WideString): WideString; safecall;
function formatDate(varDate: OleVariant; const bstrFormat: WideString;
- varDestLocale: OleVariant): WideString; safecall;
+ varDestLocale: OleVariant): WideString; safecall;
function formatTime(varTime: OleVariant; const bstrFormat: WideString;
- varDestLocale: OleVariant): WideString; safecall;
+ varDestLocale: OleVariant): WideString; safecall;
end;
IXSLTemplate = interface(IDispatch)
@@ -467,7 +467,7 @@ interface
procedure reset; safecall;
function Get_readyState: Integer; safecall;
procedure addParameter(const baseName: WideString; parameter: OleVariant;
- const namespaceURI: WideString); safecall;
+ const namespaceURI: WideString); safecall;
procedure addObject(const obj: IDispatch; const namespaceURI: WideString); safecall;
function Get_stylesheet: IXMLDOMNode; safecall;
property input: OleVariant read Get_input write Set_input;
@@ -513,14 +513,14 @@ interface
function startDocument: HResult; stdcall;
function endDocument: HResult; stdcall;
function startPrefixMapping(var pwchPrefix: Word; cchPrefix: SYSINT; var pwchUri: Word;
- cchUri: SYSINT): HResult; stdcall;
+ cchUri: SYSINT): HResult; stdcall;
function endPrefixMapping(var pwchPrefix: Word; cchPrefix: SYSINT): HResult; stdcall;
function startElement(var pwchNamespaceUri: Word; cchNamespaceUri: SYSINT;
- var pwchLocalName: Word; cchLocalName: SYSINT; var pwchQName: Word;
- cchQName: SYSINT; const pAttributes: ISAXAttributes): HResult; stdcall;
+ var pwchLocalName: Word; cchLocalName: SYSINT; var pwchQName: Word;
+ cchQName: SYSINT; const pAttributes: ISAXAttributes): HResult; stdcall;
function endElement(var pwchNamespaceUri: Word; cchNamespaceUri: SYSINT;
- var pwchLocalName: Word; cchLocalName: SYSINT; var pwchQName: Word;
- cchQName: SYSINT): HResult; stdcall;
+ var pwchLocalName: Word; cchLocalName: SYSINT; var pwchQName: Word;
+ cchQName: SYSINT): HResult; stdcall;
function characters(var pwchChars: Word; cchChars: SYSINT): HResult; stdcall;
function ignorableWhitespace(var pwchChars: Word; cchChars: SYSINT): HResult; stdcall;
function processingInstruction(var pwchTarget: Word; cchTarget: SYSINT; var pwchData: Word;
@@ -546,16 +546,16 @@ interface
out ppwchLocalName: PWord1; out pcchLocalName: SYSINT;
out ppwchQName: PWord1; out pcchQName: SYSINT): HResult; stdcall;
function getIndexFromName(var pwchUri: Word; cchUri: SYSINT; var pwchLocalName: Word;
- cchLocalName: SYSINT; out pnIndex: SYSINT): HResult; stdcall;
+ cchLocalName: SYSINT; out pnIndex: SYSINT): HResult; stdcall;
function getIndexFromQName(var pwchQName: Word; cchQName: SYSINT; out pnIndex: SYSINT): HResult; stdcall;
function getType(nIndex: SYSINT; out ppwchType: PWord1; out pcchType: SYSINT): HResult; stdcall;
function getTypeFromName(var pwchUri: Word; cchUri: SYSINT; var pwchLocalName: Word;
cchLocalName: SYSINT; out ppwchType: PWord1; out pcchType: SYSINT): HResult; stdcall;
function getTypeFromQName(var pwchQName: Word; cchQName: SYSINT; out ppwchType: PWord1;
- out pcchType: SYSINT): HResult; stdcall;
+ out pcchType: SYSINT): HResult; stdcall;
function getValue(nIndex: SYSINT; out ppwchValue: PWord1; out pcchValue: SYSINT): HResult; stdcall;
function getValueFromName(var pwchUri: Word; cchUri: SYSINT; var pwchLocalName: Word;
- cchLocalName: SYSINT; out ppwchValue: PWord1; out pcchValue: SYSINT): HResult; stdcall;
+ cchLocalName: SYSINT; out ppwchValue: PWord1; out pcchValue: SYSINT): HResult; stdcall;
function getValueFromQName(var pwchQName: Word; cchQName: SYSINT; out ppwchValue: PWord1;
out pcchValue: SYSINT): HResult; stdcall;
end;
@@ -563,19 +563,19 @@ interface
ISAXDTDHandler = interface(IUnknown)
['{E15C1BAF-AFB3-4D60-8C36-19A8C45DEFED}']
function notationDecl(var pwchName: Word; cchName: SYSINT; var pwchPublicId: Word;
- cchPublicId: SYSINT; var pwchSystemId: Word; cchSystemId: SYSINT): HResult; stdcall;
+ cchPublicId: SYSINT; var pwchSystemId: Word; cchSystemId: SYSINT): HResult; stdcall;
function unparsedEntityDecl(var pwchName: Word; cchName: SYSINT; var pwchPublicId: Word;
- cchPublicId: SYSINT; var pwchSystemId: Word; cchSystemId: SYSINT;
- var pwchNotationName: Word; cchNotationName: SYSINT): HResult; stdcall;
+ cchPublicId: SYSINT; var pwchSystemId: Word; cchSystemId: SYSINT;
+ var pwchNotationName: Word; cchNotationName: SYSINT): HResult; stdcall;
end;
ISAXErrorHandler = interface(IUnknown)
['{A60511C4-CCF5-479E-98A3-DC8DC545B7D0}']
function error(const pLocator: ISAXLocator; var pwchErrorMessage: Word; hrErrorCode: HResult): HResult; stdcall;
function fatalError(const pLocator: ISAXLocator; var pwchErrorMessage: Word;
- hrErrorCode: HResult): HResult; stdcall;
+ hrErrorCode: HResult): HResult; stdcall;
function ignorableWarning(const pLocator: ISAXLocator; var pwchErrorMessage: Word;
- hrErrorCode: HResult): HResult; stdcall;
+ hrErrorCode: HResult): HResult; stdcall;
end;
ISAXXMLFilter = interface(ISAXXMLReader)
@@ -587,7 +587,7 @@ interface
ISAXLexicalHandler = interface(IUnknown)
['{7F85D5F5-47A8-4497-BDA5-84BA04819EA6}']
function startDTD(var pwchName: Word; cchName: SYSINT; var pwchPublicId: Word;
- cchPublicId: SYSINT; var pwchSystemId: Word; cchSystemId: SYSINT): HResult; stdcall;
+ cchPublicId: SYSINT; var pwchSystemId: Word; cchSystemId: SYSINT): HResult; stdcall;
function endDTD: HResult; stdcall;
function startEntity(var pwchName: Word; cchName: SYSINT): HResult; stdcall;
function endEntity(var pwchName: Word; cchName: SYSINT): HResult; stdcall;
@@ -604,9 +604,9 @@ interface
var pwchType: Word; cchType: SYSINT; var pwchValueDefault: Word;
cchValueDefault: SYSINT; var pwchValue: Word; cchValue: SYSINT): HResult; stdcall;
function internalEntityDecl(var pwchName: Word; cchName: SYSINT; var pwchValue: Word;
- cchValue: SYSINT): HResult; stdcall;
+ cchValue: SYSINT): HResult; stdcall;
function externalEntityDecl(var pwchName: Word; cchName: SYSINT; var pwchPublicId: Word;
- cchPublicId: SYSINT; var pwchSystemId: Word; cchSystemId: SYSINT): HResult; stdcall;
+ cchPublicId: SYSINT; var pwchSystemId: Word; cchSystemId: SYSINT): HResult; stdcall;
end;
IVBSAXXMLReader = interface(IDispatch)
@@ -650,9 +650,9 @@ interface
procedure startPrefixMapping(var strPrefix: WideString; var strURI: WideString); safecall;
procedure endPrefixMapping(var strPrefix: WideString); safecall;
procedure startElement(var strNamespaceURI: WideString; var strLocalName: WideString;
- var strQName: WideString; const oAttributes: IVBSAXAttributes); safecall;
+ var strQName: WideString; const oAttributes: IVBSAXAttributes); safecall;
procedure endElement(var strNamespaceURI: WideString; var strLocalName: WideString;
- var strQName: WideString); safecall;
+ var strQName: WideString); safecall;
procedure characters(var strChars: WideString); safecall;
procedure ignorableWhitespace(var strChars: WideString); safecall;
procedure processingInstruction(var strTarget: WideString; var strData: WideString); safecall;
@@ -692,9 +692,9 @@ interface
IVBSAXDTDHandler = interface(IDispatch)
['{24FB3297-302D-4620-BA39-3A732D850558}']
procedure notationDecl(var strName: WideString; var strPublicId: WideString;
- var strSystemId: WideString); safecall;
+ var strSystemId: WideString); safecall;
procedure unparsedEntityDecl(var strName: WideString; var strPublicId: WideString;
- var strSystemId: WideString; var strNotationName: WideString); safecall;
+ var strSystemId: WideString; var strNotationName: WideString); safecall;
end;
IVBSAXErrorHandler = interface(IDispatch)
@@ -702,9 +702,9 @@ interface
procedure error(const oLocator: IVBSAXLocator; var strErrorMessage: WideString;
nErrorCode: Integer); safecall;
procedure fatalError(const oLocator: IVBSAXLocator; var strErrorMessage: WideString;
- nErrorCode: Integer); safecall;
+ nErrorCode: Integer); safecall;
procedure ignorableWarning(const oLocator: IVBSAXLocator; var strErrorMessage: WideString;
- nErrorCode: Integer); safecall;
+ nErrorCode: Integer); safecall;
end;
IVBSAXXMLFilter = interface(IDispatch)
@@ -717,7 +717,7 @@ interface
IVBSAXLexicalHandler = interface(IDispatch)
['{032AAC35-8C0E-4D9D-979F-E3B702935576}']
procedure startDTD(var strName: WideString; var strPublicId: WideString;
- var strSystemId: WideString); safecall;
+ var strSystemId: WideString); safecall;
procedure endDTD; safecall;
procedure startEntity(var strName: WideString); safecall;
procedure endEntity(var strName: WideString); safecall;
@@ -734,7 +734,7 @@ interface
var strValue: WideString); safecall;
procedure internalEntityDecl(var strName: WideString; var strValue: WideString); safecall;
procedure externalEntityDecl(var strName: WideString; var strPublicId: WideString;
- var strSystemId: WideString); safecall;
+ var strSystemId: WideString); safecall;
end;
IMXWriter = interface(IDispatch)
@@ -769,14 +769,14 @@ interface
IMXAttributes = interface(IDispatch)
['{F10D27CC-3EC0-415C-8ED8-77AB1C5E7262}']
procedure addAttribute(const strURI: WideString; const strLocalName: WideString;
- const strQName: WideString; const strType: WideString;
- const strValue: WideString); safecall;
+ const strQName: WideString; const strType: WideString;
+ const strValue: WideString); safecall;
procedure addAttributeFromIndex(varAtts: OleVariant; nIndex: SYSINT); safecall;
procedure clear; safecall;
procedure removeAttribute(nIndex: SYSINT); safecall;
procedure setAttribute(nIndex: SYSINT; const strURI: WideString;
- const strLocalName: WideString; const strQName: WideString;
- const strType: WideString; const strValue: WideString); safecall;
+ const strLocalName: WideString; const strQName: WideString;
+ const strType: WideString; const strValue: WideString); safecall;
procedure setAttributes(varAtts: OleVariant); safecall;
procedure setLocalName(nIndex: SYSINT; const strLocalName: WideString); safecall;
procedure setQName(nIndex: SYSINT; const strQName: WideString); safecall;
@@ -940,7 +940,7 @@ interface
IXMLHTTPRequest = interface(IDispatch)
['{ED8C108D-4349-11D2-91A4-00C04F7969E8}']
procedure open(const bstrMethod: WideString; const bstrUrl: WideString; varAsync: OleVariant;
- bstrUser: OleVariant; bstrPassword: OleVariant); safecall;
+ bstrUser: OleVariant; bstrPassword: OleVariant); safecall;
procedure setRequestHeader(const bstrHeader: WideString; const bstrValue: WideString); safecall;
function getResponseHeader(const bstrHeader: WideString): WideString; safecall;
function getAllResponseHeaders: WideString; safecall;
diff --git a/source/codebot/codebot.io.serialport.pas b/source/codebot/codebot.io.serialport.pas
new file mode 100644
index 0000000..a250b72
--- /dev/null
+++ b/source/codebot/codebot.io.serialport.pas
@@ -0,0 +1,529 @@
+(********************************************************)
+(* *)
+(* Codebot Pascal Library *)
+(* http://cross.codebot.org *)
+(* Modified June 2022 *)
+(* *)
+(********************************************************)
+
+{ }
+unit Codebot.IO.SerialPort;
+
+{$i codebot.inc}
+
+interface
+
+{$ifdef linux}
+uses
+ SysUtils, Classes, TypInfo;
+
+const
+ Baud300 = 300;
+ Baud1200 = 1200;
+ Baud2400 = 2400;
+ Baud4800 = 4800;
+ Baud9600 = 9600;
+ Baud19200 = 19200;
+ Baud38400 = 38400;
+ Baud57600 = 57600;
+ Baud115200 = 115200;
+ Baud230400 = 230400;
+
+ Bits5 = 5;
+ Bits6 = 6;
+ Bits7 = 7;
+ Bits8 = 8;
+
+type
+ TParity = (prNone, prOdd, prEven);
+ TStopBits = (sbOne, sbTwo);
+ TFlowControl = set of (fcXOn, fcXOff, fcRequestToSend);
+
+{ TSerialPortOptions }
+
+ TSerialPortOptions = record
+ public
+ Baud: Integer;
+ DataBits: Integer;
+ Parity: TParity;
+ StopBits: TStopBits;
+ FlowControl: TFlowControl;
+ Min: Byte;
+ Timeout: Byte;
+ class function Create(const Device: string): TSerialPortOptions; overload; static;
+ class function Create(Baud: Integer = Baud9600; DataBits: Integer = Bits8;
+ Parity: TParity = prNone): TSerialPortOptions; overload; static;
+ function ToString: string;
+ end;
+
+{ TSerialPort }
+
+ TSerialPort = class
+ private
+ FDevice: string;
+ FHandle: THandle;
+ FReadBuffer: array[0..1023] of Byte;
+ function UpdatePort(const Options: TSerialPortOptions): Boolean;
+ procedure CheckOpened;
+ function GetOpened: Boolean;
+ public
+ constructor Create(const Device: string);
+ destructor Destroy; override;
+ function Open: Boolean; overload;
+ function Open(const Options: TSerialPortOptions): Boolean; overload;
+ procedure Close;
+ function Read: string;
+ function ReadBinary(var Buffer; BufferSize: Integer): Integer;
+ procedure Write(const S: string);
+ procedure WriteBinary(var Buffer; BufferSize: Integer);
+ procedure XOn;
+ procedure XOff;
+ property Opened: Boolean read GetOpened;
+ property Device: string read FDevice;
+ end;
+
+procedure EnumSerialPorts(Ports: TStrings);
+{$endif}
+
+implementation
+
+{$ifdef linux}
+const
+ O_RDWR = $02;
+ O_NOCTTY = $100;
+ TCSANOW = $00;
+ CBAUD = 4111;
+ CBAUDEX = 4096;
+
+ B300 = 7;
+ B1200 = 9;
+ B2400 = 11;
+ B4800 = 12;
+ B9600 = 13;
+ B19200 = 14;
+ B38400 = 15;
+ B57600 = 4097;
+ B115200 = 4098;
+ B230400 = 4099;
+
+ CS5 = 0;
+ CS6 = 16;
+ CS7 = 32;
+ CS8 = 48;
+
+ CSTOPB = 64;
+
+ PARENB = 256;
+ PARODD = 512;
+
+ CLOCAL = 2048;
+ CREAD = 128;
+ CSIZE = 48;
+ ECHO = 8;
+ ECHOE = 16;
+ ECHOK = 32;
+ ECHONL = 64;
+ ICANON = 2;
+ ICRNL = 256;
+ IEXTEN = 32768;
+ IGNBRK = 1;
+ IGNCR = 128;
+ INLCR = 64;
+ INPCK = 16;
+ ISIG = 1;
+ ISTRIP = 32;
+ OCRNL = 8;
+ ONLCR = 4;
+ OPOST = 1;
+ IXON = 1024;
+ IXOFF = 4096;
+ CRTSCTS = 2147483648;
+
+ VTIME = 5;
+ VMIN = 6;
+
+ { TCIFLUSH = 0; TCOFLUSH = 1;}
+ TCIOFLUSH = 2;
+
+type
+ termios = record
+ c_iflag: LongWord;
+ c_oflag: LongWord;
+ c_cflag: LongWord;
+ c_lflag: LongWord;
+ c_line: Byte;
+ c_cc: array[0..34] of Byte;
+ c_ispeed: LongWord;
+ c_ospeed: LongWord;
+ end;
+ TTermios = termios;
+
+{$ifdef unix}
+const
+ libc = 'c';
+
+function _open(path: PChar; flags: Integer): Integer; cdecl; external libc name 'open';
+function _close(fd: THandle): Integer; cdecl; external libc name 'close';
+function _write(fd: THandle; var buffer; numBytes: Integer): Integer; cdecl; external libc name 'write';
+function _read(fd: THandle; var buffer; numBytes: Integer): Integer; cdecl; external libc name 'read';
+function _ioctl(fd: THandle; request: DWord; value: Integer): Integer; cdecl; external libc name 'ioctl';
+function _tcgetattr(fd: THandle; out term: TTermios): Integer; cdecl; external libc name 'tcgetattr';
+function _tcsetattr(fd: THandle; actions: Integer; var term: TTermios): Integer; cdecl; external libc name 'tcsetattr';
+function _tcflush(fd: THandle; queue: Integer): Integer; cdecl; external libc name 'tcflush';
+{$else}
+function _open(path: PChar; flags: Integer): Integer;
+begin
+ Result := 0;
+end;
+function _close(fd: THandle): Integer;
+begin
+ Result := 0;
+end;
+function _write(fd: THandle; var buffer; numBytes: Integer): Integer;
+begin
+ Result := 0;
+end;
+function _read(fd: THandle; var buffer; numBytes: Integer): Integer;
+begin
+ Result := 0;
+end;
+function _ioctl(fd: THandle; request: DWord; value: Integer): Integer;
+begin
+ Result := 0;
+end;
+
+function _tcgetattr(fd: THandle; out term: TTermios): Integer;
+begin
+ Result := 0;
+end;
+
+function _tcsetattr(fd: THandle; actions: Integer; var term: TTermios): Integer;
+begin
+ Result := 0;
+end;
+{$endif}
+
+{ TSerialPortOptions }
+
+class function TSerialPortOptions.Create(const Device: string): TSerialPortOptions;
+var
+ F: THandle;
+ T: TTermios;
+begin
+ FillChar(Result{%H-}, SizeOf(Result), 0);
+ if not FileExists(Device) then
+ Exit;
+ F := _open(PChar(Device), O_RDWR or O_NOCTTY);
+ if F > 0 then
+ try
+ if _tcgetattr(F, T) = 0 then
+ begin
+ if (T.c_cflag and B230400) = B230400 then
+ Result.Baud := Baud230400
+ else if (T.c_cflag and B115200) = B115200 then
+ Result.Baud := Baud115200
+ else if (T.c_cflag and B57600) = B57600 then
+ Result.Baud := Baud57600
+ else if (T.c_cflag and B38400) = B38400 then
+ Result.Baud := Baud38400
+ else if (T.c_cflag and B19200) = B19200 then
+ Result.Baud := Baud19200
+ else if (T.c_cflag and B9600) = B9600 then
+ Result.Baud := Baud9600
+ else if (T.c_cflag and B4800) = B4800 then
+ Result.Baud := Baud4800
+ else if (T.c_cflag and B2400) = B2400 then
+ Result.Baud := Baud2400
+ else if (T.c_cflag and B1200) = B1200 then
+ Result.Baud := Baud1200
+ else if (T.c_cflag and B300) = B300 then
+ Result.Baud := Baud300
+ else
+ Exit;
+ if (T.c_cflag and CS8) = CS8 then
+ Result.DataBits := Bits8
+ else if (T.c_cflag and CS7) = CS7 then
+ Result.DataBits := Bits7
+ else if (T.c_cflag and CS6) = CS6 then
+ Result.DataBits := Bits6
+ else
+ Result.DataBits := Bits5;
+ if (T.c_cflag and (PARENB or PARODD)) = PARENB or PARODD then
+ Result.Parity := prOdd
+ else if (T.c_cflag and PARENB) = PARENB then
+ Result.Parity := prEven
+ else
+ Result.Parity := prNone;
+ if (T.c_cflag and CSTOPB) = CSTOPB then
+ Result.StopBits := sbTwo
+ else
+ Result.StopBits := sbOne;
+ if (T.c_iflag and IXON) = IXON then
+ Include(Result.FlowControl, fcXOn);
+ if (T.c_iflag and IXOFF) = IXOFF then
+ Include(Result.FlowControl, fcXOff);
+ if (T.c_iflag and CRTSCTS) = CRTSCTS then
+ Include(Result.FlowControl, fcRequestToSend);
+ Result.Timeout := T.c_cc[VTIME] ;
+ Result.Min := T.c_cc[VMIN];
+ end;
+ finally
+ _close(F);
+ end;
+end;
+
+class function TSerialPortOptions.Create(Baud: Integer; DataBits: Integer;
+ Parity: TParity): TSerialPortOptions;
+begin
+ Result.Baud := Baud;
+ Result.DataBits := DataBits;
+ Result.Parity := Parity;
+ Result.StopBits := sbOne;
+ Result.FlowControl := [];
+ Result.Min := 0;
+ Result.Timeout := 0;
+end;
+
+function TSerialPortOptions.ToString: string;
+begin
+ Result :=
+ 'Baud: ' + IntToStr(Baud) + #10 +
+ 'DataBits: ' + IntToStr(DataBits) + #10 +
+ 'Parity: ' + GetEnumName(TypeInfo(TParity), Ord(Parity)) + #10 +
+ 'StopBits: ' + GetEnumName(TypeInfo(TStopBits), Ord(StopBits)) + #10 +
+ 'FlowControl: ' + SetToString(PTypeInfo(TypeInfo(TFlowControl)), Pointer(@FlowControl), True) + #10 +
+ 'Min: ' + IntToStr(Min) + #10 +
+ 'Timeout: ' + IntToStr(Timeout);
+end;
+
+{ TSerialPort }
+
+constructor TSerialPort.Create(const Device: string);
+begin
+ FDevice := Device;
+ inherited Create;
+end;
+
+destructor TSerialPort.Destroy;
+begin
+ Close;
+ inherited Destroy;
+end;
+
+function TSerialPort.Open: Boolean;
+begin
+ Result := Open(TSerialPortOptions.Create);
+end;
+
+function TSerialPort.Open(const Options: TSerialPortOptions): Boolean;
+begin
+ Result := False;
+ if Opened then
+ Exit;
+ if not FileExists(FDevice) then
+ Exit;
+ FHandle := _open(PChar(FDevice), O_RDWR or O_NOCTTY);
+ Result := Opened and UpdatePort(Options);
+end;
+
+function TSerialPort.UpdatePort(const Options: TSerialPortOptions): Boolean;
+var
+ T: TTermios;
+begin
+ Result := False;
+ if _tcgetattr(FHandle, T) <> 0 then
+ begin
+ Close;
+ Exit;
+ end;
+ T.c_cflag := T.c_cflag or CLOCAL or CREAD;
+ T.c_lflag := T.c_lflag and (not (ICANON or ECHO or ECHOE or ECHOK or ECHONL or ISIG or IEXTEN));
+ T.c_oflag := T.c_oflag and (not (OPOST or ONLCR or OCRNL));
+ T.c_iflag := T.c_iflag and (not (INLCR or IGNCR or ICRNL or IGNBRK or INPCK or ISTRIP or IXON or IXOFF));
+ T.c_cflag := T.c_cflag and (not (CBAUD or CBAUDEX or CSIZE or CRTSCTS));
+ case Options.Baud of
+ Baud300: T.c_cflag := T.c_cflag or B300;
+ Baud1200: T.c_cflag := T.c_cflag or B1200;
+ Baud2400: T.c_cflag := T.c_cflag or B2400;
+ Baud4800: T.c_cflag := T.c_cflag or B4800;
+ Baud9600: T.c_cflag := T.c_cflag or B9600;
+ Baud19200: T.c_cflag := T.c_cflag or B19200;
+ Baud38400: T.c_cflag := T.c_cflag or B38400;
+ Baud57600: T.c_cflag := T.c_cflag or B57600;
+ Baud115200: T.c_cflag := T.c_cflag or B115200;
+ Baud230400: T.c_cflag := T.c_cflag or B230400;
+ else
+ T.c_cflag := T.c_cflag or B9600;
+ end;
+ case Options.DataBits of
+ Bits5: T.c_cflag := T.c_cflag or CS5;
+ Bits6: T.c_cflag := T.c_cflag or CS6;
+ Bits7: T.c_cflag := T.c_cflag or CS7;
+ Bits8: T.c_cflag := T.c_cflag or CS8;
+ else
+ T.c_cflag := T.c_cflag or CS8;
+ end;
+ if Options.Parity = prOdd then
+ T.c_cflag := T.c_cflag or PARENB or PARODD
+ else if Options.Parity = prEven then
+ begin
+ T.c_cflag := T.c_cflag and (not PARODD);
+ T.c_cflag := T.c_cflag or PARENB;
+ end
+ else
+ T.c_cflag := T.c_cflag and (not (PARENB or PARODD));
+ if Options.StopBits = sbOne then
+ T.c_cflag := T.c_cflag and (not CSTOPB)
+ else
+ T.c_cflag := T.c_cflag or CSTOPB;
+ if fcXOn in Options.FlowControl then
+ T.c_iflag := T.c_iflag or IXON;
+ if fcXOff in Options.FlowControl then
+ T.c_iflag := T.c_iflag or IXOFF;
+ if fcRequestToSend in Options.FlowControl then
+ T.c_cflag := T.c_cflag or CRTSCTS;
+ T.c_cc[VTIME] := Options.Timeout;
+ T.c_cc[VMIN] := Options.Min;
+ if _tcsetattr(FHandle, TCSANOW, T) <> 0 then
+ begin
+ Close;
+ Exit;
+ end;
+ _tcflush(FHandle, TCIOFLUSH);
+ Result := True;
+end;
+
+procedure TSerialPort.Close;
+var
+ H: THandle;
+begin
+ if not Opened then
+ Exit;
+ H := FHandle;
+ FHandle := 0;
+ _tcflush(H, TCIOFLUSH);
+ _close(H);
+end;
+
+procedure TSerialPort.CheckOpened;
+begin
+ if not Opened then
+ raise EInOutError.Create('Port is not opened');
+end;
+
+function TSerialPort.Read: string;
+var
+ B: TBytes;
+ I: Integer;
+begin
+ Result := '';
+ I := ReadBinary(FReadBuffer, SizeOf(FReadBuffer));
+ if I < 1 then
+ Exit;
+ B := nil;
+ SetLength(B, I);
+ Move(FReadBuffer[0], B[0], I);
+ Result := TEncoding.ANSI.GetAnsiString(B);
+end;
+
+function TSerialPort.ReadBinary(var Buffer; BufferSize: Integer): Integer;
+begin
+ CheckOpened;
+ Result := _read(FHandle, Buffer, BufferSize);
+end;
+
+procedure TSerialPort.Write(const S: string);
+var
+ B: TBytes;
+begin
+ CheckOpened;
+ if S = '' then
+ Exit;
+ B := TEncoding.UTF8.GetAnsiBytes(S);
+ WriteBinary(B[0], Length(B));
+end;
+
+procedure TSerialPort.WriteBinary(var Buffer; BufferSize: Integer);
+begin
+ CheckOpened;
+ _write(FHandle, Buffer, BufferSize);
+end;
+
+procedure TSerialPort.XOn;
+var
+ B: Byte;
+begin
+ B := $11;
+ WriteBinary(B, 1);
+end;
+
+procedure TSerialPort.XOff;
+var
+ B: Byte;
+begin
+ B := $13;
+ WriteBinary(B, 1);
+end;
+
+function TSerialPort.GetOpened: Boolean;
+begin
+ Result := FHandle > 0;
+end;
+
+procedure EnumSerialPorts(Ports: TStrings);
+
+ function CheckPort(const Device: string): Boolean;
+ var
+ F: THandle;
+ T: TTermios;
+ begin
+ Result := False;
+ if not FileExists(Device) then
+ Exit;
+ F := _open(PChar(Device), O_RDWR or O_NOCTTY);
+ if F > 0 then
+ begin
+ Result := _tcgetattr(F, T) = 0;
+ _close(F);
+ end;
+ end;
+
+const
+ MaxPorts = 9;
+var
+ S, D: string;
+ I: Integer;
+begin
+ Ports.BeginUpdate;
+ try
+ Ports.Clear;
+ for I := 0 to MaxPorts do
+ begin
+ S := 'ttyS' + IntToStr(I);
+ D := '/sys/class/tty/' + S + '/device/';
+ if DirectoryExists(D) and (FileExists(D +'/id') or DirectoryExists(D + '/of_node')) then
+ begin
+ S := '/dev/' + S;
+ if CheckPort(S) then
+ Ports.Add(S);
+ end;
+ end;
+ for I := 0 to MaxPorts do
+ begin
+ S := 'ttyUSB' + IntToStr(I);
+ D := '/sys/class/tty/' + S + '/device/tty';
+ if DirectoryExists(D) or DirectoryExists('/sys/bus/usb-serial/devices/' + S) then
+ begin
+ S := '/dev/' + S;
+ if CheckPort(S) then
+ Ports.Add(S);
+ end;
+ end;
+ finally
+ Ports.EndUpdate;
+ end;
+end;
+{$endif}
+
+end.
+
diff --git a/source/codebot.lpk b/source/codebot/codebot.lpk
similarity index 59%
rename from source/codebot.lpk
rename to source/codebot/codebot.lpk
index 657be14..332a0eb 100644
--- a/source/codebot.lpk
+++ b/source/codebot/codebot.lpk
@@ -1,15 +1,12 @@
-
-
+
-
-
-
+
@@ -27,249 +24,193 @@
-
+
+
+
+
+
+
+
+
+
-
-
-
-
+
-
-
+
+
-
-
+
+
-
-
+
+
-
-
+
+
-
-
+
+
-
-
+
+
-
-
+
+
-
-
+
+
-
-
+
+
-
-
+
+
-
-
+
+
-
-
+
+
-
-
+
+
-
-
+
+
-
-
+
+
-
-
+
+
-
-
+
+
-
-
+
+
-
-
+
+
-
-
+
+
-
-
+
+
-
-
+
+
-
-
+
+
-
-
+
+
+
-
-
+
+
-
-
+
+
-
-
+
+
-
-
+
+
-
-
+
+
-
-
+
+
-
-
+
+
-
-
+
+
-
-
+
+
-
-
+
+
-
-
+
+
-
-
+
+
-
-
+
+
-
-
+
+
-
-
+
+
-
-
+
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
-
-
-
-
+
diff --git a/source/codebot/codebot.networking.beta.pas b/source/codebot/codebot.networking.beta.pas
new file mode 100644
index 0000000..37efff9
--- /dev/null
+++ b/source/codebot/codebot.networking.beta.pas
@@ -0,0 +1,1237 @@
+(********************************************************)
+(* *)
+(* Codebot Pascal Library *)
+(* http://cross.codebot.org *)
+(* Modified March 2015 *)
+(* *)
+(********************************************************)
+
+{ }
+unit Codebot.Networking;
+
+{$i codebot.inc}
+
+interface
+
+uses
+ SysUtils, Classes,
+ Codebot.System,
+ Codebot.Interop.Sockets,
+ Codebot.Interop.OpenSSL;
+
+{ TAddressName resolves and converts a host name to an internet address
+ See also
+ }
+
+type
+ TAddressName = record
+ private
+ FAddress: LongWord;
+ FHost: string;
+ FLocation: string;
+ FResolved: Boolean;
+ public
+ { Create an address name given a host to be resolved }
+ class function Create(const Host: string): TAddressName; static; overload;
+ { Create an address name given a 32 bit encoded address }
+ class function Create(Address: LongWord): TAddressName; static; overload;
+ { Create an address name given a 4 byte address }
+ class function Create(A, B, C, D: Byte): TAddressName; static; overload;
+ { Convert an address name to a string }
+ class operator Implicit(const Value: TAddressName): string;
+ { Convert a string to an address name }
+ class operator Implicit(const Value: string): TAddressName;
+ { Attempt to resolve a name into an address }
+ function Resolve: Boolean;
+ { The address resolved from the host }
+ property Address: LongWord read FAddress;
+ { The host name }
+ property Host: string read FHost;
+ { The address in string form }
+ property Location: string read FLocation;
+ { Resolved is true if a host name could be resolved }
+ property Resolved: Boolean read FResolved;
+ end;
+
+{ TSocketState is used by the TSocket class
+ See also
+ }
+
+ TSocketState = (
+ { The socket is closed and not connected }
+ ssClosed,
+ { The socket is listening and acting as a local server }
+ ssServer,
+ { The socket is a client connection connected to a remote server }
+ ssClient,
+ { The socket is an remote connection accepted by a local server }
+ ssRemote);
+
+
+{ TTransmitProgress is used to tally bytes read or written
+ See also
+ }
+
+ TTransmitData = record
+ Expected: Longint;
+ Actual: Longint;
+ end;
+
+
+ TTransmitCallback = procedure(Bytes: LargeInt; var Cancel: Boolean) of object;
+
+{ TTransmitEvent can be reused to indicate progress of reading or writing }
+
+ TTransmitEvent = procedure(Sender: TObject; const Expected, Actual: Longint;
+ var Cancel: Boolean) of object;
+
+{ Note, SSL certificate files can be generated using this terminal command:
+
+ openssl req -x509 -newkey rsa:2048 -keyout key.pem -out cert.pem \
+ -days 365 -nodes -subj '/CN=localhost' }
+
+{ TSocket provides a simple object oriented interface to network sockets
+ See also
+ }
+
+ TSocket = class(TObject)
+ private
+ FAddress: TAddressName;
+ FBlocking: Boolean;
+ FPort: Word;
+ FHandle: TSocketHandle;
+ FServer: TSocket;
+ FState: TSocketState;
+ FSecure: Boolean;
+ FSSLCertificates: TSSLCtx;
+ FSSLContext: TSSLCtx;
+ FSSLSocket: TSSL;
+ FTimeout: LongWord;
+ FTimer: Double;
+ FData: Pointer;
+ procedure SetBlocking(Value: Boolean);
+ procedure TimerReset;
+ function TimerExpired: Boolean;
+ function DoRead(var Buffer; BufferSize: LongWord): Integer;
+ function DoWrite(var Buffer; BufferSize: LongWord): Integer;
+ function GetAddress: TAddressName;
+ procedure SetSecure(Value: Boolean);
+ function GetConnected: Boolean;
+ public
+ { Create a new socket }
+ constructor Create; overload;
+ { Create an incomming connection for a server socket }
+ constructor Create(Server: TSocket); overload;
+ destructor Destroy; override;
+ { If you plan to create a secure socket server you need to load both a
+ certificate file and key file before listening }
+ function LoadCertificate(CertFile: string; KeyFile: string): Boolean;
+ { release any resources related to server certificates }
+ procedure UnloadCertificate;
+ { Close the socket }
+ procedure Close;
+ { Connect to an address converting the state to a client }
+ function Connect(const Address: TAddressName; Port: Word): Boolean;
+ { Listen on address and port converting the state to a server }
+ function Listen(const Address: TAddressName; Port: Word): Boolean; overload;
+ { Listen on a port converting the socket to a local server }
+ function Listen(Port: Word): Boolean; overload;
+ { While listening you may accept an incomming connection }
+ function Accept(Socket: TSocket): Boolean;
+ { Read incoming data from a client or remote socket to a buffer }
+ function Read(var Buffer; BufferSize: LongWord): Integer; overload;
+ { Read incoming data from a client or remote socket to text }
+ function Read(out Text: string; BufferSize: LongWord = $10000): Integer; overload;
+ { Write outgoing data from a buffer to a client or remote socket }
+ function Write(var Buffer; BufferSize: LongWord): Integer; overload;
+ { Write outgoing data from text to a client or remote socket }
+ function Write(const Text: string): Integer; overload;
+ { Write all bytes in a buffer to a client or remote socket }
+ function WriteAll(var Buffer; BufferSize: LongWord): Boolean; overload;
+ { Write all text to a client or remote socket }
+ function WriteAll(const Text: string): Boolean; overload;
+ { The address of socket }
+ property Address: TAddressName read GetAddress;
+ { When blocking is true, read an write operations will wait for completion }
+ property Blocking: Boolean read FBlocking write SetBlocking;
+ { The port of the socket }
+ property Port: Word read FPort;
+ { The server socket from which a remote socket was accepted }
+ property Server: TSocket read FServer;
+ { When secure is true socket communication will be routed through an SSL library }
+ property Secure: Boolean read FSecure write SetSecure;
+ { The underlying socket state }
+ property State: TSocketState read FState;
+ { Optional timeout period }
+ property Timeout: LongWord read FTimeout write FTimeout;
+ { Connected is true when a socket is valid and active }
+ property Connected: Boolean read GetConnected;
+ { Data provides a extra bits of user definable information }
+ property Data: Pointer read FData write FData;
+ end;
+
+{ THttpRequest can be used to send or receive http requests
+ See also
+ }
+
+ THttpRequest = class
+ private
+ FPartialBody: string;
+ FDone: Boolean;
+ FVerb: string;
+ FResource: string;
+ FProtocol: string;
+ FHeaders: INamedStrings;
+ FBodyStream: TStream;
+ FBodyText: string;
+ FValid: Boolean;
+ FCancelled: Boolean;
+ FOnProgress: TTransmitEvent;
+ function ReadHeader(Socket: TSocket): Boolean;
+ function ReadBody(Socket: TSocket): Boolean;
+ function SendHeader(Socket: TSocket): Boolean;
+ function SendBody(Socket: TSocket): Boolean;
+ public
+ constructor Create;
+ { Reset all read only properties to their defaults }
+ procedure Reset;
+ { Cancels the request, which you normally invoke during OnProgress }
+ procedure Cancel;
+ { Attempt to receive a request. Use this when you're the server. }
+ function Receive(Socket: TSocket): Boolean;
+ { Attempt to send a request. Use this when you're the client. }
+ function Send(Socket: TSocket): Boolean;
+ { Verb contains the method used by the client such as GET or POST }
+ property Verb: string read FVerb;
+ { Resource contains the resources and quest string,such as /index.htm }
+ property Resource: string read FResource write FResource;
+ { Protocol such as HTTP/1.1 }
+ property Protocol: string read FProtocol write FProtocol;
+ { Headers are the string value pairs }
+ property Headers: INamedStrings read FHeaders;
+ { When BodyStream is assigned it is used by send or receive }
+ property BodyStream: TStream read FBodyStream write FBodyStream;
+ { When BodyStream is unassigned BodyText is used by send or receive }
+ property BodyText: string read FBodyText write FBodyText;
+ { Valid holds the scuess or failure of the last send or receive }
+ property Valid: Boolean read FValid;
+ { OnProgress is invoked when body is being sent or received }
+ property OnProgress: TTransmitEvent read FOnProgress write FOnProgress;
+ end;
+
+
+procedure SocketWrite(Socket: TSocket; Stream: TStream);
+
+
+{ Attempt to locate the domain record }
+
+function Whois(const Domain: string; out Response: string): Boolean;
+
+implementation
+
+{ TAddressName }
+
+class function TAddressName.Create(const Host: string): TAddressName;
+begin
+ Result.FAddress := 0;
+ Result.FHost := Host;
+ Result.FLocation := '';
+ Result.FResolved := False;
+end;
+
+class function TAddressName.Create(Address: LongWord): TAddressName;
+var
+ Addr: TInAddr;
+begin
+ Addr.s_addr := Address;
+ Result.FAddress := Addr.s_addr;
+ Result.FHost := inet_ntoa(Addr);
+ Result.FLocation := Result.FHost;
+ Result.FResolved := True;
+end;
+
+class function TAddressName.Create(A, B, C, D: Byte): TAddressName;
+var
+ Addr: TInAddr;
+begin
+ SocketsInit;
+ Addr.S_un_b.s_b1 := A;
+ Addr.S_un_b.s_b2 := B;
+ Addr.S_un_b.s_b3 := C;
+ Addr.S_un_b.s_b4 := D;
+ Result.FAddress := Addr.s_addr;
+ Result.FHost := inet_ntoa(Addr);
+ Result.FLocation := Result.FHost;
+ Result.FResolved := True;
+end;
+
+class operator TAddressName.Implicit(const Value: TAddressName): string;
+begin
+ Result := Value.Host;
+end;
+
+class operator TAddressName.Implicit(const Value: string): TAddressName;
+begin
+ Result := TAddressName.Create(Value);
+end;
+
+function TAddressName.Resolve: Boolean;
+var
+ HostEnt: PHostEnt;
+ Addr: PInAddr;
+begin
+ SocketsInit;
+ if FResolved then
+ Exit(True);
+ if FHost = '' then
+ Exit(False);
+ HostEnt := gethostbyname(PAnsiChar(FHost));
+ if HostEnt = nil then
+ Exit(False);
+ Addr := HostEnt.h_addr^;
+ FAddress := Addr.S_addr;
+ FLocation := inet_ntoa(Addr^);
+ FResolved := True;
+ Result := True;
+end;
+
+{ TSocket class }
+
+constructor TSocket.Create;
+const
+ DefaultTimeout = 4000;
+begin
+ inherited Create;
+ SocketsInit;
+ FHandle := INVALID_SOCKET;
+ FTimeout := DefaultTimeout;
+end;
+
+constructor TSocket.Create(Server: TSocket);
+begin
+ Create;
+ FServer := Server;
+end;
+
+destructor TSocket.Destroy;
+begin
+ Close;
+ UnloadCertificate;
+ inherited Destroy;
+end;
+
+function TSocket.LoadCertificate(CertFile: string; KeyFile: string): Boolean;
+begin
+ Close;
+ FSecure := True;
+ if OpenSSLInit then
+ begin
+ FSSLCertificates := SSL_CTX_new(SSLv23_server_method);
+ if FSSLCertificates = nil then
+ Exit(False);
+ Result :=
+ (SSL_CTX_use_certificate_file(FSSLCertificates, PChar(CertFile), SSL_FILETYPE_PEM) > 0) and
+ (SSL_CTX_use_PrivateKey_file(FSSLCertificates, PChar(KeyFile), SSL_FILETYPE_PEM) > 0) and
+ (SSL_CTX_check_private_key(FSSLCertificates) > 0);
+ if not Result then
+ begin
+ SSL_CTX_free(FSSLCertificates);
+ FSSLCertificates := nil;
+ end;
+ end
+ else
+ Result := False;
+end;
+
+procedure TSocket.UnloadCertificate;
+begin
+ if FSSLCertificates <> nil then
+ begin
+ Close;
+ SSL_CTX_free(FSSLCertificates);
+ FSSLCertificates := nil;
+ end;
+ FSecure := False;
+end;
+
+procedure TSocket.Close;
+var
+ H: TSocketHandle;
+ S: TSSL;
+ C: TSSLCtx;
+begin
+ FState := ssClosed;
+ H := FHandle;
+ S := FSSLSocket;
+ C := FSSLContext;
+ FHandle := INVALID_SOCKET;
+ FSSLSocket := nil;
+ FSSLContext := nil;
+ if H <> INVALID_SOCKET then
+ begin
+ Codebot.Interop.Sockets.shutdown(H, SHUT_RDWR);
+ Codebot.Interop.Sockets.close(H);
+ end;
+ if S <> nil then
+ begin
+ SSL_shutdown(S);
+ SSL_free(S);
+ end;
+ if C <> nil then
+ SSL_CTX_free(C);
+end;
+
+procedure TSocket.TimerReset;
+begin
+ FTimer := 0;
+end;
+
+procedure TSocket.SetBlocking(Value: Boolean);
+begin
+ if FBlocking = Value then Exit;
+ Close;
+ FBlocking := Value;
+end;
+
+function TSocket.TimerExpired: Boolean;
+begin
+ if FTimeout = 0 then
+ Result := True
+ else if FTimer = 0 then
+ begin
+ FTimer := TimeQuery;
+ Result := False;
+ end
+ else
+ Result := TimeQuery - FTimer > FTimeout / 1000;
+end;
+
+function TSocket.Connect(const Address: TAddressName; Port: Word): Boolean;
+var
+ Addr: TSockAddrIn;
+ {$ifdef windows}
+ Mode: LongWord;
+ {$endif}
+begin
+ Close;
+ if FSecure then
+ if not OpenSSLInit then
+ Exit(False);
+ FAddress := Address;
+ FPort := Port;
+ if not FAddress.Resolve then
+ Exit(False);
+ if FPort = 0 then
+ Exit(False);
+ FHandle := socket(AF_INET, SOCK_STREAM, IPPROTO_TCP);
+ if FHandle = INVALID_SOCKET then
+ Exit(False);
+ Addr.sin_family := AF_INET;
+ Addr.sin_addr.s_addr := FAddress.Address;
+ Addr.sin_port := htons(FPort);
+ if Codebot.Interop.Sockets.connect(FHandle, @Addr, SizeOf(Addr)) = SOCKET_ERROR then
+ begin
+ Close;
+ Exit(False);
+ end;
+ FState := ssClient;
+ if FSecure then
+ begin
+ FSSLContext := SSL_CTX_new(SSLv3_client_method);
+ if FSSLContext = nil then
+ begin
+ Close;
+ Exit(False);
+ end;
+ FSSLSocket := SSL_new(FSSLContext);
+ if FSSLSocket = nil then
+ begin
+ Close;
+ Exit(False);
+ end;
+ if SSL_set_fd(FSSLSocket, FHandle) < 1 then
+ begin
+ Close;
+ Exit(False);
+ end;
+ if SSL_connect(FSSLSocket) < 1 then
+ begin
+ Close;
+ Exit(False);
+ end;
+ end;
+ if not FBlocking then
+ begin
+ {$ifdef windows}
+ Mode := 1;
+ ioctlsocket(FHandle, FIONBIO, Mode);
+ {$else}
+ fcntl(FHandle, F_SETFL, O_NONBLOCK);
+ {$endif}
+ end;
+ Result := True;
+end;
+
+function TSocket.Listen(const Address: TAddressName; Port: Word): Boolean;
+var
+ Addr: TSockAddrIn;
+begin
+ Result := False;
+ Close;
+ if FSecure and (FSSLCertificates = nil) then
+ Exit;
+ FAddress := Address;
+ FPort := Port;
+ if FPort = 0 then
+ Exit;
+ FHandle := socket(AF_INET, SOCK_STREAM, IPPROTO_TCP);
+ if FHandle = INVALID_SOCKET then
+ Exit;
+ Addr.sin_family := AF_INET;
+ if FAddress.Resolve then
+ Addr.sin_addr.s_addr := FAddress.Address
+ else
+ Addr.sin_addr.s_addr := INADDR_ANY;
+ Addr.sin_port := htons(FPort);
+ if bind(FHandle, @Addr, SizeOf(Addr)) = SOCKET_ERROR then
+ begin
+ Close;
+ Exit;
+ end;
+ if not FAddress.Resolved then
+ FAddress := TAddressName.Create(Addr.sin_addr.s_addr);
+ if Codebot.Interop.Sockets.listen(FHandle, SOMAXCONN) = SOCKET_ERROR then
+ begin
+ Close;
+ Exit;
+ end;
+ FState := ssServer;
+ Result := True;
+end;
+
+function TSocket.Listen(Port: Word): Boolean;
+begin
+ Result := Listen(TAddressName.Create(''), Port);
+end;
+
+function TSocket.Accept(Socket: TSocket): Boolean;
+var
+ Addr: TSockAddrIn;
+ I: Integer;
+ H: TSocketHandle;
+ {$ifdef windows}
+ Mode: LongWord;
+ {$endif}
+ Error: LongInt;
+begin
+ Result := False;
+ if Socket = Self then
+ Exit;
+ Socket.Close;
+ if FState <> ssServer then
+ Exit;
+ I := SizeOf(Addr);
+ H := Codebot.Interop.Sockets.accept(FHandle, @Addr, I);
+ if H = INVALID_SOCKET then
+ Exit;
+ Socket.FHandle := H;
+ Socket.FAddress := TAddressName.Create(Addr.sin_addr.s_addr);
+ Socket.FPort := ntohs(Addr.sin_port);
+ Socket.FState := ssRemote;
+ Socket.FServer := Self;
+ Socket.FBlocking := FBlocking;
+ if not FBlocking then
+ begin
+ {$ifdef windows}
+ Mode := 1;
+ ioctlsocket(Socket.FHandle, FIONBIO, Mode);
+ {$else}
+ fcntl(Socket.FHandle, F_SETFL, O_NONBLOCK);
+ {$endif}
+ end;
+ Socket.FSecure := FSecure;
+ if FSecure then
+ begin
+ Socket.FSSLSocket := SSL_new(FSSLCertificates);
+ if Socket.FSSLSocket = nil then
+ begin
+ Socket.Close;
+ Exit;
+ end;
+ if SSL_set_fd(Socket.FSSLSocket, Socket.FHandle) < 1 then
+ begin
+ Socket.Close;
+ Exit;
+ end;
+ if FBlocking then
+ begin
+ if SSL_accept(Socket.FSSLSocket) < 1 then
+ begin
+ Socket.Close;
+ Exit;
+ end;
+ end
+ else
+ repeat
+ Error := SSL_accept(Socket.FSSLSocket);
+ if Error > 0 then
+ Break;
+ if Error = 0 then
+ begin
+ Socket.Close;
+ Exit;
+ end;
+ Error := SSL_get_error(Socket.FSSLSocket, Error);
+ if (Error = SSL_ERROR_WANT_READ) or (Error = SSL_ERROR_WANT_WRITE) then
+ Continue;
+ Socket.Close;
+ Exit;
+ until False;
+ end;
+ Result := True;
+end;
+
+function TSocket.DoRead(var Buffer; BufferSize: LongWord): Integer;
+var
+ Bytes: LongInt;
+begin
+ if FState < ssClient then
+ Exit(SOCKET_ERROR);
+ if BufferSize < 1 then
+ Exit(0);
+ if FSecure then
+ Bytes := SSL_read(FSSLSocket, @Buffer, BufferSize)
+ else
+ Bytes := recv(FHandle, Buffer, BufferSize, 0);
+ if Bytes = 0 then
+ begin
+ Close;
+ Exit(Bytes);
+ end;
+ Result := Bytes;
+end;
+
+function TSocket.Read(var Buffer; BufferSize: LongWord): Integer;
+begin
+ TimerReset;
+ repeat
+ Result := DoRead(Buffer, BufferSize);
+ if (Result > -1) or FBlocking then
+ Break;
+ Sleep(1);
+ until TimerExpired;
+ if Result < 0 then
+ Result := 0;
+end;
+
+function TSocket.Read(out Text: string; BufferSize: LongWord = $10000): Integer;
+begin
+ SetLength(Text, BufferSize);
+ Result := Read(Pointer(Text)^, BufferSize);
+ if Result < 1 then
+ SetLength(Text, 0)
+ else
+ SetLength(Text, Result);
+end;
+
+function TSocket.DoWrite(var Buffer; BufferSize: LongWord): Integer;
+var
+ Bytes: LongInt;
+begin
+ if FState < ssClient then
+ Exit(SOCKET_ERROR);
+ if BufferSize < 1 then
+ Exit(0);
+ if FSecure then
+ Bytes := SSL_write(FSSLSocket, @Buffer, BufferSize)
+ else
+ Bytes := send(FHandle, Buffer, BufferSize, MSG_NOSIGNAL);
+ if Bytes < 1 then
+ begin
+ Close;
+ Exit(SOCKET_ERROR);
+ end;
+ Result := Bytes;
+end;
+
+function TSocket.Write(var Buffer; BufferSize: LongWord): Integer;
+begin
+ TimerReset;
+ repeat
+ Result := DoWrite(Buffer, BufferSize);
+ if (Result > -1) or FBlocking then
+ Break;
+ Sleep(1);
+ until TimerExpired;
+ if Result < 0 then
+ Result := 0;
+end;
+
+function TSocket.Write(const Text: string): Integer;
+begin
+ Result := Write(Pointer(Text)^, Length(Text));
+end;
+
+function TSocket.WriteAll(var Buffer; BufferSize: LongWord): Boolean;
+var
+ B: PByte;
+ I: Integer;
+begin
+ Result := False;
+ if FState < ssClient then
+ Exit;
+ if BufferSize < 1 then
+ Exit;
+ B := @Buffer;
+ while BufferSize > 0 do
+ begin
+ I := Write(B^, BufferSize);
+ if not Connected then
+ Exit;
+ if I < 1 then
+ Continue;
+ BufferSize := BufferSize - I;
+ Inc(B, I);
+ end;
+ Result := True;
+end;
+
+function TSocket.WriteAll(const Text: string): Boolean;
+begin
+ Result := WriteAll(Pointer(Text)^, Length(Text));
+end;
+
+function TSocket.GetAddress: TAddressName;
+begin
+ Result := FAddress;
+end;
+
+procedure TSocket.SetSecure(Value: Boolean);
+begin
+ if Value <> FSecure then
+ begin
+ Close;
+ FSecure := Value;
+ end;
+end;
+
+function TSocket.GetConnected: Boolean;
+begin
+ Result := FHandle <> INVALID_SOCKET;
+end;
+
+{ THttpRequest }
+
+constructor THttpRequest.Create;
+begin
+ inherited Create;
+ FHeaders := TNamedStringsIntf.Create;
+end;
+
+procedure THttpRequest.Reset;
+begin
+ FCancelled := False;
+ FVerb := '';
+ FResource := '';
+ FProtocol := '';
+ FPartialBody := '';
+ FBodyText := '';
+ FHeaders.Clear;
+ FDone := False;
+ FValid := False;
+end;
+
+procedure THttpRequest.Cancel;
+begin
+ FCancelled := True;
+end;
+
+function THttpRequest.ReadHeader(Socket: TSocket): Boolean;
+const
+ Endings: array[0..3] of string = (#13#10#13#10, #10#13#10#13, #10#10, #13#10);
+var
+ HeaderComplete: Boolean;
+ Header, Ending, S: string;
+ EndIndex, I, J: Integer;
+ Lines, First: StringArray;
+begin
+ Result := False;
+ Reset;
+ HeaderComplete := False;
+ Header := '';
+ J := 0;
+ repeat
+ if not Socket.Connected then
+ Break;
+ I := Socket.Read(S);
+ { We wait on read to give the user a chance to accept an ssl certificate }
+ if I = 0 then
+ begin
+ Inc(J);
+ Sleep(500);
+ if J = 60 then
+ Exit
+ else
+ Continue;
+ end;
+ if I > 0 then
+ begin
+ Header := Header + S;
+ EndIndex := -1;
+ for I := Low(Endings) to High(Endings) do
+ begin
+ EndIndex := Header.IndexOf(Endings[I]);
+ if EndIndex > 0 then
+ begin
+ EndIndex := I;
+ Break;
+ end;
+ end;
+ if EndIndex > -1 then
+ begin
+ HeaderComplete := True;
+ Ending := Endings[EndIndex];
+ FPartialBody := Header.SecondOf(Ending);
+ S := Header.FirstOf(Ending);
+ Ending.Length := Ending.Length div 2;
+ Lines := S.Split(Ending);
+ if Lines.Length > 0 then
+ begin
+ S := Lines[0];
+ First := S.Split(' ');
+ if First.Length > 2 then
+ begin
+ FVerb := First[0];
+ FResource := First[1];
+ FProtocol := First[2];
+ for I := 1 to Lines.Length - 1 do
+ begin
+ S := Lines[I];
+ FHeaders.Add(S.FirstOf(':').Trim, S.SecondOf(':').Trim);
+ end;
+ FValid := True;
+ end;
+ end;
+ end;
+ end
+ else
+ HeaderComplete := True;
+ until HeaderComplete;
+ Result := FValid;
+end;
+
+function THttpRequest.ReadBody(Socket: TSocket): Boolean;
+const
+ BufferSize = $10000;
+var
+ OwnStream: Boolean;
+ Stream: TStream;
+ Buffer: Pointer;
+ UndefinedLength: Boolean;
+ ContentLength, ContentRead: LargeInt;
+ I: LargeInt;
+begin
+ Result := False;
+ if (not FValid) or FDone then
+ Exit;
+ FDone := True;
+ if FVerb = 'GET' then
+ Exit(True);
+ OwnStream := BodyStream = nil;
+ if OwnStream then
+ Stream := TStringStream.Create(FPartialBody)
+ else
+ begin
+ Stream := BodyStream;
+ if FPartialBody.Length > 0 then
+ Stream.Write(PChar(FPartialBody)^, FPartialBody.Length);
+ end;
+ Buffer := GetMem(BufferSize);
+ FPartialBody := '';
+ FBodyText := '';
+ try
+ ContentRead := 0;
+ ContentLength := 0;
+ I := StrToInt64Def(FHeaders.GetValue('Content-Length'), -1);
+ UndefinedLength := I < 0;
+ if UndefinedLength then
+ ContentLength := High(ContentLength)
+ else
+ ContentLength := I;
+ if (I <> 0) and Assigned(FOnProgress) then
+ if UndefinedLength then
+ FOnProgress(Self, 0, 0)
+ else
+ FOnProgress(Self, ContentLength, 0);
+ if FCancelled then
+ Exit;
+ if I <> 0 then
+ repeat
+ if not Socket.Connected then
+ Break;
+ if UndefinedLength then
+ I := Socket.Read(Buffer^, BufferSize)
+ else if ContentLength - ContentRead > BufferSize then
+ I := Socket.Read(Buffer^, BufferSize)
+ else
+ I := Socket.Read(Buffer^, ContentLength - ContentRead);
+ if I < 0 then
+ Break;
+ if I > 0 then
+ begin
+ Stream.Write(Buffer^, I);
+ ContentRead := ContentRead + I;
+ if Assigned(FOnProgress) then
+ if UndefinedLength then
+ FOnProgress(Self, 0, ContentRead)
+ else
+ FOnProgress(Self, ContentLength, ContentRead);
+ if FCancelled then
+ Exit;
+ end;
+ until ContentRead = ContentLength;
+ Result := UndefinedLength or (ContentRead = ContentLength);
+ if OwnStream then
+ FBodyText := (Stream as TStringStream).DataString;
+ finally
+ FreeMem(Buffer);
+ if OwnStream then
+ Stream.Free;
+ end;
+end;
+
+function THttpRequest.Receive(Socket: TSocket): Boolean;
+begin
+ Result := ReadHeader(Socket) and ReadBody(Socket);
+end;
+
+function THttpRequest.SendHeader(Socket: TSocket): Boolean;
+const
+ Ending = #13#10;
+var
+ Request, S: string;
+ I: Integer;
+begin
+ FCancelled := False;
+ Result := False;
+ try
+ if not Socket.Connected then
+ Exit;
+ if FVerb = '' then
+ FVerb := 'GET';
+ Request := FVerb;
+ if FResource = '' then
+ FResource := '/';
+ Request := Request + ' ' + FResource;
+ if FProtocol = '' then
+ FProtocol := 'HTTP/1.1'
+ Request := Request + ' ' + FProtocol + Ending;
+ for I := 0 to FHeaders.Count - 1 do
+ begin
+ S := FHeaders.Names[I];
+ Request := Request + S + ': ' FHeaders.ValueByIndex[I] + Ending;
+ end;
+ Request := Request + Ending;
+ Result := Socket.WriteAll(Request);
+ finally
+ FValid := Result;
+ end;
+end;
+
+function THttpRequest.SendBody(Socket: TSocket): Boolean;
+const
+ BufferSize = $10000;
+var
+ OwnStream: Boolean;
+ Stream: TStream;
+ Buffer: Pointer;
+ ContentLength, ContentWrite: LargeInt;
+ I: LargeInt;
+begin
+ Result := False;
+ try
+ if not Socket.Connected then
+ Exit;
+ if not FValid then
+ Exit;
+ if FVerb = 'GET' then
+ begin
+ Result := True;
+ Exit;
+ end;
+ if FBodyStream = nil then
+ begin
+ Stream := TStringStream.Create(FBodyText);
+ OwnStream := True;
+ end
+ else
+ begin
+ Stream := FBodyStream;
+ OwnStream := False;
+ end;
+ try
+ I := Stream.Size - Stream.Position < 0;
+ if I < 1 then
+ ContentLength := 0
+ else
+ ContentLength := I;
+ I := StrToInt64Def(FHeaders['Content-Length'], 0);
+ if I <> ContentLength then
+ Exit;
+ if ContentLength = 0 then
+ begin
+ Result := True;
+ Exit;
+ end;
+ ContentWrite := 0;
+ if Assigned(FOnProgress) then
+ FOnProgress(Self, ContentLength, ContentWrite);
+ if FCancelled then
+ Exit;
+ Buffer := GetMem();
+
+ finally
+ if OwnStream then
+ Stream.Free;
+ end;
+ finally
+ FValid := Result;
+ end;
+end;
+
+function THttpRequest.Send(Socket: TSocket): Boolean;
+begin
+ Result := SendHeader(Socket) and SendBody(Socket);
+end;
+
+function Whois(const Domain: string; out Response: string): Boolean;
+type
+ TDomainList = array of string;
+
+const
+ Domains: TDomainList = nil;
+
+ procedure Init;
+ begin
+ Domains := TDomainList.Create(
+ 'ac whois.nic.ac',
+ 'ae whois.aeda.net.ae',
+ 'aero whois.aero',
+ 'af whois.nic.af',
+ 'ag whois.nic.ag',
+ 'al whois.ripe.net',
+ 'am whois.amnic.net',
+ 'as whois.nic.as',
+ 'asia whois.nic.asia',
+ 'at whois.nic.at',
+ 'au whois.aunic.net',
+ 'ax whois.ax',
+ 'az whois.ripe.net',
+ 'ba whois.ripe.net',
+ 'be whois.dns.be',
+ 'bg whois.register.bg',
+ 'bi whois.nic.bi',
+ 'biz whois.neulevel.biz',
+ 'bj www.nic.bj',
+ 'br whois.nic.br',
+ 'br.com whois.centralnic.com',
+ 'bt whois.netnames.net',
+ 'by whois.cctld.by',
+ 'bz whois.belizenic.bz',
+ 'ca whois.cira.ca',
+ 'cat whois.cat',
+ 'cc whois.nic.cc',
+ 'cd whois.nic.cd',
+ 'ch whois.nic.ch',
+ 'ck whois.nic.ck',
+ 'cl whois.nic.cl',
+ 'cn whois.cnnic.net.cn',
+ 'cn.com whois.centralnic.com',
+ 'co whois.nic.co',
+ 'co.nl whois.co.nl',
+ 'com whois.verisign-grs.com',
+ 'coop whois.nic.coop',
+ 'cx whois.nic.cx',
+ 'cy whois.ripe.net',
+ 'cz whois.nic.cz',
+ 'de whois.denic.de',
+ 'dk whois.dk-hostmaster.dk',
+ 'dm whois.nic.cx',
+ 'dz whois.nic.dz',
+ 'edu whois.educause.net',
+ 'ee whois.tld.ee',
+ 'eg whois.ripe.net',
+ 'es whois.nic.es',
+ 'eu whois.eu',
+ 'eu.com whois.centralnic.com',
+ 'fi whois.ficora.fi',
+ 'fo whois.nic.fo',
+ 'fr whois.nic.fr',
+ 'gb whois.ripe.net',
+ 'gb.com whois.centralnic.com',
+ 'gb.net whois.centralnic.com',
+ 'qc.com whois.centralnic.com',
+ 'ge whois.ripe.net',
+ 'gl whois.nic.gl',
+ 'gm whois.ripe.net',
+ 'gov whois.nic.gov',
+ 'gr whois.ripe.net',
+ 'gs whois.nic.gs',
+ 'hk whois.hknic.net.hk',
+ 'hm whois.registry.hm',
+ 'hn whois2.afilias-grs.net',
+ 'hr whois.dns.hr',
+ 'hu whois.nic.hu',
+ 'hu.com whois.centralnic.com',
+ 'id whois.pandi.or.id',
+ 'ie whois.domainregistry.ie',
+ 'il whois.isoc.org.il',
+ 'in whois.inregistry.net',
+ 'info whois.afilias.info',
+ 'int whois.isi.edu',
+ 'io whois.nic.io',
+ 'iq vrx.net',
+ 'ir whois.nic.ir',
+ 'is whois.isnic.is',
+ 'it whois.nic.it',
+ 'je whois.je',
+ 'jobs jobswhois.verisign-grs.com',
+ 'jp whois.jprs.jp',
+ 'ke whois.kenic.or.ke',
+ 'kg whois.domain.kg',
+ 'kr whois.nic.or.kr',
+ 'la whois2.afilias-grs.net',
+ 'li whois.nic.li',
+ 'lt whois.domreg.lt',
+ 'lu whois.restena.lu',
+ 'lv whois.nic.lv',
+ 'ly whois.lydomains.com',
+ 'ma whois.iam.net.ma',
+ 'mc whois.ripe.net',
+ 'md whois.nic.md',
+ 'me whois.nic.me',
+ 'mil whois.nic.mil',
+ 'mk whois.ripe.net',
+ 'mobi whois.dotmobiregistry.net',
+ 'ms whois.nic.ms',
+ 'mt whois.ripe.net',
+ 'mu whois.nic.mu',
+ 'mx whois.nic.mx',
+ 'my whois.mynic.net.my',
+ 'name whois.nic.name',
+ 'net whois.verisign-grs.com',
+ 'news whois.rightside.co',
+ 'nf whois.nic.cx',
+ 'ng whois.nic.net.ng',
+ 'nl whois.domain-registry.nl',
+ 'no whois.norid.no',
+ 'no.com whois.centralnic.com',
+ 'nu whois.nic.nu',
+ 'nz whois.srs.net.nz',
+ 'org whois.pir.org',
+ 'pl whois.dns.pl',
+ 'pr whois.nic.pr',
+ 'pro whois.registrypro.pro',
+ 'pt whois.dns.pt',
+ 'pw whois.nic.pw',
+ 'ro whois.rotld.ro',
+ 'ru whois.tcinet.ru',
+ 'sa saudinic.net.sa',
+ 'sa.com whois.centralnic.com',
+ 'sb whois.nic.net.sb',
+ 'sc whois2.afilias-grs.net',
+ 'se whois.nic-se.se',
+ 'se.com whois.centralnic.com',
+ 'se.net whois.centralnic.com',
+ 'sg whois.nic.net.sg',
+ 'sh whois.nic.sh',
+ 'si whois.arnes.si',
+ 'sk whois.sk-nic.sk',
+ 'sm whois.nic.sm',
+ 'st whois.nic.st',
+ 'so whois.nic.so',
+ 'su whois.tcinet.ru',
+ 'tc whois.adamsnames.tc',
+ 'tel whois.nic.tel',
+ 'tf whois.nic.tf',
+ 'th whois.thnic.net',
+ 'tj whois.nic.tj',
+ 'tk whois.nic.tk',
+ 'tl whois.domains.tl',
+ 'tm whois.nic.tm',
+ 'tn whois.ati.tn',
+ 'to whois.tonic.to',
+ 'tp whois.domains.tl',
+ 'tr whois.nic.tr',
+ 'travel whois.nic.travel',
+ 'tw whois.twnic.net.tw',
+ 'tv whois.nic.tv',
+ 'tz whois.tznic.or.tz',
+ 'ua whois.ua',
+ 'uk whois.nic.uk',
+ 'uk.com whois.centralnic.com',
+ 'uk.net whois.centralnic.com',
+ 'ac.uk whois.ja.net',
+ 'gov.uk whois.ja.net',
+ 'us whois.nic.us',
+ 'us.com whois.centralnic.com',
+ 'uy nic.uy',
+ 'uy.com whois.centralnic.com',
+ 'uz whois.cctld.uz',
+ 'va whois.ripe.net',
+ 'vc whois2.afilias-grs.net',
+ 've whois.nic.ve',
+ 'vg whois.adamsnames.tc',
+ 'ws whois.website.ws',
+ 'xxx whois.nic.xxx',
+ 'yu whois.ripe.net',
+ 'za.com whois.centralnic.com');
+ end;
+
+ function FindServer: string;
+ var
+ Strings: StringArray;
+ A, B: string;
+ S: string;
+ begin
+ if Domains = nil then
+ Init;
+ Result := '';
+ Strings := Domain.Trim.ToLower.Split('.');
+ if Strings.Length < 2 then
+ Exit;
+ A := Strings.Pop;
+ B := Strings.Pop;
+ if A.IsEmpty or B.IsEmpty then
+ Exit;
+ for S in Domains do
+ if S.BeginsWith(A + ' ') or S.BeginsWith(B + '.' + A + ' ') then
+ Exit(S.SecondOf(' '));
+ end;
+
+const
+ WhoisPort = 43;
+var
+ Socket: TSocket;
+ S: string;
+begin
+ Response := '';
+ Result := False;
+ S := FindServer;
+ if S.IsEmpty then
+ Exit;
+ Socket := TSocket.Create;
+ try
+ if Socket.Connect(S, WhoisPort) then
+ begin
+ S := 'domain ' + Domain.Trim.ToLower + #10;
+ if Socket.Write(S) = S.Length then
+ Result := (Socket.Read(Response) > S.Length) and (Response.IndexOf('Domain Name:') > 0);
+ end;
+ finally
+ Socket.Free;
+ end;
+end;
+
+end.
+
diff --git a/source/codebot.networking.ftp.pas b/source/codebot/codebot.networking.ftp.pas
similarity index 98%
rename from source/codebot.networking.ftp.pas
rename to source/codebot/codebot.networking.ftp.pas
index e883b47..892d40d 100644
--- a/source/codebot.networking.ftp.pas
+++ b/source/codebot/codebot.networking.ftp.pas
@@ -2,7 +2,7 @@
(* *)
(* Codebot Pascal Library *)
(* http://cross.codebot.org *)
-(* Modified March 2015 *)
+(* Modified August 2019 *)
(* *)
(********************************************************)
@@ -619,16 +619,16 @@ function TFtpClient.FindFirst(const Path: string; out FindData: TRemoteFindData;
function TFtpClient.FindNext(out FindData: TRemoteFindData): Boolean;
- function SafeRead(var Columns: StringArray; Index: Integer): string;
+ function SafeRead(var Columns: StringArray; Index: Integer): string;
var
I: Integer;
begin
I := Columns.Length;
if Index < I then
- Result := Columns[Index]
- else
- Result := '';
- end;
+ Result := Columns[Index]
+ else
+ Result := '';
+ end;
const
AttributeColumn = 0;
@@ -654,10 +654,10 @@ function TFtpClient.FindNext(out FindData: TRemoteFindData): Boolean;
if FFindIndex < FFindList.Length then
begin
Columns := FFindList[FFindIndex].Words(FileColumn);
- S := SafeRead(Columns, AttributeColumn);
+ S := SafeRead(Columns, AttributeColumn);
if S.Length >= 10 then
begin
- if S[1] = 'd' then
+ if S[1] = 'd' then
Include(FindData.Attributes, fsaDirectory);
if S[1] = 'l' then
Include(FindData.Attributes, fsaLink);
@@ -667,7 +667,7 @@ function TFtpClient.FindNext(out FindData: TRemoteFindData): Boolean;
Include(FindData.Attributes, fsaWrite);
if S[10] = 'x' then
Include(FindData.Attributes, fsaExecute);
- end;
+ end;
if FindData.Attributes * FFindMask = [] then
begin
Result := FindNext(FindData);
@@ -701,7 +701,7 @@ function TFtpClient.FindNext(out FindData: TRemoteFindData): Boolean;
Result := True;
end
else
- Result := False;
+ Result := False;
end;
procedure TFtpClient.SetConnected(Value: Boolean);
diff --git a/source/codebot.networking.pas b/source/codebot/codebot.networking.pas
similarity index 78%
rename from source/codebot.networking.pas
rename to source/codebot/codebot.networking.pas
index dd630f4..2bd8f9f 100644
--- a/source/codebot.networking.pas
+++ b/source/codebot/codebot.networking.pas
@@ -2,7 +2,7 @@
(* *)
(* Codebot Pascal Library *)
(* http://cross.codebot.org *)
-(* Modified March 2015 *)
+(* Modified September 2023 *)
(* *)
(********************************************************)
@@ -15,7 +15,9 @@ interface
uses
SysUtils,
+ Classes,
Codebot.System,
+ Codebot.Cryptography,
Codebot.Interop.Sockets,
Codebot.Interop.OpenSSL;
@@ -93,6 +95,7 @@ TSocket = class(TObject)
FSecure: Boolean;
FSSLContext: TSSLCtx;
FSSLSocket: TSSL;
+ FSSLConnected: Boolean;
FTimeout: LongWord;
FTimer: Double;
procedure SetBlocking(Value: Boolean);
@@ -130,7 +133,11 @@ TSocket = class(TObject)
{ Write all bytes in a buffer to a client or remote socket }
function WriteAll(var Buffer; BufferSize: LongWord): Boolean; overload;
{ Write all text to a client or remote socket }
- function WriteAll(const Text: string): Boolean; overload;
+ function WriteText(const Text: string; Task: IAsyncTask = nil): Boolean; overload;
+ { Write the contents of a file to a client or remote socket }
+ function WriteFile(const FileName: string; Task: IAsyncTask = nil): Boolean;
+ { Write a stream to a client or remote socket }
+ function WriteStream(Stream: TStream; Task: IAsyncTask = nil): Boolean;
{ The address of socket }
property Address: TAddressName read GetAddress;
{ When blocking is true, read an write operations wait }
@@ -157,8 +164,15 @@ TSocket = class(TObject)
TTransmitEvent = procedure(Sender: TObject; const Size, Transmitted: LargeWord) of object;
+{ Send data to a host using a port returning true if sucessful }
+
+function SocketSend(const Host: string; Port: Word; const Data: string): Boolean;
+
implementation
+uses
+ Codebot.Support;
+
{ TAddressName }
class function TAddressName.Create(const Host: string): TAddressName;
@@ -227,6 +241,11 @@ function TAddressName.Resolve: Boolean;
{ TSocket class }
+{$define SockAccept := Codebot.Interop.Sockets.accept}
+{$define SockClose := Codebot.Interop.Sockets.close}
+{$define SockConnect := Codebot.Interop.Sockets.connect}
+{$define SockListen := Codebot.Interop.Sockets.listen}
+
constructor TSocket.Create;
const
DefaultTimeout = 4000;
@@ -251,6 +270,7 @@ destructor TSocket.Destroy;
procedure TSocket.Close;
var
+ B: Boolean;
S: TSSL;
C: TSSLCtx;
H: TSocketHandle;
@@ -258,21 +278,24 @@ procedure TSocket.Close;
FState := ssClosed;
if FHandle = INVALID_SOCKET then
Exit;
+ B := FSSLConnected;
S := FSSLSocket;
C := FSSLContext;
H := FHandle;
+ FSSLConnected := False;
FSSLSocket := nil;
FSSLContext := nil;
FHandle := INVALID_SOCKET;
if S <> nil then
begin
- SSL_shutdown(S);
+ if B then
+ SSL_shutdown(S);
SSL_free(S);
end;
if C <> nil then
SSL_CTX_free(C);
shutdown(H, SHUT_RDWR);
- Codebot.Interop.Sockets.close(H);
+ SockClose(H);
end;
procedure TSocket.TimerReset;
@@ -300,18 +323,23 @@ function TSocket.TimerExpired: Boolean;
Result := TimeQuery - FTimer > FTimeout / 1000;
end;
+procedure SSL_set_tlsext_host_name(ssl: Tssl; host: PChar);
+begin
+ SSL_ctrl(ssl, SSL_CTRL_SET_TLSEXT_HOSTNAME, TLSEXT_NAMETYPE_host_name, host);
+end;
+
function TSocket.Connect(const Address: TAddressName; Port: Word): Boolean;
var
- Addr: TSockAddrIn;
+ Addr: TSockAddr;
{$ifdef windows}
Mode: LongWord;
{$endif}
begin
Close;
if FSecure then
- if not OpenSSLInit then
+ if not InitSSL then
Exit(False);
- FAddress := Address;
+ FAddress := Address;
FPort := Port;
if not FAddress.Resolve then
Exit(False);
@@ -326,7 +354,7 @@ function TSocket.Connect(const Address: TAddressName; Port: Word): Boolean;
Addr.sin_family := AF_INET;
Addr.sin_addr.s_addr := FAddress.Address;
Addr.sin_port := htons(FPort);
- if Codebot.Interop.Sockets.connect(FHandle, @Addr, SizeOf(Addr)) = SOCKET_ERROR then
+ if SockConnect(FHandle, @Addr, SizeOf(Addr)) = SOCKET_ERROR then
begin
Close;
Exit(False);
@@ -334,7 +362,7 @@ function TSocket.Connect(const Address: TAddressName; Port: Word): Boolean;
FState := ssClient;
if FSecure then
begin
- FSSLContext := SSL_CTX_new(SSLv23_client_method);
+ FSSLContext := SSL_CTX_new(TLS_client_method);
if FSSLContext = nil then
begin
Close;
@@ -346,16 +374,19 @@ function TSocket.Connect(const Address: TAddressName; Port: Word): Boolean;
Close;
Exit(False);
end;
- if not SSL_set_fd(FSSLSocket, FHandle) then
+ if Address.Host <> '' then
+ SSL_set_tlsext_host_name(FSSLSocket, PChar(Address.Host));
+ if SSL_set_fd(FSSLSocket, FHandle) <> 1 then
begin
Close;
Exit(False);
end;
- if not SSL_connect(FSSLSocket) then
+ if SSL_connect(FSSLSocket) <> 1 then
begin
Close;
Exit(False);
end;
+ FSSLConnected := True;
end;
if not FBlocking then
begin
@@ -371,7 +402,7 @@ function TSocket.Connect(const Address: TAddressName; Port: Word): Boolean;
function TSocket.Listen(const Address: TAddressName; Port: Word): Boolean;
var
- Addr: TSockAddrIn;
+ Addr: TSockAddr;
begin
Result := False;
Close;
@@ -400,7 +431,7 @@ function TSocket.Listen(const Address: TAddressName; Port: Word): Boolean;
end;
if not FAddress.Resolved then
FAddress := TAddressName.Create(Addr.sin_addr.s_addr);
- if Codebot.Interop.Sockets.listen(FHandle, SOMAXCONN) = SOCKET_ERROR then
+ if SockListen(FHandle, SOMAXCONN) = SOCKET_ERROR then
begin
Close;
Exit;
@@ -416,7 +447,7 @@ function TSocket.Listen(Port: Word): Boolean;
function TSocket.Accept(Socket: TSocket): Boolean;
var
- Addr: TSockAddrIn;
+ Addr: TSockAddr;
I: Integer;
H: TSocketHandle;
{$ifdef windows}
@@ -430,7 +461,7 @@ function TSocket.Accept(Socket: TSocket): Boolean;
if FState <> ssServer then
Exit;
I := SizeOf(Addr);
- H := Codebot.Interop.Sockets.accept(FHandle, @Addr, I);
+ H := SockAccept(FHandle, @Addr, I);
if H = INVALID_SOCKET then
Exit(False);
Socket.FHandle := H;
@@ -452,6 +483,13 @@ function TSocket.Accept(Socket: TSocket): Boolean;
Result := True;
end;
+function __errno_location: PInteger; cdecl; external 'c' name '__errno_location';
+
+function GetErrno: Integer;
+begin
+ Result := __errno_location^;
+end;
+
function TSocket.DoRead(var Buffer; BufferSize: LongWord): Integer;
var
Bytes: LongInt;
@@ -464,6 +502,12 @@ function TSocket.DoRead(var Buffer; BufferSize: LongWord): Integer;
Bytes := SSL_read(FSSLSocket, @Buffer, BufferSize)
else
Bytes := recv(FHandle, Buffer, BufferSize, 0);
+ if Bytes = -1 then
+ begin
+ ErrorCode := GetErrno;
+ WriteLn('recv error: ', ErrorCode);
+ Exit;
+ end;
if Bytes = 0 then
begin
Close;
@@ -487,6 +531,9 @@ function TSocket.Read(var Buffer; BufferSize: LongWord): Integer;
function TSocket.Read(out Text: string; BufferSize: LongWord = $10000): Integer;
begin
+ Text := '';
+ if BufferSize < 1 then
+ Exit;
SetLength(Text, BufferSize);
Result := Read(Pointer(Text)^, BufferSize);
if Result < 1 then
@@ -552,9 +599,87 @@ function TSocket.WriteAll(var Buffer; BufferSize: LongWord): Boolean;
Result := True;
end;
-function TSocket.WriteAll(const Text: string): Boolean;
+function TSocket.WriteText(const Text: string; Task: IAsyncTask = nil): Boolean;
+const
+ MaxSize = 1024 * 16;
+var
+ S: TStream;
+ I: LargeInt;
+begin
+ I := Length(Text);
+ if I > 0 then // MaxSize - 1 then
+ try
+ S := TStringStream.Create(Text);
+ Result := WriteStream(S, Task);
+ finally
+ S.Free;
+ end
+ else
+ Result := WriteAll(Pointer(Text)^, Length(Text));
+end;
+
+function TSocket.WriteFile(const FileName: string; Task: IAsyncTask = nil): Boolean;
+var
+ S: TStream;
begin
- Result := WriteAll(Pointer(Text)^, Length(Text));
+ S := TFileStream.Create(FileName, fmOpenRead);
+ try
+ Result := WriteStream(S, Task);
+ finally
+ S.Free;
+ end;
+end;
+
+var
+ BytesWritten: Integer;
+
+function TSocket.WriteStream(Stream: TStream; Task: IAsyncTask = nil): Boolean;
+
+ procedure DoProgress(Delta: Integer);
+ begin
+ if (Delta > 0) and (Task <> nil) then
+ (Task as IAsyncRunnerBase).Tick(Delta);
+ end;
+
+ function IsCancelled: Boolean;
+ begin
+ Result := (Task <> nil) and Task.Cancelled;
+ end;
+
+const
+ BufferSize = 1024 * 16;
+var
+ Buffer: Pointer;
+ S: string;
+ I: Integer;
+begin
+ BytesWritten := 0;
+ Result := False;
+ Buffer := GetMem(BufferSize);
+ try
+ while True do
+ begin
+ I := Stream.Read(Buffer^, BufferSize);
+ if I < 1 then
+ Exit(True);
+ //S := StrCopyData(Buffer, I);
+
+ BytesWritten := BytesWritten + I;
+ System.WriteLn('BytesWritten ', I);
+ System.WriteLn('Hash ', HashBuffer(hashMD5, Buffer^, I).AsHex);
+ if WriteAll(Buffer, I) then
+ begin
+ if IsCancelled then
+ Break
+ else
+ DoProgress(I);
+ end
+ else
+ Break;
+ end;
+ finally
+ FreeMem(Buffer);
+ end;
end;
function TSocket.GetAddress: TAddressName;
@@ -576,5 +701,21 @@ function TSocket.GetConnected: Boolean;
Result := FHandle <> INVALID_SOCKET;
end;
-end.
+function SocketSend(const Host: string; Port: Word; const Data: string): Boolean;
+var
+ S: TSocket;
+begin
+ Result := False;
+ S := TSocket.Create;
+ try
+ if S.Connect(Host, Port) then
+ begin
+ S.Write(Data);
+ Result := True;
+ end;
+ finally
+ S.Free;
+ end;
+end;
+end.
diff --git a/source/codebot/codebot.networking.storage.pas b/source/codebot/codebot.networking.storage.pas
new file mode 100644
index 0000000..8e83115
--- /dev/null
+++ b/source/codebot/codebot.networking.storage.pas
@@ -0,0 +1,1251 @@
+(********************************************************)
+(* *)
+(* Codebot Pascal Library *)
+(* http://cross.codebot.org *)
+(* Modified October 2023 *)
+(* *)
+(********************************************************)
+
+{ }
+unit Codebot.Networking.Storage;
+
+{$i codebot.inc}
+
+interface
+
+uses
+ Classes, SysUtils, DateUtils,
+ Codebot.System,
+ Codebot.Text,
+ Codebot.Text.Json,
+ Codebot.Text.Xml,
+ Codebot.Cryptography,
+ Codebot.Networking,
+ Codebot.Networking.Web;
+
+{ TS3Config }
+
+type
+ ES3ConfigError = class(Exception);
+
+ TS3Config = class
+ private
+ FNode: TJsonNode;
+ FProvider: string;
+ FHost: string;
+ FDefaultHost: string;
+ FPort: Word;
+ FService: string;
+ FDefaultRegion: string;
+ FAccessIdVar: string;
+ FAccessId: string;
+ FSecretKeyVar: string;
+ FSecretKey: string;
+ function GetAccessId: string;
+ function GetSecretKey: string;
+ public
+ constructor Create(const AProvider: string);
+ destructor Destroy; override;
+ function Provider: string;
+ function EndPoint(const Region: string = ''): string;
+ function Port: Word;
+ function DefaultRegion: string;
+ procedure ListRegions(out Regions: TNamedStrings);
+ property AccessId: string read GetAccessId write FAccessId;
+ property SecretKey: string read GetSecretKey write FSecretKey;
+ end;
+
+{ S3Configs provides some default S3 confiurations. These configurations are
+ not exhaustive. Feel free to define you own.
+
+ All methods conform to the TS3ConfigFactory prototype and can be used in the
+ contructor of a TS3Client.
+
+ Each configuration below depends on environment variables to store your S3
+ credentials. The following is a list of those environment variable names
+ you must have populated to use the these configurations.
+
+ AWS_ACCESS_KEY_ID and AWS_SECRET_ACCESS_KEY
+ DO_ACCESS_KEY_ID and DO_SECRET_ACCESS_KEY
+ GOOG_ACCESS_KEY_ID and GOOG_SECRET_ACCESS_KEY
+ IBM_ACCESS_KEY_ID and IBM_SECRET_ACCESS_KEY
+ MS_ACCESS_KEY_ID and MS_SECRET_ACCESS_KEY
+ WAS_ACCESS_KEY_ID and WAS_SECRET_ACCESS_KEY
+
+ If you prefer an alternate method for managing access keys you can simply
+ define your own functions which create TS3Config instances.
+
+ Note:
+
+ On Linux you can set these variables in your $HOME/.profile files using
+ code like this.
+
+ export AWS_ACCESS_KEY_ID =
+ export AWS_SECRET_ACCESS_KEY = }
+
+{ TS3Request includes the end point that will accept the request and a valid
+ http and authorized request header }
+
+ TS3Request = record
+ { End point that will accept the request }
+ EndPoint: string;
+ { Http request header }
+ Header: string;
+ end;
+
+{$region async}
+{ To perform async commands use an async task. You can use the task with the
+ SendAsync method. When send completes either through success, failure, or
+ cancellation OnComplete will notify you that the task is done. }
+
+ IAsyncDocTask = interface(IAsyncTask)
+ ['{387A116F-9D1F-400D-8CD7-31A0E1769418}']
+ end;
+
+ IAsyncStreamTask = interface(IAsyncTask)
+ ['{B915D4B9-4A84-400D-AF35-6E2CCE4B30CD}']
+ end;
+
+{ TNotifyComplete is used to notify of the result of an async task }
+
+ TNotifyDocComplete = procedure(Task: IAsyncTask; Result: IDocument) of object;
+ TNotifyStreamComplete = procedure(Task: IAsyncTask; Result: TStream) of object;
+
+{ NewDocTask creates an async task with an xml document result. You may optionally
+ supply the task with user data. If owns object is true then user data will be
+ destroyed when the task is destroyed. }
+
+function NewDocTask(OnComplete: TNotifyDocComplete; Data: TObject = nil; OwnsObject: Boolean = False): IAsyncDocTask;
+
+{ NewStreamTask creates an async task using a stream object. The steam will be
+ returned in the result of the completion event. The same rules apply to data
+ as described above with the addition that you are responsible for managing the
+ stream after completion. }
+
+function NewStreamTask(OnComplete: TNotifyStreamComplete; Data: TObject = nil; OwnsObject: Boolean = False): IAsyncStreamTask;
+{$endregion}
+
+type
+
+{ TS3Methods is used to generate S3 REST requests. It builds HTTP request headers
+ using an S3 compatible configuration providers. There are many S3 compatible
+ services and they each have their own end point and regions. When you sign
+ up with any S3 service they will provide you with access keys.
+
+ The headers generated by this class use the authorization version 4 signature
+ scheme to verify you are the authorized user for their service account.
+
+ Reference:
+
+ https://docs.aws.amazon.com/AmazonS3/latest/API/sig-v4-header-based-auth.html
+
+ Note:
+
+ You will need either set to valid access key environment variables for your
+ preferred S3 compatible service or define your own TS3ConfigFactory where
+ you can implement your own TS3KeyStore functions for retrieving access keys.
+
+ Bucket note:
+
+ Some requests require both a bucket and a region. If no region is given then
+ the default region for the configured S3 service will be used. This may
+ cause the request to be denied, so you might want to first retrieve and then
+ cache the bucket region using the GetBucketLocation request.
+
+ Example usage:
+
+ S3 := TS3Methods.Create(S3Config.Wasabi);
+ ...
+ Request := S3.ListBuckets;
+ if S3.Send(Request, Document) then
+ WriteLn(Document.Text); }
+
+ TS3Methods = class
+ private
+ FConfig: TS3Config;
+ FBuckets: TStrings;
+ function GetConfig: TS3Config;
+ function QueryBucket(const Bucket, Query: string): TS3Request;
+ public
+ constructor Create(const AProvider: string);
+ destructor Destroy; override;
+ { Reconfigure replaces the current config and erases bucket region memory }
+ procedure Reconfigure(const AProvider: string);
+ { Find a bucket's region directly and cache it in memory. If a bucket
+ region is unknown this method will block while a query is dispatched. }
+ function FindRegion(const Bucket: string): string;
+ { Add a bucket's region to the memory cache manually }
+ procedure AddRegion(const Bucket, Region: string);
+ {$region requests}
+ { Request to list all buckets }
+ function ListBuckets: TS3Request;
+ { Request to get bucket region. Due to legacy constraints a blank value
+ returned from from this request should be interrupted as us-east-1. }
+ function GetBucketLocation(const Bucket: string): TS3Request;
+ { Request to get bucket access control list }
+ function GetBucketAcl(const Bucket: string): TS3Request;
+ { Request to get bucket CORS }
+ function GetBucketCors(const Bucket: string): TS3Request;
+ { Request to get bucket policy }
+ function GetBucketPolicy(const Bucket: string): TS3Request;
+ { Request to get bucket request payment }
+ function GetBucketRequestPayment(const Bucket: string): TS3Request;
+ { Request to get bucket tagging }
+ function GetBucketTagging(const Bucket: string): TS3Request;
+ { Request to get bucket versioning }
+ function GetBucketVersioning(const Bucket: string): TS3Request;
+ { Request to get bucket website }
+ function GetBucketWebsite(const Bucket: string): TS3Request;
+ { Request to list bucket objects }
+ function ListObjects(const Bucket: string; NextToken: string = '';
+ Prefix: string = ''; Delimiter: string = ''): TS3Request;
+ {$endregion}
+ {$region send}
+ { Gnerate a presigned url for public access to an object }
+ function Presign(const Bucket, Path: string; Expires: Integer = 0): string;
+ { Send a request to your S3 servers outputting the response to a XML
+ document. Returns true if the status code is 200 OK.
+
+ First overload can be used when querying or sending commands to S3
+ Second overload can be used when receving files from S3 }
+ function Send(const Request: TS3Request; out Response: IDocument): Boolean; overload;
+ function Send(const Request: TS3Request; Stream: TStream): Boolean; overload;
+ { SendAsync is identical to the method Send above but performed
+ asynchronously.
+
+ When sending an async request the task status will be success if the
+ response status is 200 OK. The completion notification will receive either
+ a response document or a stream as the result argument.
+
+ Failure to provide a completion notification will cause then response
+ document or stream to be discarded. When using the stream variant you
+ might want to free the stream upon completion.
+
+ Example usage:
+
+ procedure ListingComplete(Task: IAsyncTask; Result: IDocument);
+ begin
+ if Task.Status = asyncSuccess then
+ WriteLn(Result.Xml);
+ end;
+
+ Request := S3.ListObjects(Bucket);
+ Task := NewDocTask(ListingComplete);
+ S3.SendAsync(Request, Task); }
+ procedure SendAsync(const Request: TS3Request; Task: IAsyncDocTask); overload;
+ procedure SendAsync(const Request: TS3Request; Stream: TStream; Task: IAsyncStreamTask); overload;
+ {$endregion}
+ property Config: TS3Config read GetConfig;
+ end;
+
+implementation
+
+uses
+ Codebot.Support;
+
+const
+ DefPort = 443;
+
+var
+ InternalServiceRegions: TObject;
+
+function ServiceRegions: TJsonNode;
+const
+ CDN = 'https://cdn.jsdelivr.net/gh/sysrpl/s3.regions/services.js';
+var
+ N: TJsonNode;
+ S: string;
+begin
+ if InternalServiceRegions = nil then
+ begin
+ N := TJsonNode.Create;
+ if WebGet(CDN, S) then
+ N.Parse(S);
+ InternalServiceRegions := N;
+ end;
+ Result := TJsonNode(InternalServiceRegions);
+end;
+
+constructor TS3Config.Create(const AProvider: string);
+begin
+ inherited Create;
+ FProvider := AProvider;
+ if ServiceRegions.Find(AProvider, FNode) then
+ begin
+ FHost := FNode.Force('host').AsString;
+ FDefaultHost := FNode.Force('defaultHost').AsString;
+ FService := FNode.Force('service').AsString;
+ FPort := Round(FNode.Force('port').AsNumber);
+ if FPort = 0 then
+ FPort := DefPort;
+ FDefaultRegion := FNode.Force('defaultRegion').AsString;
+ FAccessIdVar := FNode.Force('accessId').AsString;
+ FSecretKeyVar := FNode.Force('secretKey').AsString;
+ end
+ else
+ begin
+ if FProvider = '' then
+ FProvider := '(empty string)';
+ raise ES3ConfigError.CreateFmt('Provider %s not found', [FProvider]);
+ end;
+end;
+
+destructor TS3Config.Destroy;
+begin
+ FNode.Free;
+ inherited Destroy;
+end;
+
+function TS3Config.Provider: string;
+begin
+ Result := FProvider;
+end;
+
+function TS3Config.EndPoint(const Region: string = ''): string;
+var
+ S: string;
+begin
+ S := Region;
+ if S = '' then
+ Result := FDefaultHost
+ else if FService <> '' then
+ Result := FService + '.' + S + '.' + FHost
+ else
+ Result := S + '.' + FHost;
+end;
+
+function TS3Config.Port: Word;
+begin
+ Result := FPort;
+end;
+
+function TS3Config.DefaultRegion: string;
+begin
+ Result := FDefaultRegion;
+end;
+
+procedure TS3Config.ListRegions(out Regions: TNamedStrings);
+var
+ N: TJsonNode;
+begin
+ for N in FNode.Force('regions').AsArray do
+ Regions.Add(N.Force('name').AsString, N.Force('value').AsString);
+end;
+
+function TS3Config.GetAccessId: string;
+begin
+ if FAccessId = '' then
+ FAccessId := GetEnvironmentVariable(FAccessIdVar);
+ Result := FAccessId;
+end;
+
+function TS3Config.GetSecretKey: string;
+begin
+ if FSecretKey = '' then
+ FSecretKey := GetEnvironmentVariable(FSecretKeyVar);
+ Result := FSecretKey;
+end;
+
+{
+function DOPub: string; begin Result := GetEnvironmentVariable('DO_ACCESS_KEY_ID'); end;
+function DOPriv: string; begin Result := GetEnvironmentVariable('DO_ACCESS_KEY'); end;
+
+class function S3Configs.DigitalOcean: TS3Config;
+begin
+ Result := TS3Config.Create('nyc3.digitaloceanspaces.com', 'nyc3', DOPub, DOPriv);
+end;
+
+function GOOGPub: string; begin Result := GetEnvironmentVariable('GOOG_ACCESS_KEY_ID'); end;
+function GOOGPriv: string; begin Result := GetEnvironmentVariable('GOOG_SECRET_ACCESS_KEY'); end;
+
+class function S3Configs.Google: TS3Config;
+begin
+ Result := TS3Config.Create('storage.googleapis.com', 'us-east-1', GOOGPub, GOOGPriv);
+end;
+
+function IBMPub: string; begin Result := GetEnvironmentVariable('IBM_ACCESS_KEY_ID'); end;
+function IBMPriv: string; begin Result := GetEnvironmentVariable('IBM_SECRET_ACCESS_KEY'); end;
+
+class function S3Configs.IBM: TS3Config;
+begin
+ Result := TS3Config.Create('cloud-object-storage.appdomain.cloud', 'us-east', IBMPub, IBMPriv);
+end;
+
+function MSPub: string; begin Result := GetEnvironmentVariable('MS_ACCESS_KEY_ID'); end;
+function MSPriv: string; begin Result := GetEnvironmentVariable('MS_SECRET_ACCESS_KEY'); end;
+
+class function S3Configs.Microsoft: TS3Config;
+begin
+ Result := TS3Config.Create('blob.core.windows.net', 'unknown', MSPub, MSPriv);
+end;
+
+function WASPub: string; begin Result := GetEnvironmentVariable('WAS_ACCESS_KEY_ID'); end;
+function WASPriv: string; begin Result := GetEnvironmentVariable('WAS_SECRET_ACCESS_KEY'); end;
+
+class function S3Configs.Wasabi: TS3Config;
+begin
+ Result := TS3Config.Create('s3.wasabisys.com', 'us-east-1', WASPub, WASPriv);
+end;}
+
+{ THeaderPair }
+
+type
+ THeaderPair = class
+ Name: string;
+ Value: string;
+ end;
+
+{ THeaderPairs }
+
+ THeaderPairs = class
+ private
+ FList: TList;
+ FSorted: Boolean;
+ function GetCount: Integer;
+ function GetItem(Index: Integer): THeaderPair;
+ procedure Sort;
+ public
+ constructor Create;
+ destructor Destroy; override;
+ procedure Clear;
+ function Add(const Name, Value: string): THeaderPairs;
+ function Names: string;
+ property Items[Index: Integer]: THeaderPair read GetItem; default;
+ property Count: Integer read GetCount;
+ end;
+
+{ THeaderPairs }
+
+constructor THeaderPairs.Create;
+begin
+ inherited Create;
+ FList := TList.Create;
+ FSorted := True;
+end;
+
+destructor THeaderPairs.Destroy;
+begin
+ Clear;
+ FList.Free;
+ inherited Destroy;
+end;
+
+procedure THeaderPairs.Clear;
+var
+ I: Integer;
+begin
+ for I := 0 to FList.Count - 1 do
+ TObject(FList[I]).Free;
+ FList.Clear;
+ FSorted := True;
+end;
+
+function HeaderCompare(Item1, Item2: Pointer): Integer;
+var
+ A: THeaderPair absolute Item1;
+ B: THeaderPair absolute Item2;
+begin
+ Result := StrCompare(A.Name, B.Name, True);
+end;
+
+procedure THeaderPairs.Sort;
+begin
+ if FSorted then
+ Exit;
+ FSorted := True;
+ if FList.Count > 1 then
+ FList.Sort(HeaderCompare);
+end;
+
+function THeaderPairs.Add(const Name, Value: string): THeaderPairs;
+var
+ Item: THeaderPair;
+begin
+ Item := THeaderPair.Create;
+ Item.Name := Trim(Name);
+ Item.Value := Trim(Value);
+ FList.Add(Item);
+ FSorted := FList.Count < 2;
+ Result := Self;
+end;
+
+function THeaderPairs.Names: string;
+var
+ I: Integer;
+begin
+ Result := '';
+ Sort;
+ if FList.Count < 1 then
+ Exit;
+ Result := LowerCase(THeaderPair(FList[0]).Name);
+ for I := 1 to FList.Count - 1 do
+ Result := Result + ';' + LowerCase(THeaderPair(FList[I]).Name)
+end;
+
+function THeaderPairs.GetCount: Integer;
+begin
+ Result := FList.Count;
+end;
+
+function THeaderPairs.GetItem(Index: Integer): THeaderPair;
+begin
+ Sort;
+ Result := THeaderPair(FList[Index]);
+end;
+
+{ GenerateRequest does all the work of generating a valid AWS S3 request with
+ proper version 4 authentication. }
+
+const
+ NoContent = 'e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855';
+ Service = 's3';
+ Version = 'aws4_request';
+
+function NowUTC: TDateTime;
+begin
+ Result := LocalTimeToUniversal(Now);
+end;
+
+function NewHeaders(Name: string = ''; Value: string = ''): THeaderPairs;
+begin
+ Result := THeaderPairs.Create;
+ if Name <> '' then
+ if Value <> '' then
+ Result.Add(Name, Value);
+end;
+
+function UriEncode(const S: string): string;
+var
+ I: Integer;
+begin
+ Result := '';
+ for I := 1 to Length(S) do
+ if S[I] in ['A'..'Z', 'a'..'z', '0'..'9', '-', '_', '.', '~'] then
+ Result := Result + S[I]
+ else
+ Result := Result + '%' + IntToHex(Ord(S[I]), 2);
+end;
+
+function UrlEncode(const S: string): string;
+var
+ I: Integer;
+begin
+ Result := '';
+ for I := 1 to Length(S) do
+ if S[I] in ['A'..'Z', 'a'..'z', '0'..'9', '-', '_', '.', '~', '/'] then
+ Result := Result + S[I]
+ else
+ Result := Result + '%' + IntToHex(Ord(S[I]), 2);
+end;
+
+{ Note: Query parameters should be UriEncode'd before they are sent to GenerateRequest }
+
+function QueryEncode(Query: string): string;
+var
+ List: TStringList;
+ S: string;
+ I: Integer;
+begin
+ Result := '';
+ if Query = '' then
+ Exit;
+ List := TStringList.Create;
+ try
+ for S in Query.Split('&') do
+ List.Add(S);
+ List.Sorted := True;
+ S := List[0];
+ Result := S.FirstOf('=') + '=' + S.SecondOf('=');
+ for I := 1 to List.Count - 1 do
+ begin
+ S := List[I];
+ Result := Result + '&' + S.FirstOf('=') + '=' + S.SecondOf('=');
+ end;
+ finally
+ List.Free;
+ end;
+end;
+
+function GenerateRequest(Config: TS3Config; const Region, Verb: string; Url: TUrl; Headers: THeaderPairs = nil): string;
+var
+ Date: TDateTime;
+ DateShort: string;
+ DateLong: string;
+ Resource: string;
+ Query: string;
+ Request: string;
+ CanonicalRequest: string;
+ StringToSign: string;
+ Signature: string;
+ I: Integer;
+begin
+ if Headers = nil then
+ Headers := NewHeaders;
+ try
+ Date := NowUTC;
+ DateShort := FormatDateTime('yyyymmdd', Date);
+ DateLong := DateShort + 'T' + FormatDateTime('hhnnss', Date) + 'Z';
+ Resource := Url.Resource.FirstOf('?');
+ Query := QueryEncode(Url.Resource.SecondOf('?'));
+ Headers
+ .Add('Host', Url.Domain)
+ .Add('X-Amz-Content-Sha256', NoContent)
+ .Add('X-Amz-Date', DateLong);
+ CanonicalRequest :=
+ Verb + #10 +
+ Resource + #10 +
+ Query + #10;
+ for I := 0 to Headers.Count - 1 do
+ with Headers[I] do
+ CanonicalRequest := CanonicalRequest + LowerCase(Name) + ':' + Value + #10;
+ CanonicalRequest := CanonicalRequest + #10 +
+ Headers.Names + #10 +
+ NoContent;
+ StringToSign :=
+ 'AWS4-HMAC-SHA256'#10 +
+ DateLong + #10 +
+ DateShort +
+ '/' + Region +
+ '/' + Service +
+ '/' + Version + #10 +
+ HashString(hashSHA256, CanonicalRequest).AsHex;
+ Signature :=
+ AuthString('AWS4' + Config.SecretKey, hashSHA256, DateShort)
+ .AuthNext(hashSHA256, Region)
+ .AuthNext(hashSHA256, Service)
+ .AuthNext(hashSHA256, Version)
+ .AuthNext(hashSHA256, StringToSign)
+ .AsHex;
+ Request :=
+ Verb + ' ' + Url.Resource + ' HTTP/1.1'#13#10;
+ for I := 0 to Headers.Count - 1 do
+ with Headers[I] do
+ Request := Request + Name + ': ' + Value + #13#10;
+ Request := Request + 'Authorization: ' +
+ 'AWS4-HMAC-SHA256 Credential=' + Config.AccessId +
+ '/' + DateShort +
+ '/' + Region +
+ '/' + Service +
+ '/' + Version +
+ ', SignedHeaders=' + Headers.Names +
+ ', Signature=' + Signature + #13#10 +
+ 'Connection: Close'#13#10 +
+ #13#10;
+ Result := Request;
+ finally
+ Headers.Free;
+ end;
+end;
+
+function GenerateUrl(Config: TS3Config; Url: TUrl; Region: string; Expires: Integer = 0): string;
+const
+ Week = 3600 * 24 * 7;
+var
+ Date: TDateTime;
+ DateLong: string;
+ DateShort: string;
+ Host: string;
+ Resource: string;
+ Seconds: string;
+ CanonicalRequest: string;
+ StringToSign: string;
+ Signature: string;
+begin
+ Date := NowUTC;
+ DateShort := FormatDateTime('yyyymmdd', Date);
+ DateLong := DateShort + 'T' + FormatDateTime('hhnnss', Date) + 'Z';
+ Host := Url.Domain;
+ Resource := Url.Resource;
+ if Expires < 1 then
+ Expires := Week;
+ Seconds := IntToStr(Expires);
+ CanonicalRequest :=
+ 'GET'#10 +
+ Resource + #10 +
+ 'X-Amz-Algorithm=AWS4-HMAC-SHA256&X-Amz-Credential=AKIAJ25NK7ETIMG7CGRQ' +
+ UriEncode('/' + DateShort + '/' + Region + '/s3/aws4_request') +
+ '&X-Amz-Date=' + DateLong + '&X-Amz-Expires=' + Seconds + '&X-Amz-SignedHeaders=host'#10 +
+ 'host:' + Host + #10 +
+ #10 +
+ 'host'#10 +
+ 'UNSIGNED-PAYLOAD';
+ StringToSign :=
+ 'AWS4-HMAC-SHA256'#10 +
+ DateLong + #10 +
+ DateShort + '/' + Region + '/s3/aws4_request'#10 +
+ HashString(hashSHA256, CanonicalRequest).AsHex;
+ Signature :=
+ AuthString('AWS4' + Config.SecretKey, hashSHA256, DateShort)
+ .AuthNext(hashSHA256, Region)
+ .AuthNext(hashSHA256, Service)
+ .AuthNext(hashSHA256, Version)
+ .AuthNext(hashSHA256, StringToSign)
+ .AsHex;
+ Result := 'https://' + Host;
+ if Config.Port <> DefPort then
+ Result := Result + ':' + IntToStr(Config.Port);
+ Result := Result + Resource +
+ '?X-Amz-Algorithm=AWS4-HMAC-SHA256&X-Amz-Credential=' + Config.AccessId +
+ UriEncode('/' + DateShort + '/' + Region + '/s3/aws4_request') +
+ '&X-Amz-Date=' + DateLong + '&X-Amz-Expires=' + Seconds + '&X-Amz-SignedHeaders=host'#10 +
+ '&X-Amz-Signature=' + Signature;
+end;
+
+function GenerateUrlSHA1(Config: TS3Config; Url: TUrl; Expires: Integer = 0): string;
+var
+ UnixTime: Int64;
+ StringToSign: string;
+ Signature: string;
+begin
+ if Expires < 1 then
+ Expires := 3600;
+ UnixTime := DateTimeToUnix(NowUTC) + Expires;
+ StringToSign := 'GET'#10#10#10 + IntToStr(UnixTime) + #10 + UrlEncode(Url.Resource);
+ Signature := AuthString(Config.SecretKey, hashSHA1, StringToSign).AsBase64;
+ Result := Url.AsString + Format('?AWSAccessKeyId=%s&Expires=%s&Signature=%s',
+ [Config.AccessId, IntToStr(UnixTime), UriEncode(Signature)]);
+end;
+
+{ TS3Methods }
+
+constructor TS3Methods.Create(const AProvider: string);
+begin
+ inherited Create;
+ FConfig := TS3Config.Create(AProvider);
+ FBuckets := TStringList.Create;
+end;
+
+destructor TS3Methods.Destroy;
+begin
+ FBuckets.Free;
+ FConfig.Free;
+ inherited Destroy;
+end;
+
+function TS3Methods.GetConfig: TS3Config;
+begin
+ Result := FConfig;
+end;
+
+procedure TS3Methods.Reconfigure(const AProvider: string);
+begin
+ FBuckets.Free;
+ FConfig.Free;
+ FBuckets := TStringList.Create;
+ FConfig := TS3Config.Create(AProvider);
+end;
+
+{$region bucket read}
+function TS3Methods.QueryBucket(const Bucket, Query: string): TS3Request;
+var
+ Region: string;
+begin
+ if Query = 'location' then
+ Region := FConfig.DefaultRegion
+ else
+ Region := FindRegion(Bucket);
+ Result.EndPoint := FConfig.EndPoint(Region);
+ Result.Header := GenerateRequest(FConfig, Region, 'GET', FConfig.EndPoint(Region) +
+ '/' + Bucket +
+ '?' + Query);
+end;
+
+function TS3Methods.FindRegion(const Bucket: string): string;
+var
+ Request: TS3Request;
+ D: IDocument;
+ I: Integer;
+begin
+ Result := '';
+ I := FBuckets.IndexOf(UpperCase(Bucket));
+ if I < 0 then
+ begin
+ Request.EndPoint := FConfig.EndPoint;
+ Request.Header := GenerateRequest(FConfig, FConfig.DefaultRegion, 'GET',
+ FConfig.EndPoint + '/' + Bucket + '?location');
+ if Send(Request, D) then
+ begin
+ Result := D.Root.Text;
+ if Result = '' then
+ Result := FConfig.DefaultRegion;
+ FBuckets.Add(UpperCase(Bucket));
+ FBuckets.Add(Result);
+ end;
+ end
+ else
+ Result := FBuckets[I + 1];
+ if Result = '' then
+ Result := FConfig.DefaultRegion;
+end;
+
+procedure TS3Methods.AddRegion(const Bucket, Region: string);
+var
+ I: Integer;
+begin
+ I := FBuckets.IndexOf(UpperCase(Bucket));
+ if I < 0 then
+ begin
+ FBuckets.Add(UpperCase(Bucket));
+ if Region <> '' then
+ FBuckets.Add(Region)
+ else
+ FBuckets.Add(FConfig.DefaultRegion);
+ end;
+end;
+
+function TS3Methods.ListBuckets: TS3Request;
+begin
+ Result.EndPoint := FConfig.EndPoint;
+ Result.Header := GenerateRequest(FConfig, FConfig.DefaultRegion, 'GET', Result.EndPoint);
+end;
+
+function TS3Methods.GetBucketLocation(const Bucket: string): TS3Request;
+begin
+ Result := QueryBucket(Bucket, 'location');
+end;
+
+function TS3Methods.GetBucketAcl(const Bucket: string): TS3Request;
+begin
+ Result := QueryBucket(Bucket, 'acl');
+end;
+
+function TS3Methods.GetBucketCors(const Bucket: string): TS3Request;
+begin
+ Result := QueryBucket(Bucket, 'cors');
+end;
+
+function TS3Methods.GetBucketPolicy(const Bucket: string): TS3Request;
+begin
+ Result := QueryBucket(Bucket, 'policy');
+end;
+
+function TS3Methods.GetBucketRequestPayment(const Bucket: string): TS3Request;
+begin
+ Result := QueryBucket(Bucket, 'requestPayment');
+end;
+
+function TS3Methods.GetBucketTagging(const Bucket: string): TS3Request;
+begin
+ Result := QueryBucket(Bucket, 'tagging');
+end;
+
+function TS3Methods.GetBucketVersioning(const Bucket: string): TS3Request;
+begin
+ Result := QueryBucket(Bucket, 'versioning');
+end;
+
+function TS3Methods.GetBucketWebsite(const Bucket: string): TS3Request;
+begin
+ Result := QueryBucket(Bucket, 'website');
+end;
+
+function TS3Methods.ListObjects(const Bucket: string; NextToken: string = '';
+ Prefix: string = ''; Delimiter: string = ''): TS3Request;
+var
+ Query: string;
+begin
+ Query := 'list-type=2&encoding-type=url';
+ if Delimiter <> '' then
+ Query := Query + '&delimiter=' + UriEncode(Delimiter);
+ if Prefix <> '' then
+ Query := Query + '&prefix=' + UriEncode(Prefix);
+ if NextToken <> '' then
+ Query := Query + '&continuation-token=' + UriEncode(NextToken);
+ Result := QueryBucket(Bucket, Query);
+end;
+{$endregion}
+
+{$region send}
+function TS3Methods.Presign(const Bucket, Path: string; Expires: Integer = 0): string;
+var
+ Region: string;
+ Url: string;
+begin
+ Region := FindRegion(Bucket);
+ Url := 'https://' + FConfig.EndPoint(Region);
+ if FConfig.Port <> DefPort then
+ Url := Url + ':' + IntToStr(FConfig.Port);
+ Url := Url + '/' + Bucket + '/' + UrlEncode(Path);
+ Result := GenerateUrl(FConfig, Url, Region, Expires);
+end;
+
+type
+ TReadBuffer = class
+ FSocket: TSocket;
+ FBuffer: string;
+ FIndex: Integer;
+ FLength: Integer;
+ public
+ procedure Reset(Socket: TSocket; Buffer: string);
+ function Read(var Buffer; BufferSize: LongWord): Integer; overload;
+ function Read(out Text: string): Integer; overload;
+ end;
+
+procedure TReadBuffer.Reset(Socket: TSocket; Buffer: string);
+begin
+ FSocket := Socket;
+ FBuffer := Buffer;
+ FIndex := 1;
+ FLength := Length(FBuffer);
+end;
+
+function TReadBuffer.Read(var Buffer; BufferSize: LongWord): Integer;
+var
+ B: PByte;
+begin
+ if FLength > 0 then
+ begin
+ Result := 0;
+ B := PByte(@Buffer);
+ while (FLength > 0) and (BufferSize > 0) do
+ begin
+ B^ := Byte(FBuffer[FIndex]);
+ Inc(FIndex);
+ Dec(FLength);
+ Dec(BufferSize);
+ Inc(Result);
+ end;
+ end
+ else
+ Result := FSocket.Read(Buffer, BufferSize);
+end;
+
+function TReadBuffer.Read(out Text: string): Integer; overload;
+var
+ P: PChar;
+begin
+ if FLength > 0 then
+ begin
+ P := PChar(FBuffer);
+ Inc(P, FIndex - 1);
+ Text := P^;
+ Result := FLength;
+ FLength := 0;
+ end
+ else
+ Result := FSocket.Read(Text);
+end;
+
+function InternalSend(const Request: TS3Request; Port: Word; Stream: TStream; Task: IAsyncDocTask = nil): Boolean;
+
+ procedure DoProgress(Delta: Int64);
+ begin
+ if (Delta > 0) and (Task <> nil) then
+ (Task as IAsyncRunnerBase).Tick(Delta);
+ end;
+
+ function IsCancelled: Boolean;
+ begin
+ Result := (Task <> nil) and Task.Cancelled;
+ end;
+
+ function ReadChunk(S: TReadBuffer; Chunk: string): string;
+ var
+ Buffer: string;
+ P: PChar;
+ I, J: Integer;
+ begin
+ Result := '';
+ if IsCancelled then
+ Exit;
+ Chunk := '$' + Chunk;
+ I := StrToIntDef(Chunk, 0);
+ if I = 0 then
+ Exit;
+ SetLength({%H-}Buffer, I);
+ P := PChar(Buffer);
+ while I > 0 do
+ begin
+ if IsCancelled then
+ Exit;
+ J := S.Read(P^, LongWord(I));
+ if J = 0 then
+ Exit;
+ DoProgress(J);
+ Inc(P, J);
+ Dec(I, J);
+ end;
+ Result := Buffer;
+ end;
+
+ procedure ErrorNoConnect;
+ var
+ D: IDocument;
+ F: IFiler;
+ S: string;
+ begin
+ D := NewDocument;
+ F := D.Force('Error').Filer;
+ F.WriteStr('Kind', 'No Connect');
+ F.WriteStr('Message', 'Could not connect to ' + Request.EndPoint + ':' + IntToStr(Port));
+ S := D.Xml;
+ Stream.Write(PChar(S)^, Length(S));
+ end;
+
+ procedure ErrorNoWrite(ErrorCode: Integer);
+ var
+ D: IDocument;
+ F: IFiler;
+ S: string;
+ begin
+ D := NewDocument;
+ F := D.Force('Error').Filer;
+ if ErrorCode = 0 then
+ begin
+ F.WriteStr('Kind', 'No Header');
+ F.WriteStr('Message', 'No response hreader received');
+ end
+ else
+ begin
+ F.WriteStr('Kind', 'Error Code');
+ F.WriteStr('Message', 'Recevied ' + IntToStr(ErrorCode) + ' response error');
+ end;
+ S := D.Xml;
+ Stream.Write(PChar(S)^, Length(S));
+ end;
+
+var
+ Header: THttpResponseHeader;
+ Buffer, Data, Encoding, Chunk: string;
+ Connected, Read, Written: Boolean;
+ ErrorCode: Integer;
+ Socket: TSocket;
+ ReadBuffer: TReadBuffer;
+ C: Char;
+begin
+ Result := False;
+ Header.Clear;
+ Buffer := '';
+ Connected := False;
+ Read := False;
+ Written := False;
+ ErrorCode := 0;
+ Socket := TSocket.Create;
+ ReadBuffer := TReadBuffer.Create;
+ try
+ Socket.Secure := True;
+ if Socket.Connect(Request.EndPoint, Port) then
+ begin
+ Connected := True;
+ if IsCancelled then
+ Exit;
+ Socket.Write(Request.Header);
+ while not Read do
+ while Socket.Read(Data) > 0 do
+ begin
+ Read := True;
+ Buffer := Buffer + Data;
+ if Header.Extract(Buffer) then
+ begin
+ ReadBuffer.Reset(Socket, Buffer);
+ ErrorCode := Header.Code;
+ Result := ErrorCode = 200;
+ Encoding := Header.Keys.Values['Transfer-Encoding'];
+ if StrContains(Encoding, 'chunked', True) then
+ repeat
+ Chunk := '';
+ if IsCancelled then
+ Exit;
+ while ReadBuffer.Read({%H-}C, 1) = 1 do
+ begin
+ if IsCancelled then
+ Exit;
+ if (C = #10) and (Chunk <> '') then
+ begin
+ Data := ReadChunk(ReadBuffer, Chunk);
+ if IsCancelled then
+ Exit;
+ Chunk := '';
+ if Length(Data) < 1 then
+ Break;
+ Written := True;
+ Stream.Write(Pointer(Data)^, Length(Data));
+ end
+ else if C > ' ' then
+ Chunk := Chunk + C;
+ end;
+ until Chunk = ''
+ else while ReadBuffer.Read(Data) > 0 do
+ begin
+ if IsCancelled then
+ Exit;
+ DoProgress(Length(Data));
+ Written := True;
+ Stream.Write(Pointer(Data)^, Length(Data));
+ end;
+ Break;
+ end;
+ end;
+ end;
+ finally
+ ReadBuffer.Free;
+ Socket.Free;
+ if IsCancelled then
+ Result := False;
+ end;
+ if not Result then
+ if not Connected then
+ ErrorNoConnect
+ else if not Written then
+ ErrorNoWrite(ErrorCode);
+end;
+
+procedure ResponseCodes(Status: TResponseStatus; out Name: string; var Code: Integer);
+const
+ ResponseNames: array[TResponseStatus] of string = (
+ 'Could not connect',
+ 'No response recevied',
+ 'Error',
+ 'OK',
+ 'Cancelled');
+begin
+ Name := ResponseNames[Status];
+ if Status <> rsSuccess then
+ if Status = rsError then
+ case Code of
+ 200: Name := 'OK';
+ 201: Name := 'Created';
+ 202: Name := 'Accepted';
+ 204: Name := 'No Content';
+ 301: Name := 'Moved Permanently';
+ 302: Name := 'Found';
+ 304: Name := 'Not Modified';
+ 400: Name := 'Bad Request';
+ 401: Name := 'Unauthorized';
+ 403: Name := 'Forbidden';
+ 404: Name := 'Not Found';
+ 500: Name := 'Internal Server Error';
+ 502: Name := 'Bad Gateway';
+ end
+ else
+ Code := 0;
+end;
+
+function InternalDoc(const Body: string; Status: TResponseStatus; Code: Integer): IDocument;
+const
+ Xmlns = ' xmlns="http://s3.amazonaws.com/doc/2006-03-01/"';
+var
+ Name: string;
+ F: IFiler;
+begin
+ Result := NewDocument;
+ if Body.BeginsWith(' rsSuccess then
+ begin
+ F := Result.Root.Force('ResponseStatus').Filer;
+ ResponseCodes(Status, Name, Code);
+ F.WriteStr('Name', Name);
+ F.WriteInt('Code', Code);
+ end;
+end;
+
+function TS3Methods.Send(const Request: TS3Request; out Response: IDocument): Boolean;
+var
+ ResponseHeader: THttpResponseHeader;
+ Body: string;
+ Status: TResponseStatus;
+begin
+ Status := WebSendRequest('https://' + Request.EndPoint + ':' + IntToStr(FConfig.Port),
+ Request.Header, Body, ResponseHeader);
+ Response := InternalDoc(Body, Status, ResponseHeader.Code);
+ Result := Status = rsSuccess;
+end;
+
+function TS3Methods.Send(const Request: TS3Request; Stream: TStream): Boolean;
+var
+ ResponseHeader: THttpResponseHeader;
+ Status: TResponseStatus;
+begin
+ Status := WebSendRequest('https://' + Request.EndPoint + ':' + IntToStr(FConfig.Port),
+ Request.Header, Stream, ResponseHeader);
+ Result := Status = rsSuccess;
+end;
+
+{ Async support }
+
+type
+ TAsyncParams = record
+ Request: TS3Request;
+ Port: Word;
+ Success: Boolean;
+ Result: T;
+ end;
+
+ TAsyncDocParams = TAsyncParams;
+ TAsyncStreamParams = TAsyncParams;
+
+ TAsyncDocTask = class(TAsyncTaskRunner, IAsyncDocTask) end;
+ TAsyncStreamTask = class(TAsyncTaskRunner, IAsyncStreamTask) end;
+
+function NewDocTask(OnComplete: TNotifyDocComplete; Data: TObject = nil; OwnsObject: Boolean = False): IAsyncDocTask;
+begin
+ Result := TAsyncDocTask.Create(OnComplete, Data, OwnsObject);
+end;
+
+function NewStreamTask(OnComplete: TNotifyStreamComplete; Data: TObject = nil; OwnsObject: Boolean = False): IAsyncStreamTask;
+begin
+ Result := TAsyncStreamTask.Create(OnComplete, Data, OwnsObject);
+end;
+
+procedure DocExecute(var Params: TAsyncDocParams; Task: IAsyncTask);
+var
+ ResponseHeader: THttpResponseHeader;
+ Body: string;
+ Status: TResponseStatus;
+begin
+ Status := WebSendRequest('https://' + Params.Request.EndPoint + ':' +
+ IntToStr(Params.Port), Params.Request.Header, Body, ResponseHeader, Task);
+ Params.Result := InternalDoc(Body, Status, ResponseHeader.Code);
+ Params.Success := Status = rsSuccess;
+end;
+
+procedure DocComplete(var Params: TAsyncDocParams; Task: IAsyncTask);
+var
+ Runner: IAsyncRunner;
+begin
+ Runner := Task as IAsyncRunner;
+ Runner.Notify(BoolAsync[Params.Success], Params.Result);
+end;
+
+procedure TS3Methods.SendAsync(const Request: TS3Request; Task: IAsyncDocTask);
+var
+ Params: TAsyncDocParams;
+begin
+ Params.Request := Request;
+ Params.Port := FConfig.Port;
+ TThreadRunner.Create(Params, Task, DocExecute, DocComplete);
+end;
+
+procedure StreamExecute(var Params: TAsyncStreamParams; Task: IAsyncTask);
+begin
+ Params.Success := InternalSend(Params.Request, Params.Port, Params.Result, Task as IAsyncDocTask);
+end;
+
+procedure StreamComplete(var Params: TAsyncStreamParams; Task: IAsyncTask);
+var
+ Runner: IAsyncRunner;
+begin
+ Runner := Task as IAsyncRunner;
+ Runner.Notify(BoolAsync[Params.Success], Params.Result);
+end;
+
+procedure TS3Methods.SendAsync(const Request: TS3Request; Stream: TStream; Task: IAsyncStreamTask);
+var
+ Params: TAsyncStreamParams;
+begin
+ Params.Request := Request;
+ Params.Port := FConfig.Port;
+ Params.Result := Stream;
+ TThreadRunner.Create(Params, Task, StreamExecute, StreamComplete);
+end;
+{$endregion}
+
+initialization
+ InternalServiceRegions := nil;
+finalization
+ InternalServiceRegions.Free;
+end.
+
diff --git a/source/codebot/codebot.networking.unix.pas b/source/codebot/codebot.networking.unix.pas
new file mode 100644
index 0000000..4e7d75e
--- /dev/null
+++ b/source/codebot/codebot.networking.unix.pas
@@ -0,0 +1,123 @@
+(********************************************************)
+(* *)
+(* Codebot Pascal Library *)
+(* http://cross.codebot.org *)
+(* Modified March 2019 *)
+(* *)
+(********************************************************)
+
+{ }
+unit Codebot.Networking.Unix;
+
+{$i codebot.inc}
+
+interface
+
+uses
+ Codebot.System,
+ Codebot.Interop.Sockets;
+
+{ TUnixClientSocket }
+
+type
+ TUnixClientSocket = class(TObject)
+ private
+ FHandle: TSocketHandle;
+ FFileName: string;
+ function GetConnected: Boolean;
+ procedure SetConnected(Value: Boolean);
+ procedure SetFileName(Value: string);
+ public
+ constructor Create;
+ destructor Destroy; override;
+ procedure Connect;
+ procedure Disconnect;
+ function Read(var Buffer; BufferSize: LongWord): Integer; overload;
+ function Read(out Text: string; BufferSize: LongWord = $10000): Integer; overload;
+ function Write(const S: string): Integer;
+ property FileName: string read FFileName write SetFileName;
+ property Connected: Boolean read GetConnected write SetConnected;
+ end;
+
+implementation
+
+{ TUnixClientSocket }
+
+constructor TUnixClientSocket.Create;
+begin
+ inherited Create;
+ FHandle := INVALID_SOCKET;
+end;
+
+destructor TUnixClientSocket.Destroy;
+begin
+ Disconnect;
+ inherited Destroy;
+end;
+
+procedure TUnixClientSocket.Connect;
+begin
+ if FHandle <> INVALID_SOCKET then
+ Exit;
+end;
+
+procedure TUnixClientSocket.Disconnect;
+var
+ S: TSocketHandle;
+begin
+ if FHandle = INVALID_SOCKET then
+ Exit;
+ S := FHandle;
+ FHandle := INVALID_SOCKET;
+ close(S);
+end;
+
+function TUnixClientSocket.Read(var Buffer; BufferSize: LongWord): Integer;
+begin
+ if FHandle = INVALID_SOCKET then
+ Exit(SOCKET_ERROR);
+ Result := recv(FHandle, Buffer, BufferSize, 0);
+ if Result = SOCKET_ERROR then
+ Disconnect;
+end;
+
+function TUnixClientSocket.Read(out Text: string; BufferSize: LongWord = $10000): Integer;
+begin
+ Result := 0;
+ Text := '';
+ if BufferSize < 1 then
+ Exit;
+ SetLength(Text, BufferSize);
+ Result := Read(Pointer(Text)^, BufferSize);
+ if Result < 1 then
+ SetLength(Text, 0)
+ else
+ SetLength(Text, Result);
+end;
+
+function TUnixClientSocket.Write(const S: string): Integer;
+begin
+ Result := 0;
+end;
+
+function TUnixClientSocket.GetConnected: Boolean;
+begin
+ Result := FHandle <> INVALID_SOCKET;
+end;
+
+procedure TUnixClientSocket.SetConnected(Value: Boolean);
+begin
+ if Value then
+ Connect
+ else
+ Disconnect;
+end;
+
+procedure TUnixClientSocket.SetFileName(Value: string);
+begin
+ if FFileName = Value then Exit;
+ FFileName := Value;
+end;
+
+
+end.
diff --git a/source/codebot/codebot.networking.web.pas b/source/codebot/codebot.networking.web.pas
new file mode 100644
index 0000000..f3c0cd6
--- /dev/null
+++ b/source/codebot/codebot.networking.web.pas
@@ -0,0 +1,1573 @@
+(********************************************************)
+(* *)
+(* Codebot Pascal Library *)
+(* http://cross.codebot.org *)
+(* Modified October 2023 *)
+(* *)
+(********************************************************)
+
+{ }
+unit Codebot.Networking.Web;
+
+{$i codebot.inc}
+{$ifdef linux}
+ {.$define use_curl}
+{$endif}
+
+interface
+
+uses
+ Classes,
+ SysUtils,
+ Codebot.System,
+ Codebot.Collections,
+ Codebot.Networking
+ {$ifdef use_curl}, LibCurl{$endif};
+
+{ TUrl parses urls such as https://example.com:8080/resource and
+ captures the component values
+ See also
+ }
+
+type
+ TUrl = record
+ private
+ FProtocol: string;
+ FPort: Word;
+ FDomain: string;
+ FResource: string;
+ FSecure: Boolean;
+ FValid: Boolean;
+ function GetAsString: string;
+ public
+ { Convert a TUrl to a string }
+ class operator Implicit(const Value: TUrl): string;
+ { Convert s string to a TUrl }
+ class operator Implicit(const Value: string): TUrl;
+ { Create a TUrl given a string }
+ class function Create(const S: string): TUrl; static;
+ { The protocol portion of the url, for example HTTP }
+ property Protocol: string read FProtocol;
+ { The port portion of the url, for example 8080 }
+ property Port: Word read FPort;
+ { The domain portion of the url, for example www.google.com }
+ property Domain: string read FDomain;
+ { The resource portion of the url, for example /search/?query=hello }
+ property Resource: string read FResource;
+ { Flag indicating if SSL should be used }
+ property Secure: Boolean read FSecure;
+ { Flag indicating if a url is properly formatted }
+ property Valid: Boolean read FValid;
+ { Convert the url back to a string }
+ property AsString: string read GetAsString;
+ end;
+
+{ THttpResponseHeader parses a buffer and find components of a
+ valid http response header
+ See also
+ }
+
+ THttpResponseHeader = record
+ public
+ { Response code such as 200 }
+ Code: Integer;
+ { Response status such as OK }
+ Status: string;
+ { Response key values }
+ Keys: TNamedStrings;
+ { Response raw header text }
+ RawHeader: string;
+ { When Valid is true a complete header was processed from extract }
+ Valid: Boolean;
+ { Clears all component values }
+ procedure Clear;
+ { Attempt to parse an incomming response buffer }
+ function Extract(var Buffer: string): Boolean;
+ end;
+
+{ WebSendRequest performs a http 1.1 web request and supports chunked replies }
+
+ TResponseStatus = (
+ { Socket connect failed }
+ rsNoConnect,
+ { No response was received }
+ rsNoResponse,
+ { Status code was not 200 OK }
+ rsError,
+ { Status code was 200 OK }
+ rsSuccess,
+ { Task was cancelled }
+ rsCancelled);
+
+function WebSendRequest(Url: TUrl; const Request: string; Response: TStream;
+ out Header: THttpResponseHeader; Task: IAsyncTask = nil): TResponseStatus; overload;
+function WebSendRequest(Url: TUrl; const Request: string; out Response: string;
+ out Header: THttpResponseHeader; Task: IAsyncTask = nil): TResponseStatus; overload;
+
+function WebSendRequestStream(Url: TUrl; Request: TStream; Response: TStream;
+ out Header: THttpResponseHeader; Task: IAsyncTask = nil): TResponseStatus; overload;
+function WebSendRequestStream(Url: TUrl; Request: TStream; out Response: string;
+ out Header: THttpResponseHeader; Task: IAsyncTask = nil): TResponseStatus; overload;
+
+{ THttpPost manages sending multipart http post requests. It is recommended that
+ when you attach streams to the body you turn ownership over to this class.
+ Invoking build will generate a request stream.
+
+ Note:
+
+ Adding only one nameless part to the body causes the post to suppress
+ multipart sections }
+
+type
+ THttpPost = class
+ private
+ type
+ TStringValues = TNamedValues;
+
+ TPostValue = class
+ public
+ Name: string;
+ MimeType: string;
+ Text: string;
+ FileName: string;
+ Stream: TStream;
+ OwnsStream: Boolean;
+ destructor Destroy; override;
+ end;
+
+ TPostValues = TObjectList;
+ private
+ FHeaderValues: TStringValues;
+ FPostValues: TPostValues;
+ FRequest: TStream;
+ procedure Reset;
+ public
+ constructor Create;
+ destructor Destroy; override;
+ procedure Clear;
+ { Add a custom header }
+ function AddHeader(const Name, Value: string): THttpPost;
+ { Add a text to the post body }
+ function AddText(Text: string): THttpPost; overload;
+ function AddText(const Name, Text: string): THttpPost; overload;
+ function AddText(const Name, MimeType, Text: string): THttpPost; overload;
+ { Add a file to the post body }
+ function AddFile(const FileName: string): THttpPost; overload;
+ function AddFile(const Name, FileName: string): THttpPost; overload;
+ function AddFile(const Name, MimeType, FileName: string): THttpPost; overload;
+ { Add a stream to the post body }
+ function AddStream(const Name: string; Stream: TStream; OwnsStream: Boolean = True): THttpPost; overload;
+ function AddStream(const Name, MimeType: string; Stream: TStream; OwnsStream: Boolean = True): THttpPost; overload;
+ { Build the post resulting in a request stream }
+ procedure Build(Url: TUrl);
+ property Request: TStream read FRequest;
+ end;
+
+type
+ TTransmistHeaderCompleteEvent = procedure (Sender: TObject; const Header: THttpResponseHeader) of object;
+
+{ THttpClient implements the http 1.0 client protocol
+ See also
+ }
+
+ THttpClient = class
+ private
+ FBufferSize: Integer;
+ FCancelled: Boolean;
+ FCompleted: Boolean;
+ FUserAgent: string;
+ FResponseHeader: THttpResponseHeader;
+ FResponseStream: TStream;
+ FResponseText: TStringStream;
+ FFOnCancel: TNotifyEvent;
+ FOnHeaderComplete: TTransmistHeaderCompleteEvent;
+ FOnComplete: TNotifyEvent;
+ FOnProgress: TTransmitEvent;
+ function GetCode: Integer;
+ function GetStatus: string;
+ function GetName(Index: Integer): string;
+ function GetValue(Name: string): string;
+ function GetNameCount: Integer;
+ function GetResponseText: string;
+ function Process(const Url: TUrl; const Request: string): Boolean;
+ protected
+ { Complete is invoked when Process is about to return true }
+ procedure Complete; virtual;
+ { Invoke the OnCancel event }
+ procedure DoCancel; virtual;
+ { Invoke the OnHeaderComplete event }
+ procedure DoHeaderComplete; virtual;
+ { Invoke the OnResponseComplete event }
+ procedure DoComplete; virtual;
+ { Invoke the OnProgress event }
+ procedure DoProgress(const Size, Transmitted: LargeWord); virtual;
+ public
+ { Create an http client instance }
+ constructor Create;
+ destructor Destroy; override;
+ { Clear the last response }
+ procedure Clear;
+ { Cancel an ongoing response, can be invoked automatically when an unxpected condition is encountered }
+ procedure Cancel;
+ { Request a copy of the response header }
+ procedure CopyHeader(out Header: THttpResponseHeader);
+ { Send an HTTP GET request }
+ function Get(const Url: TUrl): Boolean; overload;
+ { Send an HTTP GET request with custom headers }
+ function Get(const Url: TUrl; const Headers: TNamedStrings): Boolean; overload;
+ { Send an HTTP POST request with custom headers and content }
+ function Post(const Url: TUrl; const Headers: TNamedStrings;
+ const ContentType: string; const Content: string): Boolean;
+ { Send an HTTP POST request with an arguments form body }
+ function PostArgs(const Url: TUrl; const Args: TNamedStrings): Boolean;
+ { Send an HTTP POST request with a json body }
+ function PostJson(const Url: TUrl; const Json: string): Boolean;
+ { Send an HTTP POST request with an xml body }
+ function PostXml(const Url: TUrl; const Xml: string): Boolean;
+ { Optional size in bytes of the response buffer }
+ property BufferSize: Integer read FBufferSize write FBufferSize;
+ { Holds true if the last request completed properly }
+ property Completed: Boolean read FCompleted;
+ { The user agent as seen by the server }
+ property UserAgent: string read FUserAgent write FUserAgent;
+ { The response code returned from the server }
+ property Code: Integer read GetCode;
+ { The response status returned from the server }
+ property Status: string read GetStatus;
+ { Response header names }
+ property Names[Index: Integer]: string read GetName;
+ { Response header values }
+ property Values[Name: string]: string read GetValue;
+ { Response header name count }
+ property NameCount: Integer read GetNameCount;
+ { Set ResponseStream to write the response body to a stream }
+ property ResponseStream: TStream read FResponseStream write FResponseStream;
+ { If ResponseStream is nil then the response body is stored in ResponseText instead }
+ property ResponseText: string read GetResponseText;
+ { OnCancel is invoked if the request is stoped before completion }
+ property OnCancel: TNotifyEvent read FFOnCancel write FFOnCancel;
+ { OnHeaderComplete is invoked after a complete response header is read }
+ property OnHeaderComplete: TTransmistHeaderCompleteEvent read FOnHeaderComplete write FOnHeaderComplete;
+ { OnProgress is invoked as after the request header is received while bytes are being read }
+ property OnProgress: TTransmitEvent read FOnProgress write FOnProgress;
+ { OnComplete is invoked after a response is read in its entirety }
+ property OnComplete: TNotifyEvent read FOnComplete write FOnComplete;
+ end;
+
+const
+ SDefaultUA = 'Mozilla/5.0 (compatible; WebKit/Chrome)';
+
+{ Simplified HTTP GET with response output to a stream }
+function WebGet(const Url: TUrl; Response: TStream; const UserAgent: string = SDefaultUA): Boolean; overload;
+{ Simplified HTTP GET with response output to a string }
+function WebGet(const Url: TUrl; out Response: string; const UserAgent: string = SDefaultUA): Boolean; overload;
+{ Simplified HTTP POST with response output to a stream }
+function WebPost(const Url: TUrl; Args: TNamedStrings; Response: TStream; const UserAgent: string = SDefaultUA): Boolean; overload;
+{ Simplified HTTP POST with response output to a string }
+function WebPost(const Url: TUrl; Args: TNamedStrings; out Response: string; const UserAgent: string = SDefaultUA): Boolean; overload;
+{$ifdef use_curl}
+{ Use curl to HTTP GET with response output to a stream }
+function CurlGet(const Url: string; Response: TStream; const UserAgent: string = SDefaultUA): Boolean; overload;
+{ Use curl to HTTP GET with response output to a string }
+function CurlGet(const Url: string; out Response: string; const UserAgent: string = SDefaultUA): Boolean; overload;
+{$endif}
+
+const
+ ContentNone = '';
+ ContentText = 'text/plain';
+ ContentHtml = 'text/html';
+ ContentArgs = 'application/x-www-form-urlencoded';
+ ContentJson = 'application/json';
+ ContentXml = 'text/xml; charset=utf-8';
+
+{ HttpResponseHeaderExtract attempts to parse buffer and find a
+ valid http response header }
+function HttpResponseHeaderExtract(var Buffer: string; out Header: string;
+ out BreakStyle: string): Boolean;
+{ HttpRequestGet creates an http get request given a url }
+function HttpRequestGet(const Url: TUrl; const UserAgent: string = SDefaultUA): string;
+{ HttpRequestPost creates an http post request given a url and arguments }
+function HttpRequestPostArgs(const Url: TUrl; const Args: TNamedStrings; const UserAgent: string = SDefaultUA): string;
+{ HttpRequestPostJson creates an http post request given a url and json string }
+function HttpRequestPostJson(const Url: TUrl; const Json: string; const UserAgent: string = SDefaultUA): string;
+{ HttpRequestPostJson creates an http post request given a url and json string }
+function HttpRequestPostXml(const Url: TUrl; const Xml: string; const UserAgent: string = SDefaultUA): string;
+{ UrlEncode escapes char sequences suitable for posting data }
+function UrlEncode(const Value: string): string;
+{ UrlDecode reverts previously escaped char sequences }
+function UrlDecode(const Value: string): string;
+{ ArgsEncode converts name value pairs to a string suitable for posting }
+function ArgsEncode(const Args: TNamedStrings): string;
+{ ArgsDecode converts a posted string back to name value pairs }
+function ArgsDecode(const Args: string): TNamedStrings;
+{ MimeType extracts a mime type given a file name }
+function MimeType(const FileName: string): string;
+
+implementation
+
+uses
+ Codebot.Support;
+
+function ProtocolPort(const Protocol: string): Word;
+var
+ S: string;
+begin
+ S := Protocol.ToUpper;
+ if S = 'FTP' then
+ Result := 21
+ else if S = 'HTTP' then
+ Result := 80
+ else if S = 'HTTPS' then
+ Result := 443
+ else
+ Result := 0;
+end;
+
+function DomainValidate(const S: string): Boolean;
+begin
+ Result := S <> '';
+end;
+
+{ TUrl }
+
+class operator TUrl.Implicit(const Value: TUrl): string;
+begin
+ Result := Value.FProtocol.ToLower + '://' + Value.FDomain;
+ if Value.FPort <> ProtocolPort(Value.FProtocol) then
+ Result := Result + ':' + IntToStr(Value.FPort);
+ if Value.FResource <> '/' then
+ Result := Result + Value.FResource;
+end;
+
+class operator TUrl.Implicit(const Value: string): TUrl;
+begin
+ Result := TUrl.Create(Value);
+end;
+
+class function TUrl.Create(const S: string): TUrl;
+var
+ U: string;
+begin
+ Result.FProtocol := 'HTTP';
+ if S.IndexOf('://') > 0 then
+ begin
+ U := S.FirstOf('://');
+ if U <> '' then
+ Result.FProtocol := U.ToUpper;
+ U := S.SecondOf('://');
+ end
+ else
+ U := S;
+ Result.FPort := ProtocolPort(Result.FProtocol);
+ Result.FResource := '/' + U.SecondOf('/');
+ U := U.FirstOf('/');
+ Result.FDomain := U.FirstOf(':');
+ U := U.SecondOf(':');
+ if U <> '' then
+ Result.FPort := StrToIntDef(U, Result.FPort);
+ Result.FSecure := Result.FProtocol = 'HTTPS';
+ Result.FValid := DomainValidate(Result.FDomain) and (Result.FPort > 0);
+end;
+
+function TUrl.GetAsString: string;
+begin
+ Result := Self;
+end;
+
+{ THttpResponseHeader }
+
+procedure THttpResponseHeader.Clear;
+begin
+ Code := 0;
+ Status := '';
+ RawHeader := '';
+ Valid := False;
+ Keys.Clear;
+end;
+
+function THttpResponseHeader.Extract(var Buffer: string): Boolean;
+var
+ BreakStyle: string;
+ Lines, Row: StringArray;
+ I: Integer;
+begin
+ Result := False;
+ if Valid then
+ Exit;
+ Valid := HttpResponseHeaderExtract(Buffer, RawHeader, BreakStyle);
+ if Valid then
+ begin
+ Lines := RawHeader.Split(BreakStyle);
+ for I := Lines.Lo to Lines.Hi do
+ if I = 0 then
+ begin
+ Row := Lines[I].Words;
+ if Row.Length > 1 then
+ Code := StrToIntDef(Row[1], 0);
+ if Row.Length > 2 then
+ Status := Row[2];
+ end
+ else
+ Keys.Add(Lines[I].FirstOf(':').Trim, Lines[I].SecondOf(':').Trim);
+ end;
+ Result := Valid;
+end;
+
+type
+ TReadBuffer = class
+ FSocket: TSocket;
+ FBuffer: string;
+ FChunked: Boolean;
+ FContentLength: Int64;
+ FIndex: Integer;
+ FLength: Integer;
+ public
+ { TODO: Use ContentLength instead of assuming the header Connection: Close }
+ procedure Reset(Socket: TSocket; Buffer: string; Chunked: Boolean; ContentLength: Int64 = -1);
+ function Read(var Buffer; BufferSize: LongWord): Integer; overload;
+ function Read(out Text: string): Integer; overload;
+ property Chunked: Boolean read FChunked;
+ end;
+
+procedure TReadBuffer.Reset(Socket: TSocket; Buffer: string; Chunked: Boolean; ContentLength: Int64 = -1);
+begin
+ FSocket := Socket;
+ FBuffer := Buffer;
+ FChunked := Chunked;
+ FContentLength := ContentLength;
+ FIndex := 1;
+ FLength := Length(FBuffer);
+end;
+
+function TReadBuffer.Read(var Buffer; BufferSize: LongWord): Integer;
+var
+ B: PByte;
+begin
+ if FLength > 0 then
+ begin
+ Result := 0;
+ B := PByte(@Buffer);
+ while (FLength > 0) and (BufferSize > 0) do
+ begin
+ B^ := Byte(FBuffer[FIndex]);
+ Inc(FIndex);
+ Dec(FLength);
+ Dec(BufferSize);
+ Inc(Result);
+ end;
+ end
+ else
+ Result := FSocket.Read(Buffer, BufferSize);
+end;
+
+function TReadBuffer.Read(out Text: string): Integer;
+var
+ P: PChar;
+begin
+ if FLength > 0 then
+ begin
+ P := PChar(FBuffer);
+ Inc(P, FIndex - 1);
+ Text := P^;
+ Result := FLength;
+ FLength := 0;
+ end
+ else
+ Result := FSocket.Read(Text);
+end;
+
+function WebSendRequest(Url: TUrl; const Request: string; Response: TStream;
+ out Header: THttpResponseHeader; Task: IAsyncTask = nil): TResponseStatus;
+var
+ S: TStream;
+begin
+ S := TStringStream.Create(Request);
+ try
+ Result := WebSendRequestStream(Url, S, Response, Header, Task);
+ finally
+ S.Free;
+ end;
+end;
+
+function WebSendRequest(Url: TUrl; const Request: string; out Response: string;
+ out Header: THttpResponseHeader; Task: IAsyncTask = nil): TResponseStatus;
+var
+ S: TStringStream;
+begin
+ S := TStringStream.Create;
+ try
+ Result := WebSendRequest(Url, Request, S, Header, Task);
+ Response := S.DataString;
+ finally
+ S.Free;
+ end;
+end;
+
+function WebSendRequestStream(Url: TUrl; Request: TStream; Response: TStream;
+ out Header: THttpResponseHeader; Task: IAsyncTask = nil): TResponseStatus;
+
+ procedure DoProgress(Delta: Int64);
+ begin
+ if (Delta > 0) and (Task <> nil) then
+ (Task as IAsyncRunnerBase).Tick(Delta);
+ end;
+
+ function IsCancelled: Boolean;
+ begin
+ Result := (Task <> nil) and Task.Cancelled;
+ end;
+
+ function ReadChunk(S: TReadBuffer; Chunk: string): string;
+ var
+ Buffer: string;
+ P: PChar;
+ I, J: Integer;
+ begin
+ Result := '';
+ if IsCancelled then
+ Exit;
+ Chunk := '$' + Chunk;
+ I := StrToIntDef(Chunk, 0);
+ if I = 0 then
+ Exit;
+ SetLength({%H-}Buffer, I);
+ P := PChar(Buffer);
+ while I > 0 do
+ begin
+ if IsCancelled then
+ Exit;
+ J := S.Read(P^, LongWord(I));
+ if J = 0 then
+ Exit;
+ DoProgress(J);
+ Inc(P, J);
+ Dec(I, J);
+ end;
+ Result := Buffer;
+ end;
+
+var
+ Buffer, Data, Encoding, Chunk: string;
+ Socket: TSocket;
+ ReadBuffer: TReadBuffer;
+ Read: Boolean;
+ C: Char;
+begin
+ Result := rsNoConnect;
+ Header.Clear;
+ Buffer := '';
+ Socket := TSocket.Create;
+ ReadBuffer := TReadBuffer.Create;
+ try
+ Socket.Secure := True; //Url.Secure;
+ if Socket.Connect(Url.Domain, 443) then
+ begin
+ if IsCancelled then
+ Exit;
+ Result := rsNoResponse;
+ if not Socket.WriteStream(Request, Task) then
+ Exit;
+ Read := False;
+ while not Read do
+ while Socket.Read(Data) > 0 do
+ begin
+ Read := True;
+ Buffer := Buffer + Data;
+ WriteLn(Buffer);
+ if Header.Extract(Buffer) then
+ begin
+ if Header.Code = 200 then
+ Result := rsSuccess
+ else
+ Result := rsError;
+ Encoding := Header.Keys.Values['Transfer-Encoding'];
+ ReadBuffer.Reset(Socket, Buffer, StrContains(Encoding, 'chunked', True));
+ if ReadBuffer.Chunked then
+ repeat
+ Chunk := '';
+ if IsCancelled then
+ Exit;
+ while ReadBuffer.Read({%H-}C, 1) = 1 do
+ begin
+ if IsCancelled then
+ Exit;
+ if (C = #10) and (Chunk <> '') then
+ begin
+ Data := ReadChunk(ReadBuffer, Chunk);
+ if IsCancelled then
+ Exit;
+ Chunk := '';
+ if Length(Data) < 1 then
+ Break;
+ Response.Write(Pointer(Data)^, Length(Data));
+ end
+ else if C > ' ' then
+ Chunk := Chunk + C;
+ end;
+ until Chunk = ''
+ else while ReadBuffer.Read(Data) > 0 do
+ begin
+ if IsCancelled then
+ Exit;
+ DoProgress(Length(Data));
+ Response.Write(Pointer(Data)^, Length(Data));
+ end;
+ Break;
+ end;
+ end;
+ end;
+ finally
+ ReadBuffer.Free;
+ Socket.Free;
+ if IsCancelled then
+ Result := rsCancelled;
+ end;
+end;
+
+function WebSendRequestStream(Url: TUrl; Request: TStream; out Response: string;
+ out Header: THttpResponseHeader; Task: IAsyncTask = nil): TResponseStatus;
+var
+ S: TStringStream;
+begin
+ S := TStringStream.Create;
+ try
+ Result := WebSendRequestStream(Url, Request, S, Header, Task);
+ Response := S.DataString;
+ finally
+ S.Free;
+ end;
+end;
+
+{ THttpClient }
+
+constructor THttpClient.Create;
+begin
+ inherited Create;
+ FResponseText := TStringStream.Create('');
+ Clear;
+end;
+
+destructor THttpClient.Destroy;
+begin
+ FResponseText.Free;
+ inherited Destroy;
+end;
+
+procedure THttpClient.Clear;
+begin
+ FCompleted := False;
+ FCancelled := True;
+ FResponseHeader.Clear;
+ FResponseText.Size := 0;
+end;
+
+procedure THttpClient.Complete;
+begin
+ if not FCompleted then
+ begin
+ FCompleted := True;
+ FCancelled := True;
+ DoComplete;
+ end;
+end;
+
+procedure THttpClient.Cancel;
+begin
+ if not FCancelled then
+ begin
+ FCancelled := True;
+ DoCancel;
+ end;
+end;
+
+procedure THttpClient.CopyHeader(out Header: THttpResponseHeader);
+begin
+ Header := FResponseHeader;
+end;
+
+function THttpClient.GetCode: Integer;
+begin
+ Result := FResponseHeader.Code;
+end;
+
+function THttpClient.GetStatus: string;
+begin
+ Result := FResponseHeader.Status;
+end;
+
+function THttpClient.GetName(Index: Integer): string;
+begin
+ Result := FResponseHeader.Keys.Names[Index];
+end;
+
+function THttpClient.GetValue(Name: string): string;
+begin
+ Result := FResponseHeader.Keys.Values[Name];
+end;
+
+function THttpClient.GetNameCount: Integer;
+begin
+ Result := FResponseHeader.Keys.Count;
+end;
+
+function THttpClient.GetResponseText: string;
+begin
+ Result := FResponseText.DataString;
+end;
+
+procedure THttpClient.DoCancel;
+begin
+ if Assigned(FFOnCancel) then
+ FFOnCancel(Self);
+end;
+
+procedure THttpClient.DoHeaderComplete;
+begin
+ if Assigned(FOnHeaderComplete) then
+ FOnHeaderComplete(Self, FResponseHeader);
+end;
+
+procedure THttpClient.DoComplete;
+begin
+ if Assigned(FOnComplete) then
+ FOnComplete(Self);
+end;
+
+procedure THttpClient.DoProgress(const Size, Transmitted: LargeWord);
+begin
+ if Assigned(FOnProgress) then
+ FOnProgress(Self, Size, Transmitted);
+end;
+
+function THttpClient.Process(const Url: TUrl; const Request: string): Boolean;
+
+ function Stream: TStream;
+ begin
+ if FResponseStream <> nil then
+ Result := FResponseStream
+ else
+ Result := FResponseText;
+ end;
+
+const
+ BufferSizeMin = $1000;
+ BufferSizeDef = $10000;
+ BufferSizeMax = $100000;
+var
+ Socket: TSocket;
+ Temp, S: string;
+ ContentLength, ContentRead: LargeInt;
+ Count: LongInt;
+ Buffer: Pointer;
+ BufferSize: Integer;
+ I: Integer;
+begin
+ BufferSize := FBufferSize;
+ if BufferSize < 1 then
+ BufferSize := BufferSizeDef
+ else if BufferSize < BufferSizeMin then
+ BufferSize := BufferSizeMin
+ else if BufferSize > BufferSizeMax then
+ BufferSize := BufferSizeMax;
+ Result := False;
+ Clear;
+ try
+ FCancelled := False;
+ if not Url.Valid then
+ Exit;
+ if Request.Length = 0 then
+ Exit;
+ Socket := TSocket.Create;
+ try
+ Socket.Secure := Url.Secure;
+ Socket.Timeout := 4000;
+ if not Socket.Connect(Url.Domain, Url.Port) then
+ Exit;
+ if not Socket.WriteText(Request) then
+ Exit;
+ Temp := '';
+ repeat
+ I := Socket.Read(S);
+ if I < 1 then
+ Exit;
+ Temp := Temp + S;
+ until FResponseHeader.Extract(Temp);
+ DoHeaderComplete;
+ S := FResponseHeader.Keys.Values['Content-Length'];
+ if S <> '' then
+ begin
+ ContentLength := StrToInt64Def(S, 0);
+ if ContentLength < 1 then
+ Exit(True);
+ if Temp.Length >= ContentLength then
+ begin
+ Stream.Write(Temp[1], ContentLength);
+ Exit(True);
+ end;
+ end
+ else
+ ContentLength := High(ContentLength);
+ ContentRead := Temp.Length;
+ if ContentRead > 0 then
+ Stream.Write(Temp[1], Temp.Length);
+ Temp := '';
+ GetMem(Buffer, BufferSize);
+ try
+ repeat
+ Count := Socket.Read(Buffer^, BufferSize);
+ if Count > 0 then
+ begin
+ if Count + ContentRead >= ContentLength then
+ Count := ContentLength - ContentRead;
+ if Stream.Write(Buffer^, Count) = Count then
+ begin
+ ContentRead := ContentRead + Count;
+ DoProgress(ContentLength, ContentRead);
+ end
+ else
+ Exit;
+ end;
+ until (FCancelled) or (Count < 1) or (ContentRead >= ContentLength);
+ if FCancelled then
+ Result := False
+ else if S <> '' then
+ Result := ContentRead >= ContentLength
+ else
+ Result := True;
+ finally
+ FreeMem(Buffer);
+ end;
+ finally
+ Socket.Free;
+ end;
+ finally
+ if Result then
+ Complete
+ else
+ Cancel;
+ end;
+end;
+
+function THttpClient.Get(const Url: TUrl): Boolean;
+var
+ S: string;
+begin
+ S := HttpRequestGet(Url, FUserAgent);
+ Result := Process(Url, S);
+end;
+
+function THttpClient.Get(const Url: TUrl; const Headers: TNamedStrings): Boolean;
+var
+ Name, Value: string;
+ S: string;
+ I: Integer;
+begin
+ S := 'GET ' + Url.Resource + ' HTTP/1.0'#13#10 +
+ 'Host: ' + Url.Domain + #13#10;
+ for I := 0 to Headers.Count - 1 do
+ begin
+ Name := Headers.Names[I];
+ Value := Headers.ValueByIndex[I];
+ S := S + Name + ': ' + Value + #13#10;
+ end;
+ if UserAgent <> '' then
+ S := S + 'User-Agent: ' + UserAgent + #13#10;
+ S := S + 'Connection: Close'#13#10#13#10;
+ Result := Process(Url, S);
+end;
+
+function THttpClient.Post(const Url: TUrl; const Headers: TNamedStrings;
+ const ContentType: string; const Content: string): Boolean;
+var
+ Name, Value: string;
+ S: string;
+ I: Integer;
+begin
+ S := 'POST ' + Url.Resource + ' HTTP/1.1'#13#10 +
+ 'Host: ' + Url.Domain + #13#10;
+ for I := 0 to Headers.Count - 1 do
+ begin
+ Name := Headers.Names[I];
+ Value := Headers.ValueByIndex[I];
+ S := S + Name + ': ' + Value + #13#10;
+ end;
+ if Content.Length > 0 then
+ begin
+ S := S + 'Content-Type: ' + ContentType + #13#10;
+ S := S + 'Content-Length: ' + IntToStr(Content.Length) + #13#10;
+ end;
+ if UserAgent <> '' then
+ S := S + 'User-Agent: ' + UserAgent + #13#10;
+ S := S + 'Connection: Close'#13#10#13#10;
+ if Content.Length > 0 then
+ S := S + Content;
+ Result := Process(Url, S);
+end;
+
+function THttpClient.PostArgs(const Url: TUrl; const Args: TNamedStrings): Boolean;
+var
+ S: string;
+begin
+ S := HttpRequestPostArgs(Url, Args, FUserAgent);
+ Result := Process(Url, S);
+end;
+
+function THttpClient.PostJson(const Url: TUrl; const Json: string): Boolean;
+var
+ S: string;
+begin
+ S := HttpRequestPostJson(Url, Json, FUserAgent);
+ Result := Process(Url, S);
+end;
+
+function THttpClient.PostXml(const Url: TUrl; const Xml: string): Boolean;
+var
+ S: string;
+begin
+ S := HttpRequestPostXml(Url, Xml, FUserAgent);
+ Result := Process(Url, S);
+end;
+
+function HttpResponseHeaderExtract(var Buffer: string; out Header: string; out BreakStyle: string): Boolean;
+const
+ Breaks: array[0..3] of string = (#10#10, #13#10#13#10, #13#13, #10#13#10#13);
+var
+ First, Index: Integer;
+ I, J: Integer;
+begin
+ Result := False;
+ Header := '';
+ BreakStyle := '';
+ First := -1;
+ Index := -1;
+ for I := Low(Breaks) to High(Breaks) do
+ begin
+ J := Buffer.IndexOf(Breaks[I]);
+ if J < 1 then
+ Continue;
+ if (First < 0) or (J < First) then
+ begin
+ First := J;
+ Index := I;
+ end;
+ end;
+ if Index > -1 then
+ begin
+ Header := Buffer.FirstOf(Breaks[Index]);
+ Buffer := Buffer.SecondOf(Breaks[Index]);
+ BreakStyle := Breaks[Index];
+ BreakStyle.Length := BreakStyle.Length div 2;
+ Result := True;
+ end;
+end;
+
+function HttpRequestGet(const Url: TUrl; const UserAgent: string = SDefaultUA): string;
+begin
+ if not Url.Valid then
+ Exit('');
+ Result :=
+ 'GET ' + Url.Resource + ' HTTP/1.0'#13#10 +
+ 'Host: ' + Url.Domain + #13#10;
+ if UserAgent <> '' then
+ Result := Result + 'User-Agent: ' + UserAgent + #13#10;
+ Result := Result + 'Connection: Close'#13#10#13#10;
+end;
+
+function HttpRequestPostArgs(const Url: TUrl; const Args: TNamedStrings; const UserAgent: string = SDefaultUA): string;
+var
+ Content: string;
+begin
+ if not Url.Valid then
+ Exit('');
+ Content := ArgsEncode(Args);
+ Result :=
+ 'POST ' + Url.Resource + ' HTTP/1.0'#13#10 +
+ 'Host: ' + Url.Domain + #13#10 +
+ 'Content-Length: ' + IntToStr(Content.Length) + #13#10 +
+ 'Content-Type: ' + ContentArgs + #13#10;
+ if UserAgent <> '' then
+ Result := Result + 'User-Agent: ' + UserAgent + #13#10;
+ Result := Result + 'Connection: Close'#13#10#13#10 + Content;
+end;
+
+function HttpRequestPostJson(const Url: TUrl; const Json: string; const UserAgent: string = SDefaultUA): string;
+begin
+ if not Url.Valid then
+ Exit('');
+ Result :=
+ 'POST ' + Url.Resource + ' HTTP/1.0'#13#10 +
+ 'Host: ' + Url.Domain + #13#10 +
+ 'Content-Length: ' + IntToStr(Json.Length) + #13#10 +
+ 'Content-Type: ' + ContentJson + #13#10;
+ if UserAgent <> '' then
+ Result := Result + 'User-Agent: ' + UserAgent + #13#10;
+ Result := Result + 'Connection: Close'#13#10#13#10 + Json;
+end;
+
+function HttpRequestPostXml(const Url: TUrl; const Xml: string; const UserAgent: string = SDefaultUA): string;
+begin
+ if not Url.Valid then
+ Exit('');
+ Result :=
+ 'POST ' + Url.Resource + ' HTTP/1.0'#13#10 +
+ 'Host: ' + Url.Domain + #13#10 +
+ 'Content-Length: ' + IntToStr(Xml.Length) + #13#10 +
+ 'Content-Type: ' + ContentXml + #13#10;
+ if UserAgent <> '' then
+ Result := Result + 'User-Agent: ' + UserAgent + #13#10;
+ Result := Result + 'Connection: Close'#13#10#13#10 + Xml;
+end;
+
+function UrlEncode(const Value: string): string;
+var
+ C: Char;
+ I: Integer;
+begin
+ Result := '';
+ for I := 1 to Value.Length do
+ begin
+ C := Value[I];
+ if C in ['-', '_', '.', '~', '0'..'9', 'A'..'Z', 'a'..'z'] then
+ Result := Result + C
+ else
+ Result := Result + '%' + IntToHex(Ord(C), 2);
+ end;
+end;
+
+function UrlDecode(const Value: string): string;
+var
+ C: Char;
+ S: string;
+ I, J: Integer;
+begin
+ Result := '';
+ I := Value.Length + 1;
+ J := 1;
+ while J < I do
+ begin
+ C := Value[J];
+ if C = '%' then
+ begin
+ if J + 2 > I then
+ Exit('');
+ S := '$' + Value[J + 1] + Value[J + 2];
+ C := Chr(StrToInt(S));
+ Inc(J, 2);
+ end;
+ Result := Result + C;
+ Inc(J);
+ end;
+end;
+
+function ArgsEncode(const Args: TNamedStrings): string;
+var
+ N, V: string;
+ I: Integer;
+begin
+ Result := '';
+ for I := 0 to Args.Count - 1 do
+ begin
+ if Result <> '' then
+ Result := Result + '&';
+ N := Args.Names[I];
+ V := Args.ValueByIndex[I];
+ Result := Result + UrlEncode(N) + '=' + UrlEncode(V);
+ end;
+end;
+
+function ArgsDecode(const Args: string): TNamedStrings;
+var
+ Pairs, NameValue: StringArray;
+ S: string;
+ N, V: string;
+begin
+ Result.Clear;
+ Pairs := Args.Split('&');
+ for S in Pairs do
+ begin
+ NameValue := S.Split('=');
+ if NameValue.Length <> 2 then
+ begin
+ Result.Clear;
+ Exit;
+ end;
+ N := UrlDecode(NameValue[0]);
+ V := UrlDecode(NameValue[1]);
+ if N <> '' then
+ Result.Add(N, V);
+ end;
+end;
+
+function MimeType(const FileName: string): string;
+var
+ S: string;
+begin
+ S := FileExtractExt(FileName).ToLower;
+ if s = '.7z' then
+ Exit('application/x-7z-compressed');
+ if s = '.aac' then
+ Exit('audio/aac');
+ if s = '.avi' then
+ Exit('video/avi');
+ if s = '.bmp' then
+ Exit('image/bmp');
+ if s = '.css' then
+ Exit('text/css');
+ if s = '.csv' then
+ Exit('text/csv');
+ if s = '.doc' then
+ Exit('application/msword');
+ if s = '.ocx' then
+ Exit('application/vnd.openxmlformats-officedocument.wordprocessingml.document');
+ if s = '.gif' then
+ Exit('image/gif');
+ if s = '.htm' then
+ Exit('text/html');
+ if s = '.html' then
+ Exit('text/html');
+ if s = '.jpeg' then
+ Exit('image/jpeg');
+ if s = '.jpg' then
+ Exit('image/jpeg');
+ if s = '.js' then
+ Exit('application/javascript');
+ if s = '.json' then
+ Exit('application/json');
+ if s = '.mov' then
+ Exit('video/quicktime');
+ if s = '.m4a' then
+ Exit('audio/mp4a');
+ if s = '.mp3' then
+ Exit('audio/mpeg');
+ if s = '.m4v' then
+ Exit('video/mp4');
+ if s = '.mp4' then
+ Exit('video/mp4');
+ if s = '.mpeg' then
+ Exit('video/mpeg');
+ if s = '.mpg' then
+ Exit('video/mpeg');
+ if s = '.ogg' then
+ Exit('audio/ogg');
+ if s = '.ogv' then
+ Exit('video/ogv');
+ if s = '.pdf' then
+ Exit('application/pdf');
+ if s = '.png' then
+ Exit('image/png');
+ if s = '.ppt' then
+ Exit('application/vnd.ms-powerpoint');
+ if s = '.ptx' then
+ Exit('application/vnd.openxmlformats-officedocument.presentationml.presentation');
+ if s = '.qt' then
+ Exit('video/quicktime');
+ if s = '.svg' then
+ Exit('image/svg');
+ if s = '.swf' then
+ Exit('application/x-shockwave-flash');
+ if s = '.tif' then
+ Exit('image/tiff');
+ if s = '.tiff' then
+ Exit('image/tiff');
+ if s = '.ini' then
+ Exit('text/plain');
+ if s = '.cfg' then
+ Exit('text/plain');
+ if s = '.cs' then
+ Exit('text/plain');
+ if s = '.pas' then
+ Exit('text/plain');
+ if s = '.sh' then
+ Exit('text/plain');
+ if s = '.txt' then
+ Exit('text/plain');
+ if s = '.wav' then
+ Exit('audio/x-wav');
+ if s = '.wma' then
+ Exit('audio/x-ms-wma');
+ if s = '.wmv' then
+ Exit('audio/x-ms-wmv');
+ if s = '.xls' then
+ Exit('application/vnd.ms-excel');
+ if s = '.lsx' then
+ Exit('application/vnd.openxmlformats-officedocument.spreadsheetml.sheet');
+ if s = '.xml' then
+ Exit('text/xml');
+ if s = '.zip' then
+ Exit('application/zip');
+ Result := 'application/octet-stream';
+end;
+
+function WebGet(const Url: TUrl; Response: TStream; const UserAgent: string = SDefaultUA): Boolean;
+var
+ Request: THttpClient;
+begin
+ Request := THttpClient.Create;
+ try
+ Request.UserAgent := UserAgent;
+ Request.ResponseStream := Response;
+ Result := Request.Get(Url) and (Request.Code = 200);
+ finally
+ Request.Free;
+ end;
+end;
+
+function WebGet(const Url: TUrl; out Response: string; const UserAgent: string = SDefaultUA): Boolean;
+var
+ Request: THttpClient;
+begin
+ Request := THttpClient.Create;
+ try
+ Request.UserAgent := UserAgent;
+ Result := Request.Get(Url) and (Request.Code = 200);
+ Response := Request.ResponseText;
+ finally
+ Request.Free;
+ end;
+end;
+
+function WebPost(const Url: TUrl; Args: TNamedStrings; Response: TStream; const UserAgent: string = SDefaultUA): Boolean;
+var
+ Request: THttpClient;
+begin
+ Request := THttpClient.Create;
+ try
+ Request.UserAgent := UserAgent;
+ Request.ResponseStream := Response;
+ Result := Request.PostArgs(Url, Args) and (Request.Code = 200);
+ finally
+ Request.Free;
+ end;
+end;
+
+function WebPost(const Url: TUrl; Args: TNamedStrings; out Response: string; const UserAgent: string = SDefaultUA): Boolean;
+var
+ Request: THttpClient;
+begin
+ Request := THttpClient.Create;
+ try
+ Request.UserAgent := UserAgent;
+ Result := Request.PostArgs(Url, Args) and (Request.Code = 200);
+ Response := Request.ResponseText;
+ finally
+ Request.Free;
+ end;
+end;
+
+{$ifdef use_curl}
+function CurlWriteStream(Ptr: PByte; MemberSize, MemberCount: UIntPtr; Response: TStream): UIntPtr; cdecl;
+begin
+ Result := MemberSize * MemberCount;
+ Response.Write(Ptr^, Result);
+end;
+
+function CurlGet(const Url: string; Response: TStream; const UserAgent: string = SDefaultUA): Boolean;
+var
+ Curl: PCURL;
+begin
+ Result := False;
+ if Url = '' then
+ Exit;
+ if Response = nil then
+ Exit;
+ Curl := curl_easy_init();
+ if Curl = nil then
+ Exit;
+ try
+ curl_easy_setopt(Curl, CURLOPT_URL, [PChar(Url)]);
+ if UserAgent <> '' then
+ curl_easy_setopt(Curl, CURLOPT_USERAGENT, [PChar(UserAgent)]);
+ curl_easy_setopt(Curl, CURLOPT_WRITEFUNCTION, [@CurlWriteStream]);
+ curl_easy_setopt(Curl, CURLOPT_WRITEDATA, [Pointer(Response)]);
+ curl_easy_setopt(Curl, CURLOPT_SSL_VERIFYPEER, [0]);
+ curl_easy_setopt(Curl, CURLOPT_SSL_VERIFYHOST, [0]);
+ Result := curl_easy_perform(Curl) = CURLE_OK;
+ finally
+ curl_easy_cleanup(Curl);
+ end;
+end;
+
+function CurlWriteString(Ptr: PChar; MemberSize, MemberCount: UIntPtr; var Response: string): UIntPtr; cdecl;
+var
+ S: string;
+begin
+ SetString(S, Ptr, MemberSize * MemberCount);
+ Response := Response + S;
+ Result := MemberSize * MemberCount;
+end;
+
+function CurlGet(const Url: string; out Response: string; const UserAgent: string = SDefaultUA): Boolean;
+var
+ Curl: PCURL;
+begin
+ Response := '';
+ Result := False;
+ if Url = '' then
+ Exit;
+ Curl := curl_easy_init();
+ if Curl = nil then
+ Exit;
+ try
+ curl_easy_setopt(Curl, CURLOPT_URL, [PChar(Url)]);
+ if UserAgent <> '' then
+ curl_easy_setopt(Curl, CURLOPT_USERAGENT, [PChar(UserAgent)]);
+ curl_easy_setopt(Curl, CURLOPT_WRITEFUNCTION, [@CurlWriteString]);
+ curl_easy_setopt(Curl, CURLOPT_WRITEDATA, [@Response]);
+ curl_easy_setopt(Curl, CURLOPT_SSL_VERIFYPEER, [0]);
+ curl_easy_setopt(Curl, CURLOPT_SSL_VERIFYHOST, [0]);
+ Result := curl_easy_perform(Curl) = CURLE_OK;
+ finally
+ curl_easy_cleanup(Curl);
+ end;
+end;
+{$endif}
+
+const
+ PostBoundary = 'post_boundary_C5D3DFF684C043DCA9715B823FBB15BD';
+ PostBoundaryLine = '--' + PostBoundary + #13#10;
+
+function PostCount(Post: THttpPost): Integer;
+begin
+ Result := Post.FPostValues.Count;
+end;
+
+function PostSection(Post: THttpPost; Index: Integer): string;
+var
+ Item: THttpPost.TPostValue;
+ S: string;
+begin
+ Result := '';
+ if Index < 0 then
+ Exit;
+ if Index >= PostCount(Post) then
+ Exit;
+ Item := Post.FPostValues[Index];
+ Result :=
+ PostBoundaryLine +
+ 'Content-Disposition: form-data; name="' + Item.Name + '"';
+ if Item.Stream is TFileStream then
+ begin
+ S := FileExtractName(TFileStream(Item.Stream).FileName);
+ Result := Result + '; filename= "' + S + '"';
+ end
+ else if (Item.FileName <> '') and (FileExists(Item.FileName)) then
+ begin
+ S := FileExtractName(Item.FileName);
+ Result := Result + '; filename= "' + S + '"';
+ end;
+ Result := Result + #13#10 +
+ 'Content-Type: ' + Item.MimeType + #13#10 +
+ #13#10;
+end;
+
+{ THttpPost.TPostValue }
+
+destructor THttpPost.TPostValue.Destroy;
+begin
+ if OwnsStream then
+ Stream.Free;
+ inherited Destroy;
+end;
+
+{ THttpPost }
+
+constructor THttpPost.Create;
+begin
+ inherited Create;
+ FPostValues := TPostValues.Create(True);
+end;
+
+destructor THttpPost.Destroy;
+begin
+ Clear;
+ FPostValues.Free;
+ inherited Destroy;
+end;
+
+procedure THttpPost.Clear;
+begin
+ Reset;
+ FPostValues.Clear;
+end;
+
+procedure THttpPost.Reset;
+begin
+ FRequest.Free;
+ FRequest := nil;
+end;
+
+function THttpPost.AddHeader(const Name, Value: string): THttpPost;
+begin
+ Reset;
+ FHeaderValues.Add(Name, Value);
+ Result := Self;
+end;
+
+function THttpPost.AddText(Text: string): THttpPost;
+begin
+ Result := AddText('', '', Text);
+end;
+
+function THttpPost.AddText(const Name, Text: string): THttpPost;
+begin
+ Result := AddText(Name, '', Text);
+end;
+
+function THttpPost.AddText(const Name, MimeType, Text: string): THttpPost;
+var
+ Item: TPostValue;
+ S: string;
+begin
+ Reset;
+ S := Trim(MimeType);
+ if S = '' then
+ S := 'text/plain';
+ Item := TPostValue.Create;
+ Item.Name := Name;
+ Item.MimeType := S;
+ Item.Text := Text;
+ FPostValues.Add(Item);
+ Result := Self;
+end;
+
+function THttpPost.AddFile(const FileName: string): THttpPost;
+begin
+ Result := AddFile('', '', FileName);
+end;
+
+function THttpPost.AddFile(const Name, FileName: string): THttpPost;
+begin
+ Result := AddFile(Name, '', FileName);
+end;
+
+function THttpPost.AddFile(const Name, MimeType, FileName: string): THttpPost;
+var
+ Item: TPostValue;
+ S: string;
+begin
+ Reset;
+ if not FileExists(FileName) then
+ Exit;
+ S := Trim(MimeType);
+ if S = '' then
+ S := Codebot.Networking.Web.MimeType(FileName);
+ Item := TPostValue.Create;
+ Item.Name := Name;
+ Item.MimeType := S;
+ Item.FileName := FileName;
+ FPostValues.Add(Item);
+ Result := Self;
+end;
+
+function THttpPost.AddStream(const Name: string; Stream: TStream;
+ OwnsStream: Boolean = True): THttpPost; overload;
+begin
+ Result := AddStream(Name, '', Stream, OwnsStream);
+end;
+
+function THttpPost.AddStream(const Name, MimeType: string; Stream: TStream;
+ OwnsStream: Boolean = True): THttpPost;
+var
+ Item: TPostValue;
+ S: string;
+begin
+ Reset;
+ S := Trim(MimeType);
+ if S = '' then
+ S := 'application/octet-stream';
+ Item := TPostValue.Create;
+ Item.Name := Name;
+ Item.MimeType := S;
+ Item.Stream := Stream;
+ Item.OwnsStream := OwnsStream;
+ FPostValues.Add(Item);
+ Result := Self;
+end;
+
+function StreamText(const Stream: TStream): string;
+var
+ C: Char;
+begin
+ Result := '';
+ while Stream.Read(C, 1) = 1 do Result := Result + C;
+end;
+
+procedure THttpPost.Build(Url: TUrl);
+var
+ Stream: TAggregateStream;
+ Item: TPostValue;
+ S: string;
+ I: Integer;
+begin
+ if FRequest <> nil then
+ Exit;
+ S :=
+ 'POST ' + Url.Resource + ' HTTP/1.1'#13#10 +
+ 'Host: ' + Url.Domain + #13#10;
+ for I := 0 to FHeaderValues.Count - 1 do
+ S := S +
+ FHeaderValues.Names[I] + ': ' + FHeaderValues.ValueByIndex[I] + #13#10;
+ { If there are no body parts then we have zero content length }
+ if FPostValues.Count = 0 then
+ begin
+ S := S +
+ 'Content-Length: 0'#13#10 +
+ 'Connection: Close'#13#10 +
+ #13#10;
+ FRequest := TStringStream.Create(S);
+ Exit;
+ end;
+ { If there is one unmamed body part then we do not have a multipart post }
+ if (FPostValues.Count = 1) and (FPostValues[0].Name = '') then
+ begin
+ Stream := TAggregateStream.Create;
+ Item := FPostValues[0];
+ S := S +
+ 'Content-Type: ' + Item.MimeType + #13#10;
+ if Item.Stream <> nil then
+ Stream.AddStream(Stream, False)
+ else if (Item.FileName <> '') and (FileExists(Item.FileName)) then
+ Stream.AddFile(Item.FileName)
+ else if Item.FileName <> '' then
+ Stream.AddText(Item.FileName)
+ else
+ Stream.AddText(Item.Text);
+ S := S +
+ 'Content-Length: ' + IntToStr(Stream.Size) + #13#10 +
+ 'Connection: Close'#13#10 +
+ #13#10;
+ FRequest := TAggregateStream.Create;
+ TAggregateStream(FRequest).AddText(S + StreamText(Stream));
+ // TAggregateStream(FRequest).AddStream(Stream);
+ Exit;
+ end;
+ { We have determined that this is a multipart post }
+ S := S +
+ 'Content-Type: multipart/form-data; boundary=' + PostBoundary + #13#10;
+ Stream := TAggregateStream.Create;
+ for I := 0 to FPostValues.Count - 1 do
+ begin
+ Item := FPostValues[I];
+ Stream.AddText(PostSection(Self, I));
+ if Item.Stream <> nil then
+ Stream.AddStream(Item.Stream, False)
+ else if (Item.FileName <> '') and (FileExists(Item.FileName)) then
+ Stream.AddFile(Item.FileName)
+ else if Item.FileName <> '' then
+ Stream.AddText(Item.FileName)
+ else
+ Stream.AddText(Item.Text);
+ Stream.AddText(#13#10);
+ end;
+ Stream.AddText('--' + PostBoundary + '--');
+ S := S +
+ 'Content-Length: ' + IntToStr(Stream.Size) + #13#10 +
+ 'Connection: Close'#13#10 +
+ #13#10;
+ FRequest := TAggregateStream.Create;
+ TAggregateStream(FRequest).AddText(S);
+ TAggregateStream(FRequest).AddStream(Stream);
+end;
+
+end.
+
diff --git a/source/codebot/codebot.pas b/source/codebot/codebot.pas
new file mode 100644
index 0000000..a9b7246
--- /dev/null
+++ b/source/codebot/codebot.pas
@@ -0,0 +1,35 @@
+{ This file was automatically created by Lazarus. Do not edit!
+ This source is only used to compile and install the package.
+ }
+
+unit codebot;
+
+{$warn 5023 off : no warning about unused units}
+interface
+
+uses
+ Codebot.Animation, Codebot.Collections, Codebot.Constants, Codebot.Core,
+ Codebot.Cryptography, Codebot.Geometry, Codebot.Graphics.Linux.SurfaceCairo,
+ Codebot.Graphics, Codebot.Graphics.Types,
+ Codebot.Graphics.Windows.ImageBitmap,
+ Codebot.Graphics.Windows.InterfacedBitmap,
+ Codebot.Graphics.Windows.SurfaceD2D,
+ Codebot.Graphics.Windows.SurfaceGdiPlus, Codebot.Interop.Linux.Xml2,
+ Codebot.Interop.OpenSSL, Codebot.Interop.Sockets,
+ Codebot.Interop.Windows.Direct2D, Codebot.Interop.Windows.GdiPlus,
+ Codebot.Interop.Windows.ImageCodecs, Codebot.Interop.Windows.Msxml,
+ Codebot.Networking.Ftp, Codebot.Networking.Storage, Codebot.Networking.Unix,
+ Codebot.Networking.Web, Codebot.System, Codebot.Support,
+ Codebot.Text.Formats, Codebot.Text.Json, Codebot.Text, Codebot.Text.Xml,
+ Codebot.Text.Store, Codebot.IO.SerialPort, Codebot.Unique, Codebot.Process,
+ LazarusPackageIntf;
+
+implementation
+
+procedure Register;
+begin
+end;
+
+initialization
+ RegisterPackage('codebot', @Register);
+end.
diff --git a/source/codebot/codebot.process.pas b/source/codebot/codebot.process.pas
new file mode 100644
index 0000000..0a0e3b4
--- /dev/null
+++ b/source/codebot/codebot.process.pas
@@ -0,0 +1,231 @@
+(********************************************************)
+(* *)
+(* Codebot Pascal Library *)
+(* http://cross.codebot.org *)
+(* Modified November 2025 *)
+(* *)
+(********************************************************)
+
+{ }
+unit Codebot.Process;
+
+{$i codebot.inc}
+
+interface
+
+uses
+ SysUtils,
+ Classes,
+ Codebot.System;
+
+{ TExternalCommand provides a simplified way to run external programs
+where you want to record their output and detect when they have completed }
+
+type
+ TLineReadEvent = procedure(Sender: TObject; const Line: string) of object;
+
+ EExternalCommandException = class(Exception);
+
+ TExternalCommand = class(TComponent)
+ private
+ FCommand: string;
+ FArguments: TStrings;
+ FBufferOutput: Boolean;
+ FOutput: TStrings;
+ FLine: string;
+ FRunning: Boolean;
+ FThread: TSimpleThread;
+ FOnLineRead: TLineReadEvent;
+ FOnComplete: TNotifyEvent;
+ procedure SyncLineRead;
+ procedure SyncComplete;
+ procedure ThreadRun(Thread: TSimpleThread);
+ procedure SetArguments(Value: TStrings);
+ public
+ constructor Create(AOwner: TComponent); override;
+ destructor Destroy; override;
+ { Run begins execution of the external program }
+ procedure Run;
+ { Kill aborts execution of the external program }
+ procedure Kill;
+ { Output contains all liens read from the program }
+ property Output: TStrings read FOutput;
+ { Running is true while the external program is executing }
+ property Running: Boolean read FRunning;
+ published
+ { The file name of the external program to execute }
+ property Command: string read FCommand write FCommand;
+ { Any command line arguments provided to the above program }
+ property Arguments: TStrings read FArguments write SetArguments;
+ { When BufferOutput is true all lines read are stored in the output property }
+ property BufferOutput: Boolean read FBufferOutput write FBufferOutput default True;
+ { OnLineRead is fired each time a complete line is read from the running program }
+ property OnLineRead: TLineReadEvent read FOnLineRead write FOnLineRead;
+ { OnComplete is fire when the program completes }
+ property OnComplete: TNotifyEvent read FOnComplete write FOnComplete;
+ end;
+
+procedure RunCommand(const Command: string; Output: TStrings = nil); overload;
+procedure RunCommand(const Command: string; const Arg0: string; Output: TStrings = nil); overload;
+procedure RunCommand(const Command: string; const Arg0, Arg1: string; Output: TStrings = nil); overload;
+procedure RunCommand(const Command: string; const Arg0, Arg1, Arg2: string; Output: TStrings = nil); overload;
+
+implementation
+
+uses
+ Process;
+
+{ TExternalCommand }
+
+constructor TExternalCommand.Create(AOwner: TComponent);
+begin
+ inherited Create(AOwner);
+ FBufferOutput := True;
+ FArguments := TStringList.Create;
+ FOutput := TStringList.Create;
+end;
+
+destructor TExternalCommand.Destroy;
+begin
+ Kill;
+ while FRunning do
+ begin
+ Sleep(10);
+ if FRunning then
+ PumpMessages;
+ end;
+ FOutput.Free;
+ inherited Destroy;
+end;
+
+procedure TExternalCommand.ThreadRun(Thread: TSimpleThread);
+var
+ P: TProcess;
+ C: Char;
+begin
+ P := TProcess.Create(nil);
+ try
+ P.Executable := FCommand;
+ if FArguments.Count > 0 then
+ P.Parameters.Assign(FArguments);
+ P.Options := [poUsePipes, poStderrToOutPut];
+ P.Execute;
+ while (not FThread.Terminated) and P.Running do
+ while (not FThread.Terminated) and (P.Output.NumBytesAvailable > 0) do
+ begin
+ FLine := '';
+ repeat
+ C := Char(P.Output.ReadByte);
+ if C = #13 then
+ Continue;
+ if C = #10 then
+ Break;
+ FLine := FLine + C;
+ until P.Output.NumBytesAvailable = 0;
+ if not FThread.Terminated then
+ Thread.Synchronize(SyncLineRead);
+ end;
+ if FThread.Terminated then
+ P.Terminate(0);
+ if not FThread.Terminated then
+ SyncComplete;
+ FRunning := False;
+ finally
+ P.Free;
+ end;
+end;
+
+procedure TExternalCommand.Run;
+begin
+ if FRunning then
+ raise EExternalCommandException.Create('External command is already running');
+ if FCommand = '' then
+ raise EExternalCommandException.Create('External command is not set');
+ FRunning := True;
+ FOutput.Clear;
+ FThread := ThreadExecute(ThreadRun);
+end;
+
+procedure TExternalCommand.Kill;
+begin
+ if FRunning then
+ FThread.Terminate;
+end;
+
+procedure TExternalCommand.SyncLineRead;
+begin
+ if FBufferOutput then
+ FOutput.Add(FLine);
+ if Assigned(FOnLineRead) then
+ FOnLineRead(Self, FLine);
+end;
+
+procedure TExternalCommand.SyncComplete;
+begin
+ FRunning := False;
+ if Assigned(FOnComplete) then
+ FOnComplete(Self);
+end;
+
+procedure TExternalCommand.SetArguments(Value: TStrings);
+begin
+ FOutput.Assign(Value);
+end;
+
+{ RunCommand }
+
+procedure RunCommand(const Command: string; Output: TStrings = nil);
+begin
+ RunCommand(Command, '', '', '', Output);
+end;
+
+procedure RunCommand(const Command: string; const Arg0: string; Output: TStrings = nil);
+begin
+ RunCommand(Command, Arg0, '', '', Output);
+end;
+
+procedure RunCommand(const Command: string; const Arg0, Arg1: string; Output: TStrings = nil);
+begin
+ RunCommand(Command, Arg0, Arg1, '', Output);
+end;
+
+procedure RunCommand(const Command: string; const Arg0, Arg1, Arg2: string; Output: TStrings = nil);
+var
+ P: TProcess;
+ C: Char;
+ S: string;
+begin
+ if Output <> nil then
+ Output.Clear;
+ P := TProcess.Create(nil);
+ try
+ P.Executable := Command;
+ if Arg0 <> '' then
+ P.Parameters.Add(Arg0);
+ if Arg1 <> '' then
+ P.Parameters.Add(Arg1);
+ if Arg2 <> '' then
+ P.Parameters.Add(Arg2);
+ P.Options := [poUsePipes, poStderrToOutPut];
+ P.Execute;
+ while P.Running do
+ while P.Output.NumBytesAvailable > 0 do
+ begin
+ S := '';
+ repeat
+ C := Char(P.Output.ReadByte);
+ if C = #13 then
+ Continue;
+ if C = #10 then
+ Break;
+ S := S + C;
+ until P.Output.NumBytesAvailable = 0;
+ if Output <> nil then
+ Output.Add(S);
+ end;
+ finally
+ P.Free;
+ end;
+end;
+
+end.
diff --git a/source/codebot/codebot.support.pas b/source/codebot/codebot.support.pas
new file mode 100644
index 0000000..74f4b5b
--- /dev/null
+++ b/source/codebot/codebot.support.pas
@@ -0,0 +1,216 @@
+(********************************************************)
+(* *)
+(* Codebot Pascal Library *)
+(* http://cross.codebot.org *)
+(* Modified September 2023 *)
+(* *)
+(********************************************************)
+
+{ }
+unit Codebot.Support;
+
+{$i codebot.inc}
+
+interface
+
+uses
+ Classes,
+ Codebot.System;
+
+{ IAsyncRunner\ }
+
+type
+ IAsyncRunnerBase = interface
+ ['{63E332A4-84A4-449F-B258-C2A8BB51403D}']
+ { Tick ahead progress by a delta amount }
+ procedure Tick(Delta: Int64);
+ end;
+
+ IAsyncRunner = interface(IAsyncRunnerBase)
+ ['{631018B8-D7D1-4C2A-928E-124500AFBA03}']
+ { Nofity fires the update event if the status has changed }
+ procedure Notify(Status: TAsyncStatus; Result: T);
+ end;
+
+{ TAsyncTaskRunner\ }
+
+ TAsyncTaskRunner = class(TInterfacedObject, IAsyncTask, IAsyncRunnerBase,
+ IAsyncRunner)
+ public
+ type
+ TNotifyComplete = procedure(Task: IAsyncTask; Result: T) of object;
+ private
+ FOnComplete: TNotifyComplete;
+ FCancelled: Integer;
+ FData: TObject;
+ FOwnsObject: Boolean;
+ FProgress: Int64;
+ FStartTime: TDateTime;
+ FStartQuery: Double;
+ FDuration: Double;
+ FStatus: TAsyncStatus;
+ { IAsyncTask }
+ function GetCancelled: Boolean;
+ function GetData: TObject;
+ function GetProgress: Int64;
+ function GetStartTime: TDateTime;
+ function GetDuration: Double;
+ function GetStatus: TAsyncStatus;
+ procedure Cancel;
+ procedure Wait;
+ { IAsyncRunnerBase }
+ procedure Tick(Delta: Int64);
+ { IAsyncRunner }
+ procedure Notify(Status: TAsyncStatus; Result: T);
+ public
+ constructor Create(OnComplete: TNotifyComplete; Data: TObject = nil; OwnsObject: Boolean = False); virtual;
+ destructor Destroy; override;
+ end;
+
+{ TThreadRunner\ }
+
+ TThreadRunner = class(TThread)
+ public
+ type
+ TRunnerProc = procedure(var Params: T; Task: IAsyncTask);
+ private
+ FParams: T;
+ FTask: IAsyncTask;
+ FOnExecute: TRunnerProc;
+ FOnComplete: TRunnerProc;
+ protected
+ procedure Complete;
+ procedure Execute; override;
+ public
+ constructor Create(const Params: T; Task: IAsyncTask; OnExecute, OnComplete: TRunnerProc);
+ end;
+
+const
+ BoolAsync: array[Boolean] of TAsyncStatus = (asyncFail, asyncSuccess);
+
+implementation
+
+{ TAsyncTaskRunner }
+
+constructor TAsyncTaskRunner.Create(OnComplete: TNotifyComplete; Data: TObject = nil; OwnsObject: Boolean = False);
+begin
+ inherited Create;
+ FOnComplete := OnComplete;
+ FData := Data;
+ FOwnsObject := OwnsObject;
+ FStartTime := Now;
+ FStartQuery := TimeQuery;
+end;
+
+destructor TAsyncTaskRunner.Destroy;
+begin
+ if FOwnsObject then
+ FData.Free;
+ inherited Destroy;
+end;
+
+{ TAsyncTaskRunner.IAsyncTask }
+
+function TAsyncTaskRunner.GetCancelled: Boolean;
+begin
+ Result := FCancelled > 0;
+end;
+
+function TAsyncTaskRunner.GetData: TObject;
+begin
+ Result := FData;
+end;
+
+function TAsyncTaskRunner.GetProgress: Int64;
+begin
+ Result := FProgress;
+end;
+
+function TAsyncTaskRunner.GetStartTime: TDateTime;
+begin
+ Result := FStartTime;
+end;
+
+function TAsyncTaskRunner.GetDuration: Double;
+begin
+ if FDuration = 0 then
+ Result := TimeQuery - FStartQuery
+ else
+ Result := FDuration;
+end;
+
+function TAsyncTaskRunner.GetStatus: TAsyncStatus;
+begin
+ Result := FStatus;
+end;
+
+procedure TAsyncTaskRunner.Cancel;
+begin
+ InterlockedIncrement(FCancelled);
+end;
+
+procedure TAsyncTaskRunner.Wait;
+begin
+ while Assigned(PumpMessagesProc) do
+ begin
+ if GetStatus = asyncBusy then
+ PumpMessages
+ else
+ Exit;
+ end;
+ raise EAsyncException.Create('PumpMessagesProc must be assigned in order to wait');
+end;
+
+{ IAsyncRunnerBase }
+
+procedure TAsyncTaskRunner.Tick(Delta: Int64);
+begin
+ FProgress := FProgress + Delta;
+end;
+
+{ TAsyncTaskRunner.IAsyncTaskTask }
+
+procedure TAsyncTaskRunner.Notify(Status: TAsyncStatus; Result: T);
+var
+ S: TAsyncStatus;
+begin
+ if FStatus <> asyncBusy then
+ Exit;
+ if FCancelled > 0 then
+ S := asyncCanceled
+ else
+ S := Status;
+ if S <> asyncBusy then
+ begin
+ FStatus := S;
+ FDuration := TimeQuery - FStartQuery;
+ if Assigned(FOnComplete) then
+ FOnComplete(Self, Result);
+ end;
+end;
+
+{ TThreadRunner }
+
+constructor TThreadRunner.Create(const Params: T; Task: IAsyncTask; OnExecute, OnComplete: TRunnerProc);
+begin
+ FParams := Params;
+ FTask := Task;
+ FOnExecute := OnExecute;
+ FOnComplete := OnComplete;
+ inherited Create(False);
+end;
+
+procedure TThreadRunner.Complete;
+begin
+ FOnComplete(FParams, FTask);
+end;
+
+procedure TThreadRunner.Execute;
+begin
+ FreeOnTerminate := True;
+ FOnExecute(FParams, FTask);
+ Synchronize(Complete);
+end;
+
+end.
+
diff --git a/source/codebot.system.pas b/source/codebot/codebot.system.pas
similarity index 78%
rename from source/codebot.system.pas
rename to source/codebot/codebot.system.pas
index 6f5b5ea..dd3a0a4 100644
--- a/source/codebot.system.pas
+++ b/source/codebot/codebot.system.pas
@@ -2,7 +2,7 @@
(* *)
(* Codebot Pascal Library *)
(* http://cross.codebot.org *)
-(* Modified November 2015 *)
+(* Modified October 2023 *)
(* *)
(********************************************************)
@@ -17,7 +17,7 @@ interface
{ Codebot core unit }
Codebot.Core,
{ Free pascal units }
- SysUtils, Classes, FileUtil;
+ SysUtils, Classes;
{$region types}
type
@@ -27,11 +27,7 @@ interface
PLargeInt = ^LargeInt;
LargeWord = QWord;
PLargeWord = ^LargeWord;
-{$ifdef cpu64}
- SysInt = Int64;
-{$else}
- SysInt = LongInt;
-{$endif}
+ SysInt = NativeInt;
PSysInt = ^SysInt;
HFile = Pointer;
{$endregion}
@@ -59,24 +55,29 @@ ELibraryException = class(Exception)
property ModuleName: string read FModuleName;
property ProcName: string read FProcName;
end;
+
+ TPlatform = (platformLinux, platformMac, platformWindowsXP, platformWindows);
+
+function GetPlatform: TPlatform;
{$endregion}
+type
+ TArray = array of T;
+
{$region system}
-procedure FillZero(out Buffer; Size: UIntPtr); inline;
+procedure FillZero(out Buffer; Size: UIntPtr);
{$endregion}
{$region generic containers}
-{ TArray is a shortvut to a dtyped dynamic array }
+{ TArray is a shortcut to a typed dynamic array }
type
- TArray = array of T;
-
{ TCompare\ is used to compare two items }
TCompare = function(constref A, B: T): Integer;
{ TConvert\ is used to convert from one type to another }
// TConvert = function(constref Item: TItem): T; see issue #28766
{ TConvertString\ is used to convert a type to a string }
- TConvertString = function(constref Item: TItem): string;
+ TConvertString = function(constref Item: TItem): string;
{ TFilterFunc\ is used to test if and item passes a test }
@@ -131,13 +132,14 @@ type TArrayListEnumerator = class(TArrayEnumerator) end;
function GetLength: Integer;
procedure SetLength(Value: Integer);
function GetData: Pointer;
- function GetItem(Index: Integer): T;
+ function GetItem(Index: Integer): T;
procedure SetItem(Index: Integer; const Value: T);
public
class var DefaultCompare: TCompare;
class var DefaultConvertString: TConvertString;
{ The array acting as a list }
var Items: TArray;
+ class function ArrayOf(const Items: array of T): TArrayList; static;
class function Convert: TArrayList; static;
{ Convert a list to an array }
class operator Implicit(const Value: TArrayList): TArray;
@@ -145,6 +147,10 @@ type TArrayListEnumerator = class(TArrayEnumerator) end;
class operator Implicit(const Value: TArray): TArrayList;
{ Convert an open array to a list }
class operator Implicit(const Value: array of T): TArrayList;
+ { Performs a simple safe copy of up to N elements }
+ procedure Copy(out List: TArrayList; N: Integer);
+ { Performs a fast unsafe copy of up to N elements }
+ procedure CopyFast(out List: TArrayList; N: Integer);
{ Returns the lower bounds of the list }
function Lo: Integer;
{ Returns the upper bounds of the list }
@@ -206,6 +212,43 @@ function DefaultFloatCompare(constref A, B: Float): Integer;
function DefaultFloatConvertString(constref Item: Float): string;
{doc on}
+resourcestring
+ SStackSize = 'Cannot create a stack of size less than 1';
+ SStackPush = 'Stack push would overflow';
+ SStackPop = 'Stack pop would underflow';
+ SStackEmpty = 'Stack does not contain any items';
+
+type
+ EStackError = class(Exception);
+
+{ TStack\ }
+
+ TStack = record
+ private
+ FItems: TArray;
+ FSize: Integer;
+ FIndex: Integer;
+ function GetIsEmpty: Boolean;
+ function GetFirst: T;
+ procedure SetFirst(const Value: T);
+ function GetLast: T;
+ procedure SetLast(const Value: T);
+ public
+ { Create a stack with room for size items }
+ class function Create(Size: Integer): TStack; static;
+ { Push a new item on the stack }
+ procedure Push(const Value: T);
+ { Pop an item from the stack }
+ function Pop: T;
+ { IsEmpty is true if index is less than zero }
+ property IsEmpty: Boolean read GetIsEmpty;
+ { Index is the current item on the stack }
+ property Index: Integer read FIndex;
+ { The item with index of zero on the stack }
+ property First: T read GetFirst write SetFirst;
+ { The item with index of index on the stack }
+ property Last: T read GetLast write SetLast;
+ end;
{$endregion}
{$region math routines}
@@ -382,6 +425,8 @@ function SwitchIndex(const Switch: string): Integer;
[group string] }
function SwitchValue(const Switch: string): string;
+{ Convert an string to a binary format eg: ¢ = 11000010 10100010 [group string] }
+function StrToBin(S: string): string;
{ Convert an integer to a string [group string] }
function IntToStr(Value: Integer): string;
{ Convert a string to an integer. Can throw an EConvertError exception. [group string] }
@@ -452,6 +497,8 @@ StringHelper = record helper for string
function MatchCount(const SubStr: string; IgnoreCase: Boolean = False): Integer;
{ Returns an array of indices of a substring matches within a string }
function Matches(const SubStr: string; IgnoreCase: Boolean = False): IntArray;
+ { Removes the last occurance of a substring }
+ function RemoveLast(const SubStr: string; IgnoreCase: Boolean = False): string;
{ Replaces every instance of a pattern in a string }
function Replace(const OldPattern, NewPattern: string; IgnoreCase: Boolean = False): string;
{ Replaces the first instance of a pattern in a string }
@@ -552,6 +599,10 @@ TStringsHelper = class helper for TStrings
procedure AddFormat(const S: string; const Args: array of const);
function Contains(const S: string; IgnoreCase: Boolean = False): Boolean;
end;
+
+{ Returns the current date and time }
+
+function Now: TDateTime;
{$endregion}
{$region file management routines}
@@ -560,7 +611,7 @@ TStringsHelper = class helper for TStrings
{ Delete a file }
function FileDelete(const FileName: string): Boolean;
{ Copy a file optionally preserving file time }
-function FileCopy(const SourceName, DestName: string; PreserveTime: Boolean = False): Boolean;
+// function FileCopy(const SourceName, DestName: string; PreserveTime: Boolean = False): Boolean;
{ Rename a file }
function FileRename(const OldName, NewName: String): Boolean;
{ Determine if a file exists }
@@ -571,6 +622,8 @@ function FileSize(const FileName: string): LargeWord;
function FileDate(const FileName: string): TDateTime;
{ Extract the name portion of a file name [group files] }
function FileExtractName(const FileName: string): string;
+{ Extract the name portion of a file name [group files] }
+function FileExtractNameOnly(const FileName: string): string;
{ Extract the extension portion of a file name [group files] }
function FileExtractExt(const FileName: string): string;
{ Change the extension portion of a file name [group files] }
@@ -585,6 +638,8 @@ function FileReadStr(const FileName: string): string;
procedure FileWriteLine(const FileName: string; const Line: string);
{ Create a directory }
function DirCreate(const Dir: string): Boolean;
+{ Change to a new directory }
+procedure DirChange(const Dir: string);
{ Get the current working directory }
function DirGetCurrent: string;
{ Set the current working directory }
@@ -600,23 +655,73 @@ function DirForce(const Dir: string): Boolean;
{ Change path delimiter to match system settings [group files] }
function PathAdjustDelimiters(const Path: string): string;
{ Combine two paths }
-function PathCombine(const A, B: string): string;
+function PathCombine(const A, B: string; IncludeDelimiter: Boolean = False): string;
{ Expand a path to the absolute path }
function PathExpand(const Path: string): string;
{ Include the end delimiter for a path }
function PathIncludeDelimiter(const Path: string): string;
{ Exclude the end delimiter for a path }
function PathExcludeDelimiter(const Path: string): string;
+{ Read all the content of a stream as text }
+function StreamReadStr(Stream: TStream): string;
+{ Load a resource data given a name. }
+function ResLoadData(const ResName: string; out Stream: TStream): Boolean;
+{ Load a resource text given a name. }
+function ResLoadText(const ResName: string; out Text: string): Boolean;
+{ Save a resource data to a file given a name. }
+function ResSaveData(const ResName, FileName: string): Boolean;
{ Returns the location of the application configuration file }
function ConfigAppFile(Global: Boolean; CreateDir: Boolean = False): string;
{ Returns the location of the application configuration directory }
function ConfigAppDir(Global: Boolean; CreateDir: Boolean = False): string;
+{ Find files from ParamStr at start index returning a strings object }
+procedure FindFileParams(StartIndex: Integer; out FileParams: TStrings);
+
+const
+ faReadOnly = $00000001;
+ faHidden = $00000002;
+ faSysFile = $00000004;
+ faVolumeId = $00000008;
+ faDirectory = $00000010;
+ faArchive = $00000020;
+ faSymLink = $00000040;
+ faAnyFile = $0000003f;
+
{ FindOpen corrects path delimiters and convert search to an output parameter }
function FindOpen(const Path: string; Attr: Longint; out Search: TSearchRec): LongInt;
-{ Find files in a path returning a strings object }
-function FindFiles(const Path: string): TStrings;
-{ Find files from ParamStr at start index returning a strings object }
-function FindFileParams(StartIndex: Integer): TStrings;
+{ Find file system items from a path outputting to a TStrings object }
+procedure FindFiles(const Path: string; out FileSearch: TStrings; Attributes: Integer = 0); overload;
+
+{ TFileSearchItem }
+
+type
+ TFileSearchItem = record
+ public
+ { The full path to the file or folder }
+ Name: string;
+ { The size in bytes of the item }
+ Size: LargeInt;
+ { The last modified date and time }
+ Modified: TDateTime;
+ { Details about the type of item found }
+ Attributes: Integer;
+ end;
+
+ TFileSearch = type TArrayList;
+
+{ Find file system items from a path outputting to a TFileSearch array }
+procedure FindFiles(const Path: string; out FileSearch: TFileSearch; Attributes: Integer = 0); overload;
+
+type
+ TFileSearchHelper = record helper for TFileSearch
+ public
+ { Sort search items by file name }
+ procedure SortName(Order: TSortingOrder = soAscend);
+ { Sort search items by file size }
+ procedure SortSize(Order: TSortingOrder = soAscend);
+ { Sort search items by file modified date }
+ procedure SortModified(Order: TSortingOrder = soAscend);
+ end;
{$endregion}
{ TNamedValues\ is a simple case insensitive string based dictionary
@@ -645,13 +750,15 @@ TNamedValues = record
procedure Delete(Index: Integer);
{ Removes all named values setting the count of the dictionary to 0 }
procedure Clear;
+ { Returns true if a named key is in the dictionary }
+ function HasName(const Name: string): Boolean;
{ The number of key value pairs in the dictionary }
property Count: Integer read GetCount;
- { Returns true if ther are no named values in the dictionary }
+ { Returns true if there are no named values in the dictionary }
property Empty: Boolean read GetEmpty;
{ Names indexed by an integer }
property Names[Index: Integer]: string read GetName;
- { Values indexed by a name }
+ { Values indexed by a named key }
property Values[Name: string]: T read GetValue; default;
{ Values indexed by an integer }
property ValueByIndex[Index: Integer]: T read GetValueByIndex;
@@ -667,10 +774,85 @@ TNamedEnumerable = record
function GetEnumerator: IEnumerator;
end;
+{ INamedValues is a reference type for TNamedValues }
+
+ INamedValues = interface(IEnumerable)
+ ['{D228ADD8-4C4E-4C6C-A6F6-FA17FC307253}']
+ function GetCount: Integer;
+ function GetEmpty: Boolean;
+ function GetName(Index: Integer): string;
+ function GetValue(const Name: string): T;
+ function GetValueByIndex(Index: Integer): T;
+ procedure Add(const Name: string; const Value: T);
+ procedure Remove(const Name: string);
+ procedure Delete(Index: Integer);
+ procedure Clear;
+ property Count: Integer read GetCount;
+ property Empty: Boolean read GetEmpty;
+ property Names[Index: Integer]: string read GetName;
+ property Values[Name: string]: T read GetValue; default;
+ property ValueByIndex[Index: Integer]: T read GetValueByIndex;
+ end;
+
{ TNamedStrings is a dictionary of string name value pairs }
TNamedStrings = TNamedValues;
+{ INamedStrings is a reference type for TNamedStrings }
+
+ INamedStrings = interface(INamedValues)
+ ['{C03EF776-46AC-4757-8654-F31EC34E67A7}']
+ end;
+
+{ TNamedValuesIntf exposes INamedValues }
+
+ TNamedValuesIntf = class(TInterfacedObject, IEnumerable, INamedValues)
+ private
+ FData: TNamedValues;
+ public
+ { IEnumerable }
+ function GetEnumerator: IEnumerator;
+ { INamedValues }
+ function GetCount: Integer;
+ function GetEmpty: Boolean;
+ function GetName(Index: Integer): string;
+ function GetValue(const Name: string): T;
+ function GetValueByIndex(Index: Integer): T;
+ procedure Add(const Name: string; const Value: T);
+ procedure Remove(const Name: string);
+ procedure Delete(Index: Integer);
+ procedure Clear;
+ end;
+
+{ TNamedStringsIntf exposes INamedStrings }
+
+ TNamedStringsIntf = class(TNamedValuesIntf, INamedStrings)
+ end;
+
+{ TInterfacedFree creates a connection between an interface and a component.
+ When your interface is destroyed first then ReleaseComponent is invoked. You
+ may override ReleaseComponent to perform househeeping tasks such as
+ unsubscribing from events on component. If the component is destroyed first
+ then the corresponding component field automatically becomes nil.
+
+ Note:
+
+ If you override ReleaseComponent be sure to call the inherited method after
+ you complete your housheeping tasks. }
+
+ TInterfacedFree = class(TInterfacedObject)
+ private
+ FNotify: TObject;
+ procedure NotifyFree(Sender: TObject);
+ protected
+ procedure ReleaseComponent; virtual;
+ public
+ { Holds a reference to a component until it is destroyed }
+ Component: TComponent;
+ constructor Create(AComponent: TComponent); virtual;
+ destructor Destroy; override;
+ end;
+
{ IDelegate\ allows event subscribers to add or remove their event handlers
See also
members> }
@@ -893,7 +1075,50 @@ function MutexCreate: IMutex;
{ Create a new event object }
function EventCreate: IEvent;
+{ The following is a summary of async status values.
+
+ asyncBusy: The task is still running and duration is increasing
+ asyncSuccess: The task completed with success
+ asyncFail: The task completed with failure
+ asyncCanceled: The task was cancelled and did not complete }
+
type
+ TAsyncStatus = (asyncBusy, asyncSuccess, asyncFail, asyncCanceled);
+
+ EAsyncException = class(Exception);
+
+{ IAsyncTask is used to perform cancellable tasks in background threads. When
+ a task is created its initial status is busy and the start time is recorded.
+
+ See also
+ }
+
+ IAsyncTask = interface
+ ['{C51218C0-526D-4167-B778-3018E5C00509}']
+ function GetCancelled: Boolean;
+ function GetData: TObject;
+ function GetProgress: Int64;
+ function GetStartTime: TDateTime;
+ function GetDuration: Double;
+ function GetStatus: TAsyncStatus;
+ { Cancel marks the task as cancelled }
+ procedure Cancel;
+ { Waits for the task to complete }
+ procedure Wait;
+ { Cancelled is true if cancel has been invoked at least one time }
+ property Cancelled: Boolean read GetCancelled;
+ { Data can be set to be owned by the task }
+ property Data: TObject read GetData;
+ { Progress is a number to indicating the amount of work done }
+ property Progress: Int64 read GetProgress;
+ { Start time is a record of when the task began }
+ property StartTime: TDateTime read GetStartTime;
+ { Duration is a record of time in seconds the task lasted }
+ property Duration: Double read GetDuration;
+ { Status of the task }
+ property Status: TAsyncStatus read GetStatus;
+ end;
+
{doc off}
TSimpleThread = class;
{doc on}
@@ -909,31 +1134,47 @@ TSimpleThread = class;
TSimpleThread = class(TThread)
private
FExecuteMethod: TThreadExecuteMethod;
+ FTempStatus: string;
FStatus: string;
FOnStatus: TNotifyEvent;
procedure DoStatus;
procedure SetStatus(const Value: string);
protected
- { Sets FreeOnTermiante to True and executes the method }
+ { Sets FreeOnTerminate to True and executes the method }
procedure Execute; override;
public
- { Starts an executing method on a new thread }
+ { Create immediately starts ExecuteMethod on a new thread }
constructor Create(ExecuteMethod: TThreadExecuteMethod;
OnStatus: TNotifyEvent = nil; OnTerminate: TNotifyEvent = nil);
- { Synch can be used by the executing method to move execution to the main thread }
- procedure Synch(Method: TThreadMethod);
+ { Synchronize can be used by ExecuteMethod to invoke a method
+ on the main thread }
+ procedure Synchronize(Method: TThreadMethod);
{ You should only set status inside ExecuteMethod }
property Status: string read FStatus write SetStatus;
- { Terminated is set to True when Terminated is called }
+ { Terminated is set to True after the Terminate method is called }
property Terminated;
end;
+{ TThreadExecuteProc is the callback invoked when a TSimpleThread is created }
+
+ TThreadExecuteProc = procedure(Thread: TSimpleThread);
+
+{ Execute a procedure inside a simple thread }
+
+function ThreadExecute(ThreadMethod: TThreadExecuteMethod): TSimpleThread; overload;
+function ThreadExecute(ThreadProc: TThreadExecuteProc): TSimpleThread; overload;
+function ThreadExecute(Proc: TProcedure): TSimpleThread; overload;
+
+{ Sleep for a given number of milliseconds }
+
+procedure Sleep(Milliseconds: Cardinal);
+
{$endregion}
{$region waiting routines}
{ Definable message pump }
var
- PumpMessagesProc: procedure;
+ PumpMessagesProc: procedure of object;
{ Retrieve messages from a queue while waiting }
procedure PumpMessages;
@@ -983,6 +1224,50 @@ constructor ELibraryException.Create(const ModuleName, ProcName: string);
inherited Create(S);
end;
+{$ifdef windows}
+var
+ PlatformState: TPlatform;
+
+type
+ TOSVersionInfo = record
+ dwOSVersionInfoSize: DWord;
+ dwMajorVersion: DWord;
+ dwMinorVersion: DWord;
+ dwBuildNumber: DWord;
+ dwPlatformId: DWord;
+ szCSDVersion: array[0..127] of Char;
+ end;
+
+function GetVersionExA(var Info: TOSVersionInfo): LongBool; stdcall; external 'kernel32.dll';
+{$endif}
+
+function GetPlatform: TPlatform;
+{$ifdef windows}
+var
+ Info: TOSVersionInfo;
+{$endif}
+begin
+ {$ifdef windows}
+ if PlatformState < platformWindowsXP then
+ begin
+ FillChar(Info, SizeOf(Info), 0);
+ Info.dwOSVersionInfoSize := SizeOf(TOSVersionInfo);
+ GetVersionExA(Info);
+ if Info.dwMajorVersion > 5 then
+ PlatformState := platformWindows
+ else
+ PlatformState := platformWindowsXP;
+ end;
+ Exit(PlatformState);
+ {$endif}
+ {$ifdef darwin}
+ Exit(platformLinux);
+ {$endif}
+ {$ifdef linux}
+ Exit(platformLinux);
+ {$endif}
+end;
+
procedure LibraryExcept(const ModuleName: string; ProcName: string);
begin
raise ELibraryException.Create(ModuleName, ProcName);
@@ -1087,8 +1372,8 @@ function IntPower(Base: Float; Exponent: Integer): Float;
var
I: LongInt;
begin
- if (Base = 0.0) and (Exponent = 0) then
- Exit(1);
+ if (Base = 0.0) and (Exponent = 0) then
+ Exit(1);
I := Abs(Exponent);
Result := 1.0;
while I > 0 do
@@ -1464,7 +1749,7 @@ function StrTrim(const S: string): string;
begin
Len := Length(S);
while (Len > 0) and (S[Len] in WhiteSpace) do
- Dec(Len);
+ Dec(Len);
I := 1;
while ( I <= Len) and (S[I] in WhiteSpace) do
Inc(I);
@@ -1513,7 +1798,7 @@ function StrFindCount(const S, SubStr: string; IgnoreCase: Boolean = False): Int
if Index > 0 then
begin
Inc(Result);
- Start := Index + 1;
+ Start := Index + Length(SubStr);
end;
until Index = 0;
end;
@@ -1529,44 +1814,51 @@ function StrFindIndex(const S, SubStr: string; IgnoreCase: Boolean = False): Int
begin
Start := StrFind(S, SubStr, Start, IgnoreCase);
Result[Index] := Start;
- Inc(Start);
+ Inc(Start, Length(SubStr));
Inc(Index);
end;
end;
+function StrRemoveLast(const S, SubStr: string; IgnoreCase: Boolean = False): string;
+begin
+ Result := S;
+ if StrEndsWith(S, SubStr, IgnoreCase) then
+ SetLength(Result, Length(Result) - Length(SubStr));
+end;
+
function StrReplace(const S, OldPattern, NewPattern: string; IgnoreCase: Boolean = False): string;
var
PosIndex: IntArray;
- I, J, K, L: Integer;
+ FindIndex, FindLen, OldIndex, OldLen, NewIndex, NewLen, I: Integer;
begin
PosIndex := StrFindIndex(S, OldPattern, IgnoreCase);
- if PosIndex.Length = 0 then
+ FindLen := PosIndex.Length;
+ if FindLen = 0 then
begin
Result := S;
Exit;
end;
- Result.length := S.Length + (NewPattern.Length - OldPattern.Length) * PosIndex.Length;
- I := 0;
- J := 1;
- K := 1;
- while K <= S.Length do
+ OldLen := S.Length;
+ NewLen := OldLen + NewPattern.Length * FindLen - OldPattern.Length * FindLen;
+ SetLength(Result, NewLen);
+ OldIndex := 1;
+ NewIndex := 1;
+ FindIndex := 0;
+ while OldIndex <= OldLen do
begin
- if K = PosIndex[I] then
+ if (FindIndex < FindLen) and (OldIndex = PosIndex[FindIndex]) then
begin
- if I < PosIndex.Hi then
- Inc(I);
- Inc(K, OldPattern.Length);
- for L := 1 to NewPattern.Length do
- begin
- Result[J] := NewPattern[L];
- Inc(J);
- end;
+ Inc(OldIndex, OldPattern.Length);
+ for I := 0 to NewPattern.Length - 1 do
+ Result[NewIndex + I] := NewPattern[I + 1];
+ Inc(NewIndex, NewPattern.Length);
+ Inc(FindIndex);
end
else
begin
- Result[J] := S[K];
- Inc(J);
- Inc(K);
+ Result[NewIndex] := S[OldIndex];
+ Inc(OldIndex);
+ Inc(NewIndex);
end;
end;
end;
@@ -1786,6 +2078,7 @@ function StrOf(C: Char; Len: Integer): string;
begin
if Len < 1 then
Exit;
+ Result := '';
SetLength(Result, Len);
for I := 1 to Len do
Result[I] := C;
@@ -1907,65 +2200,67 @@ function StrLineBreakStyle(const S: string): TTextLineBreakStyle;
function StrAdjustLineBreaks(const S: string; Style: TTextLineBreakStyle): string;
var
- Source,Dest: PChar;
+ Source, Dest: PChar;
DestLen: Integer;
- I,J,L: Longint;
-
+ I, J, L: Longint;
begin
Source:=Pointer(S);
- L:=Length(S);
- DestLen:=L;
- I:=1;
- while (I<=L) do
- begin
- case S[i] of
- #10: if (Style=tlbsCRLF) then
- Inc(DestLen);
- #13: if (Style=tlbsCRLF) then
- if (I '' then
+ Result := FormatDateTime(Format, Self)
else
Result := FormatDateTime('yyyy-mm-dd hh:nn:ss', Self);
end;
@@ -2520,6 +2844,11 @@ function TDateTimeHelper.Day: Word;
Result := D;
end;
+function Now: TDateTime;
+begin
+ Result := SysUtils.Now;
+end;
+
{ TStringsHelper }
procedure TStringsHelper.AddLine;
@@ -2542,28 +2871,52 @@ function TStringsHelper.Contains(const S: string; IgnoreCase: Boolean = False):
{$region file management routines}
function FileDelete(const FileName: string): Boolean;
begin
- Result := FileUtil.DeleteFileUTF8(FileName);
+ Result := DeleteFile(FileName);
end;
-function FileCopy(const SourceName, DestName: string;
+{function FileCopy(const SourceName, DestName: string;
PreserveTime: Boolean = False): Boolean;
begin
Result := CopyFile(SourceName, DestName, PreserveTime);
-end;
+end;}
function FileRename(const OldName, NewName: String): Boolean;
begin
- Result := FileUtil.RenameFileUTF8(OldName, NewName);
+ Result := RenameFile(OldName, NewName);
end;
function FileExists(const FileName: string): Boolean;
begin
- Result := FileUtil.FileExistsUTF8(FileName);
+ {if DirExists(FileName) then
+ Result := False
+ else}
+ Result := SysUtils.FileExists(FileName);
end;
function FileSize(const FileName: string): LargeWord;
+var
+ F: file of Byte;
begin
- Result := FileUtil.FileSize(FileName);
+ Result := 0;
+ if (FileExists(FileName)) then
+ begin
+ try
+ {$I-}
+ AssignFile(F, FileName);
+ Reset(F);
+ {$I+}
+ if (IOResult = 0) then
+ begin
+ Result := System.FileSize(F);
+ end
+ else
+ begin
+ Result := 0;
+ end;
+ finally
+ {$I-}CloseFile(F);{$I+}
+ end;
+ end;
end;
function FileDate(const FileName: string): TDateTime;
@@ -2576,6 +2929,12 @@ function FileExtractName(const FileName: string): string;
Result := StrLastOf(PathAdjustDelimiters(FileName), DirectorySeparator);
end;
+function FileExtractNameOnly(const FileName: string): string;
+begin
+ Result := FileExtractName(FileName);
+ Result := FileChangeExt(Result, '');
+end;
+
function FileExtractExt(const FileName: string): string;
begin
Result := StrLastOf(PathAdjustDelimiters(FileName), DirectorySeparator);
@@ -2621,7 +2980,7 @@ procedure FileWriteStr(const FileName: string; const Contents: string);
end;
function FileReadStr(const FileName: string): string;
-Const
+const
BufferSize = 1024 * 10;
MaxGrow = 1 shl 29;
var
@@ -2631,7 +2990,7 @@ function FileReadStr(const FileName: string): string;
I: Integer;
begin
Result := '';
- if FileExistsUTF8(FileName) then
+ if FileExists(FileName) then
begin
F := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
try
@@ -2658,7 +3017,7 @@ procedure FileWriteLine(const FileName: string; const Line: string);
F: TFileStream;
S: string;
begin
- if FileUtil.FileExistsUTF8(FileName) then
+ if FileExists(FileName) then
F := TFileStream.Create(FileName, fmOpenWrite)
else
F := TFileStream.Create(FileName, fmCreate);
@@ -2675,17 +3034,22 @@ procedure FileWriteLine(const FileName: string; const Line: string);
function DirCreate(const Dir: string): Boolean;
begin
- Result := FileUtil.ForceDirectoriesUTF8(Dir);
+ Result := ForceDirectories(Dir);
+end;
+
+procedure DirChange(const Dir: string);
+begin
+ ChDir(Dir);
end;
function DirGetCurrent: string;
begin
- Result := FileUtil.GetCurrentDirUTF8;
+ Result := GetCurrentDir;
end;
function DirSetCurrent(const Dir: string): Boolean;
begin
- Result := FileUtil.SetCurrentDirUTF8(Dir);
+ Result := SetCurrentDir(Dir);
end;
function DirGetTemp(Global: Boolean = False): string;
@@ -2695,17 +3059,19 @@ function DirGetTemp(Global: Boolean = False): string;
function DirDelete(const Dir: string; OnlyContents: Boolean = False): Boolean;
begin
- Result := DeleteDirectory(Dir, OnlyContents);
+ Result := RemoveDir(Dir);
+ if OnlyContents then
+ ForceDirectories(Dir);
end;
function DirExists(const Dir: string): Boolean;
begin
- Result := FileUtil.DirectoryExistsUTF8(Dir);
+ Result := DirectoryExists(Dir);
end;
function DirForce(const Dir: string): Boolean;
begin
- Result := ForceDirectoriesUTF8(Dir);
+ Result := ForceDirectories(Dir);
end;
function PathAdjustDelimiters(const Path: string): string;
@@ -2718,14 +3084,18 @@ function PathAdjustDelimiters(const Path: string): string;
{$warnings on}
end;
-function PathCombine(const A, B: string): string;
+function PathCombine(const A, B: string; IncludeDelimiter: Boolean = False): string;
begin
- Result := PathIncludeDelimiter(A) + PathExcludeDelimiter(B);
+ if IncludeDelimiter then
+ Result := PathIncludeDelimiter(A) + PathIncludeDelimiter(B)
+ else
+ Result := PathIncludeDelimiter(A) + PathExcludeDelimiter(B);
+ Result := PathAdjustDelimiters(Result);
end;
function PathExpand(const Path: string): string;
begin
- Result := ExpandFileNameUTF8(Path);
+ Result := ExpandFileName(Path);
end;
function PathIncludeDelimiter(const Path: string): string;
@@ -2738,14 +3108,99 @@ function PathExcludeDelimiter(const Path: string): string;
Result := ExcludeTrailingPathDelimiter(Path);
end;
+function StreamReadStr(Stream: TStream): string;
+var
+ I: Integer;
+begin
+ I := Stream.Size;
+ SetLength(Result, I);
+ if I > 0 then
+ Stream.Read(PChar(Result)^, I);
+end;
+
+const
+ RT_RCDATA = PChar(10);
+
+function ResLoadData(const ResName: string; out Stream: TStream): Boolean;
+begin
+ Result := False;
+ Stream := nil;
+ if ResName = '' then
+ Exit;
+ if FindResource(Hinstance, PChar(ResName), RT_RCDATA) = 0 then
+ Exit;
+ Stream := TResourceStream.Create(HInstance, ResName, RT_RCDATA);
+ Result := True;
+end;
+
+function ResLoadText(const ResName: string; out Text: string): Boolean;
+var
+ S: TStream;
+ R: TResourceStream absolute S;
+ I: Integer;
+begin
+ Text := '';
+ Result := ResLoadData(ResName, S);
+ if Result then
+ try
+ I := S.Size;
+ if I < 1 then
+ Exit;
+ SetLength(Text, I);
+ Move(R.Memory^, PChar(Text)^, I);
+ finally
+ S.Free;
+ end;
+end;
+
+function ResSaveData(const ResName, FileName: string): Boolean;
+var
+ S: TStream;
+ R: TResourceStream absolute S;
+begin
+ Result := ResLoadData(ResName, S);
+ if Result then
+ try
+ R.SaveToFile(FileName);
+ finally
+ S.Free;
+ end;
+end;
+
function ConfigAppFile(Global: Boolean; CreateDir: Boolean = False): string;
begin
- Result := GetAppConfigFileUTF8(Global, False, CreateDir);
+ Result := ConfigAppDir(Global, CreateDir);
+ Result := PathCombine(Result, 'settings.cfg');
end;
function ConfigAppDir(Global: Boolean; CreateDir: Boolean = False): string;
begin
- Result := GetAppConfigDirUTF8(Global, CreateDir);
+ Result := GetAppConfigDir(Global);
+ if CreateDir and (not DirExists(Result)) then
+ DirCreate(Result);
+end;
+
+procedure FindFileParams(StartIndex: Integer; out FileParams: TStrings);
+var
+ Search: TStrings;
+ S: string;
+ I: Integer;
+begin
+ FileParams := TStringList.Create;
+ if StartIndex < 1 then
+ Exit;
+ for I := StartIndex to ParamCount do
+ begin
+ S := ParamStr(I);
+ if FileExists(S) then
+ FileParams.Add(S)
+ else
+ begin
+ FindFiles(S, Search);
+ FileParams.AddStrings(Search);
+ Search.Free;
+ end;
+ end;
end;
function FindOpen(const Path: string; Attr: Longint; out Search: TSearchRec): LongInt;
@@ -2753,7 +3208,7 @@ function FindOpen(const Path: string; Attr: Longint; out Search: TSearchRec): Lo
Result := FindFirst(PathAdjustDelimiters(Path), Attr, Search);
end;
-function FindFiles(const Path: string): TStrings;
+procedure FindFiles(const Path: string; out FileSearch: TStrings; Attributes: Integer = 0);
var
Name, Folder: string;
Search: TSearchRec;
@@ -2770,38 +3225,89 @@ function FindFiles(const Path: string): TStrings;
if Folder = Path then
Folder := '.'
end;
- Result := TStringList.Create;
- if FindOpen(PathCombine(Folder, Name), faAnyFile and (not faDirectory), Search) = 0 then
+ FileSearch := TStringList.Create;
+ if FindOpen(PathCombine(Folder, Name), Attributes, Search) = 0 then
begin
repeat
- Result.Add(PathCombine(Folder, Search.Name));
+ FileSearch.Add(PathCombine(Folder, Search.Name));
until FindNext(Search) <> 0;
FindClose(Search);
end;
end;
-function FindFileParams(StartIndex: Integer): TStrings;
+procedure FindFiles(const Path: string; out FileSearch: TFileSearch; Attributes: Integer = 0);
var
- Search: TStrings;
- S: string;
- I: Integer;
+ Name, Folder: string;
+ Search: TSearchRec;
+ Item: TFileSearchItem;
begin
- Result := TStringList.Create;
- if StartIndex < 1 then
- Exit;
- for I := StartIndex to ParamCount do
+ if DirectoryExists(Path) then
begin
- S := ParamStrUTF8(I);
- if FileUtil.FileExistsUTF8(S) then
- Result.Add(S)
- else
- begin
- Search := FindFiles(S);
- Result.AddStrings(Search);
- Search.Free;
- end;
+ Name := '*';
+ Folder := Path;
+ end
+ else
+ begin
+ Name := FileExtractName(Path);
+ Folder := FileExtractPath(Path);
+ if Folder = Path then
+ Folder := '.'
+ end;
+ FileSearch.Length := 0;
+ if FindOpen(PathCombine(Folder, Name), Attributes, Search) = 0 then
+ begin
+ repeat
+ Item.Name := PathCombine(Folder, Search.Name);
+ Item.Attributes := Search.Attr;
+ Item.Size := Search.Size;
+ Item.Modified := FileDate(Item.Name);
+ FileSearch.Push(Item);
+ until FindNext(Search) <> 0;
+ FindClose(Search);
end;
end;
+
+function FileItemSortName(constref A, B: TFileSearchItem): Integer;
+begin
+ {$ifdef windows}
+ Result := StrCompare(A.Name, B.Name, True);
+ {$else}
+ Result := StrCompare(A.Name, B.Name);
+ {$endif}
+end;
+
+procedure TFileSearchHelper.SortName(Order: TSortingOrder = soAscend);
+begin
+ Self.Sort(Order, FileItemSortName);
+end;
+
+function FileItemSortSize(constref A, B: TFileSearchItem): Integer;
+begin
+ Result := A.Size - B.Size;
+end;
+
+
+procedure TFileSearchHelper.SortSize(Order: TSortingOrder = soAscend);
+begin
+ Self.Sort(Order, FileItemSortSize);
+end;
+
+function FileItemSortModified(constref A, B: TFileSearchItem): Integer;
+begin
+ if A.Modified < B.Modified then
+ Result := 1
+ else if A.Modified > B.Modified then
+ Result := -1
+ else
+ Result := 0;
+end;
+
+procedure TFileSearchHelper.SortModified(Order: TSortingOrder = soAscend);
+begin
+ Self.Sort(Order, FileItemSortModified);
+end;
+
+
{$endregion}
{$region generic containers}
@@ -2859,6 +3365,43 @@ function TArrayList.GetEnumerator: IEnumerator;
Result.Push(I);
end;
+class function TArrayList.ArrayOf(const Items: array of T): TArrayList;
+var
+ I: Integer;
+begin
+ Result.Items := nil;
+ System.SetLength(Result.Items, System.Length(Items));
+ for I := 0 to System.Length(Items) - 1 do
+ Result.Items[I] := Items[I];
+end;
+
+procedure TArrayList.Copy(out List: TArrayList; N: Integer);
+var
+ I: Integer;
+begin
+ if N < 1 then
+ N := Length
+ else if N > Length then
+ N := Length;
+ List.Length := N;
+ if N < 1 then
+ Exit;
+ for I := 0 to N - 1 do
+ List.Items[I] := Items[I];
+end;
+
+procedure TArrayList.CopyFast(out List: TArrayList; N: Integer);
+begin
+ if N < 1 then
+ N := Length
+ else if N > Length then
+ N := Length;
+ List.Length := N;
+ if N < 1 then
+ Exit;
+ System.Move(Items[0], List.Items[0], N * SizeOf(T));
+end;
+
procedure TArrayList.Reverse;
var
Swap: T;
@@ -2960,6 +3503,7 @@ function TArrayList.Filter(Func: TFilterFunc): TArrayList;
I, J: Integer;
begin
J := System.Length(Items);
+ Result.Items := nil;
System.SetLength(Result.Items, J);
J := 0;
for I := 0 to System.Length(Items) - 1 do
@@ -3082,7 +3626,7 @@ function TArrayList.GetIsEmpty: Boolean;
function TArrayList.GetFirst: T;
begin
- Result := Items[0];
+ Result := Items[0]
end;
procedure TArrayList.SetFirst(const Value: T);
@@ -3092,7 +3636,7 @@ procedure TArrayList.SetFirst(const Value: T);
function TArrayList.GetLast: T;
begin
- Result := Items[Length - 1];
+ Result := Items[Length - 1]
end;
procedure TArrayList.SetLast(const Value: T);
@@ -3130,6 +3674,67 @@ class function TArrayList.Convert: TArrayList;
Result.Length := 0;
end;
+{ TStack }
+
+class function TStack.Create(Size: Integer): TStack;
+begin
+ if Size < 1 then
+ raise EStackError.Create(SStackSize);
+ Result.FItems := nil;
+ SetLength(Result.FItems, Size);
+ Result.FSize := Size;
+ Result.FIndex := -1;
+end;
+
+procedure TStack.Push(const Value: T);
+begin
+ if FIndex + 1 = FSize then
+ raise EStackError.Create(SStackPush);
+ Inc(FIndex);
+ FItems[FIndex] := Value
+end;
+
+function TStack.Pop: T;
+begin
+ if FIndex < 0 then
+ raise EStackError.Create(SStackPop);
+ Result := FItems[FIndex];
+ Dec(FIndex);
+end;
+
+function TStack.GetIsEmpty: Boolean;
+begin
+ Result := FIndex < 0;
+end;
+
+function TStack.GetFirst: T;
+begin
+ if FIndex < 0 then
+ raise EStackError.Create(SStackEmpty);
+ Result := FItems[0];
+end;
+
+procedure TStack.SetFirst(const Value: T);
+begin
+ if FIndex < 0 then
+ raise EStackError.Create(SStackEmpty);
+ FItems[0] := Value;
+end;
+
+function TStack.GetLast: T;
+begin
+ if FIndex < 0 then
+ raise EStackError.Create(SStackEmpty);
+ Result := FItems[FIndex];
+end;
+
+procedure TStack.SetLast(const Value: T);
+begin
+ if FIndex < 0 then
+ raise EStackError.Create(SStackEmpty);
+ FItems[FIndex] := Value;
+end;
+
{ TNamedValues }
function TNamedValues.GetEnumerator: IEnumerator;
@@ -3186,6 +3791,20 @@ procedure TNamedValues.Clear;
FValues.Clear;
end;
+function TNamedValues.HasName(const Name: string): Boolean;
+var
+ S: string;
+ I: Integer;
+begin
+ Result := False;
+ if Name = '' then
+ Exit;
+ S := Name.ToUpper;
+ for I := FNames.Lo to FNames.Hi do
+ if S = FNames[I].ToUpper then
+ Exit(True);
+end;
+
function TNamedValues.GetCount: Integer;
begin
Result := FNames.Length;
@@ -3229,6 +3848,108 @@ function TNamedValues.GetValueByIndex(Index: Integer): T;
Result := default(T);
end;
+{ TNamedValuesIntf.IEnumerable }
+
+function TNamedValuesIntf.GetEnumerator: IEnumerator;
+begin
+ Result := FData.GetEnumerator;
+end;
+
+{ TNamedValuesIntf.INamedValues }
+
+function TNamedValuesIntf.GetCount: Integer;
+begin
+ Result := FData.GetCount;
+end;
+
+function TNamedValuesIntf.GetEmpty: Boolean;
+begin
+ Result := FData.GetEmpty;
+end;
+
+function TNamedValuesIntf.GetName(Index: Integer): string;
+begin
+ Result := FData.GetName(Index);
+end;
+
+function TNamedValuesIntf.GetValue(const Name: string): T;
+begin
+ Result := FData.GetValue(Name);
+end;
+
+function TNamedValuesIntf.GetValueByIndex(Index: Integer): T;
+begin
+ Result := FData.GetValueByIndex(Index);
+end;
+
+procedure TNamedValuesIntf.Add(const Name: string; const Value: T);
+begin
+ FData.Add(Name, Value);
+end;
+
+procedure TNamedValuesIntf.Remove(const Name: string);
+begin
+ FData.Remove(Name);
+end;
+
+procedure TNamedValuesIntf.Delete(Index: Integer);
+begin
+ FData.Delete(Index);
+end;
+
+procedure TNamedValuesIntf.Clear;
+begin
+ FData.Clear;
+end;
+
+{ TComponentFreeNotify }
+
+type
+ TComponentFreeNotify = class(TComponent)
+ private
+ FOnFree: TNotifyEvent;
+ public
+ destructor Destroy; override;
+ property OnFree: TNotifyEvent read FOnFree write FOnFree;
+ end;
+
+destructor TComponentFreeNotify.Destroy;
+begin
+ if Assigned(FOnFree) then
+ FOnFree(Self);
+ inherited Destroy;
+end;
+
+{ TInterfacedFree }
+
+constructor TInterfacedFree.Create(AComponent: TComponent);
+begin
+ inherited Create;
+ Component := AComponent;
+ FNotify := TComponentFreeNotify.Create(AComponent);
+ TComponentFreeNotify(FNotify).OnFree := NotifyFree;
+end;
+
+destructor TInterfacedFree.Destroy;
+begin
+ if FNotify <> nil then
+ ReleaseComponent;
+ inherited Destroy;
+end;
+
+procedure TInterfacedFree.ReleaseComponent;
+begin
+ TComponentFreeNotify(FNotify).OnFree := nil;
+ FNotify := nil;
+ Component := nil;
+end;
+
+procedure TInterfacedFree.NotifyFree(Sender: TObject);
+begin
+ FNotify := nil;
+ Component := nil;
+end;
+
function MemCompare(const A, B; Size: LongWord): Boolean;
var
C, D: PByte;
@@ -3366,10 +4087,10 @@ procedure TChangeNotifier.Change;
function TNullInfo.Reset: TNullResult;
begin
FCount := 0;
- InterLockedExchange(FBytes, 0);
- InterLockedExchange(FRate, 0);
- InterLockedExchange(FSeconds, 0);
- InterLockedExchange(FAvergage, 0);
+ System.InterLockedExchange(FBytes, 0);
+ System.InterLockedExchange(FRate, 0);
+ System.InterLockedExchange(FSeconds, 0);
+ System.InterLockedExchange(FAvergage, 0);
FTime := 0;
FRateTime := 0;
FRateBytes := 0;
@@ -3418,19 +4139,19 @@ procedure TNullStream.RecordInfo(Info: TNullInfo; Count: LongWord);
begin
Info.FTime := Time;
Info.FCount := Count;
- InterLockedExchange(Info.FBytes, Info.FCount);
+ System.InterLockedExchange(Info.FBytes, Info.FCount);
end
else if Time - Info.FTime < 1 then
begin
Info.FCount += Count;
- InterLockedExchange(Info.FBytes, Info.FBytes + Info.FCount);
+ System.InterLockedExchange(Info.FBytes, Info.FBytes + Info.FCount);
end
else if Time - Info.FTime < 2 then
begin
Info.FResult.Push(Info.FCount);
Info.FCount := Count;
- InterLockedExchange(Info.FBytes, Info.FBytes + Info.FCount);
- InterLockedIncrement(Info.FSeconds);
+ System.InterLockedExchange(Info.FBytes, Info.FBytes + Info.FCount);
+ System.InterLockedIncrement(Info.FSeconds);
Info.FTime += 1;
end
else
@@ -3438,7 +4159,7 @@ procedure TNullStream.RecordInfo(Info: TNullInfo; Count: LongWord);
Info.Reset;
Info.FTime := Time;
Info.FCount := Count;
- InterLockedExchange(Info.FBytes, Info.FCount);
+ System.InterLockedExchange(Info.FBytes, Info.FCount);
end;
if Info.FRateTime = 0 then
Info.FRateTime := Time;
@@ -3450,13 +4171,13 @@ procedure TNullStream.RecordInfo(Info: TNullInfo; Count: LongWord);
Compliment := Round(Count * ((Time - Poll) / Time));
Info.FRateBytes += Count - Compliment;
Section := Round(Info.FRateBytes / Poll);
- InterLockedExchange(Info.FRate, Section);
+ System.InterLockedExchange(Info.FRate, Section);
Info.FRateBytes := Compliment;
Info.FRateTime += Poll;
Info.FAvergageTotal += Section;
Inc(Info.FAvergageCount);
Section := Round(Info.FAvergageTotal / Info.FAvergageCount);
- InterLockedExchange(Info.FAvergage, Section);
+ System.InterLockedExchange(Info.FAvergage, Section);
end
else
begin
@@ -3468,8 +4189,8 @@ procedure TNullStream.RecordInfo(Info: TNullInfo; Count: LongWord);
Info.FRateTime += Poll;
end;
Section := Round(Info.FAvergageTotal / Info.FAvergageCount);
- InterLockedExchange(Info.FAvergage, Section);
- InterLockedExchange(Info.FRate, 0);
+ System.InterLockedExchange(Info.FAvergage, Section);
+ System.InterLockedExchange(Info.FRate, 0);
Info.FRateBytes := 0;
Info.FRateTime := 0;
end;
@@ -3496,22 +4217,13 @@ function TNullStream.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64;
{$endregion}
{$region threading}
-
-var
- SemaphoreInit: TSempahoreInitHandler;
- SemaphoreDestroy: TSemaphoreDestroyHandler;
- SemaphorePost: TSemaphorePostHandler;
- SemaphoreWait: TSemaphoreWaitHandler;
-
procedure ThreadsInit;
var
M: TThreadManager;
begin
+ M.AllocateThreadVars := nil;
+ FillChar(M, SizeOf(M), 0);
GetThreadManager(M);
- SemaphoreInit := M.SemaphoreInit;
- SemaphoreDestroy := M.SemaphoreDestroy;
- SemaphorePost := M.SemaphorePost;
- SemaphoreWait := M.SemaphoreWait;
end;
{ TMutexObject }
@@ -3519,8 +4231,8 @@ procedure ThreadsInit;
type
TMutexObject = class(TInterfacedObject, IMutex)
private
- FSemaphore: Pointer;
- FCounter: Integer;
+ FSemaphore: TRTLCriticalSection;
+ FLock: LongInt;
public
constructor Create;
destructor Destroy; override;
@@ -3544,29 +4256,25 @@ TEventObject = class(TInterfacedObject, IEvent)
constructor TMutexObject.Create;
begin
inherited Create;
- if @SemaphoreInit = nil then
- ThreadsInit;
- FSemaphore := SemaphoreInit;
+ InitCriticalSection(FSemaphore);
end;
destructor TMutexObject.Destroy;
begin
- SemaphoreDestroy(FSemaphore);
+ DoneCriticalSection(FSemaphore);
inherited Destroy;
end;
function TMutexObject.Lock: LongInt;
begin
- Result := InterLockedIncrement(FCounter);
- if Result > 1 then
- SemaphoreWait(FSemaphore);
+ EnterCriticalSection(FSemaphore);
+ Result := InterlockedIncrement(FLock);
end;
function TMutexObject.Unlock: LongInt;
begin
- Result := InterLockedDecrement(FCounter);
- if Result > 0 then
- SemaphorePost(FSemaphore);
+ Result := InterlockedDecrement(FLock);
+ LeaveCriticalSection(FSemaphore);
end;
constructor TEventObject.Create;
@@ -3598,7 +4306,7 @@ procedure TEventObject.Wait;
function MutexCreate: IMutex;
begin
- Result := TMutexObject.Create;;
+ Result := TMutexObject.Create;
end;
function EventCreate: IEvent;
@@ -3623,27 +4331,82 @@ procedure TSimpleThread.Execute;
FExecuteMethod(Self);
end;
-procedure TSimpleThread.Synch(Method: TThreadMethod);
+procedure TSimpleThread.Synchronize(Method: TThreadMethod);
begin
- Synchronize(Method);
+ inherited Synchronize(Method);
end;
procedure TSimpleThread.DoStatus;
begin
+ FStatus := FTempStatus;
if Assigned(FOnStatus) then
FOnStatus(Self);
end;
procedure TSimpleThread.SetStatus(const Value: string);
begin
- if Value <> FStatus then
+ if (Value <> FTempStatus) and (Handle = GetCurrentThreadId) then
begin
- FStatus := Value;
+ FTempStatus := Value;
if Assigned(FOnStatus) then
Synchronize(DoStatus);
end;
end;
+{ TThreadContainer }
+
+type
+ TThreadContainer = class
+ private
+ FThreadProc: TThreadExecuteProc;
+ FProc: TProcedure;
+ procedure Execute(Thread: TSimpleThread);
+ public
+ constructor Create(ThreadProc: TThreadExecuteProc; Proc: TProcedure);
+ function Run: TSimpleThread;
+ end;
+
+constructor TThreadContainer.Create(ThreadProc: TThreadExecuteProc; Proc: TProcedure);
+begin
+ inherited Create;
+ FThreadProc := ThreadProc;
+ FProc := Proc;
+end;
+
+procedure TThreadContainer.Execute(Thread: TSimpleThread);
+begin
+ if Assigned(FThreadProc) then
+ FThreadProc(Thread)
+ else
+ FProc;
+ Free;
+end;
+
+function TThreadContainer.Run: TSimpleThread;
+begin
+ Result := TSimpleThread.Create(Execute);
+end;
+
+function ThreadExecute(ThreadMethod: TThreadExecuteMethod): TSimpleThread;
+begin
+ Result := TSimpleThread.Create(ThreadMethod);
+end;
+
+function ThreadExecute(ThreadProc: TThreadExecuteProc): TSimpleThread;
+begin
+ Result := TThreadContainer.Create(ThreadProc, nil).Run;
+end;
+
+function ThreadExecute(Proc: TProcedure): TSimpleThread;
+begin
+ Result := TThreadContainer.Create(nil, Proc).Run;
+end;
+
+procedure Sleep(Milliseconds: Cardinal);
+begin
+ SysUtils.Sleep(Milliseconds);
+end;
+
{$endregion}
{$region waiting routines}
diff --git a/source/codebot/codebot.text.formats.pas b/source/codebot/codebot.text.formats.pas
new file mode 100644
index 0000000..f56fa1b
--- /dev/null
+++ b/source/codebot/codebot.text.formats.pas
@@ -0,0 +1,205 @@
+(********************************************************)
+(* *)
+(* Codebot Pascal Library *)
+(* http://cross.codebot.org *)
+(* Modified September 2019 *)
+(* *)
+(********************************************************)
+
+{ }
+unit Codebot.Text.Formats;
+
+{$i codebot.inc}
+
+interface
+
+uses
+ Codebot.System;
+
+{$region textformats}
+{ Attempt to translate a json string to an xml string [group textformats] }
+(*function JsonToXml(const Json: string): string;
+
+{ Attempt to translate an xml string to an json string [group textformats] }
+function XmlToJson(const Xml: string): string;
+
+{ Perform a quick test to determine if a string contains json data [group textformats] }
+function IsJson(const S: string): Boolean;
+
+{ Perform a quick test to determine if a string contains xml data [group textformats] }
+function IsXml(const S: string): Boolean;*)
+{$endregion}
+
+implementation
+
+{$region formats}
+(*function JsonEnumData(Data: TJSONData; Level: Integer): string;
+var
+ Item: TJSONEnum;
+ K, S: string;
+begin
+ Result := '';
+ S := '';
+ SetLength(S, Level);
+ FillChar(S[1], Level, ' ');
+ for Item in Data do
+ begin
+ K := Item.Key;
+ if K[1] in ['0'..'9'] then
+ K := 'item' + K;
+ if Item.Value.JSONType in [jtArray, jtObject] then
+ begin
+ if Item.Value.JSONType = jtArray then
+ Result := Result + S + '<' + K + ' type="array">'#10
+ else
+ Result := Result + S + '<' + K + ' type="object">'#10;
+ Result := Result + JsonEnumData(Item.Value, Level + 2);
+ Result := Result + S + ''#10;
+ end
+ else
+ case Item.Value.JSONType of
+ jtNull: Result := Result + S + '<' + K + ' type="null"/>'#10;
+ jtBoolean: Result := Result + S + '<' + K + ' type="bool">' + Item.Value.AsString + ''#10;
+ jtNumber: Result := Result + S + '<' + K + ' type="number">' + Item.Value.AsString + ''#10;
+ else
+ Result := Result + S + '<' + K + '>' + Item.Value.AsString + ''#10;
+ end;
+ end;
+end;
+
+function JsonToXml(const Json: string): string;
+const
+ Header = ''#10;
+var
+ P: TJSONParser;
+ D: TJSONData;
+ S: string;
+begin
+ try
+ P := TJSONParser.Create(Json, [joUTF8]);
+ try
+ D := P.Parse;
+ if D.JSONType = jtArray then
+ S := 'array'
+ else
+ S := 'object';
+ Result := Header + '<' + S + '>'#10 + JsonEnumData(D, 2) + '';
+ finally
+ P.Free;
+ end;
+ except
+ Result := '';
+ end;
+end;
+
+function XmlEnumObject(N: INode; Level: Integer; IsArray: Boolean): string;
+var
+ List: INodeList;
+ Item: INode;
+ K, S, Prefix: string;
+ I, J: Integer;
+begin
+ Result := '';
+ S := '';
+ SetLength(S, Level);
+ FillChar(S[1], Level, ' ');
+ List := N.Nodes;
+ J := List.Count - 1;
+ for I := 0 to J do
+ begin
+ Item := List[I];
+ K := Item.Filer.ReadStr('@type');
+ if IsArray then
+ Prefix := S
+ else
+ Prefix := S + '"' + Item.Name + '": ';
+ if Item.Nodes.Count > 0 then
+ begin
+ if K = 'array' then
+ begin
+ Result := Result + Prefix + '['#10 + XmlEnumObject(Item, Level + 2, True);
+ Result := Result + S + ']'
+ end
+ else
+ begin
+ Result := Result + Prefix + '{'#10 + XmlEnumObject(Item, Level + 2, False);
+ Result := Result + S + '}'
+ end;
+ end
+ else
+ begin
+ if K = 'array' then
+ Result := Result + Prefix + '[ ]'
+ else if K = 'object' then
+ Result := Result + Prefix + '{ }'
+ else if K = 'null' then
+ Result := Result + Prefix + 'null'
+ else if K = '' then
+ Result := Result + Prefix + '"' + Item.Text + '"'
+ else
+ Result := Result + Prefix + Item.Text;
+ end;
+ if I = J then
+ Result := Result + #10
+ else
+ Result := Result + ','#10
+ end;
+end;
+
+function XmlToJson(const Xml: string): string;
+var
+ D: IDocument;
+ R: INode;
+ S: string;
+begin
+ D := DocumentCreate;
+ D.Text := Xml;
+ R := D.Root;
+ if R <> nil then
+ begin
+ S := D.Root.Name;
+ if S = 'array' then
+ Result := '['#10 + XmlEnumObject(R, 2, True) + ']'
+ else
+ Result := '{'#10 + XmlEnumObject(R, 2, False) + '}';
+ end
+ else
+ Result := '';
+end;
+
+function IsJson(const S: string): Boolean;
+var
+ P: PChar;
+begin
+ Result := False;
+ P := PChar(S);
+ while P[0] > #0 do
+ begin
+ if P[0] <= ' ' then
+ begin
+ Inc(P);
+ Continue;
+ end;
+ Exit(P[0] in ['[', '{']);
+ end;
+end;
+
+function IsXml(const S: string): Boolean;
+var
+ P: PChar;
+begin
+ Result := False;
+ P := PChar(S);
+ while P[0] > #0 do
+ begin
+ if P[0] <= ' ' then
+ begin
+ Inc(P);
+ Continue;
+ end;
+ Exit(P[0] = '<');
+ end;
+end;*)
+{$endregion}
+
+end.
diff --git a/source/codebot/codebot.text.json.pas b/source/codebot/codebot.text.json.pas
new file mode 100644
index 0000000..812d847
--- /dev/null
+++ b/source/codebot/codebot.text.json.pas
@@ -0,0 +1,1541 @@
+(********************************************************)
+(* *)
+(* Codebot Pascal Library *)
+(* http://cross.codebot.org *)
+(* Modified June 2022 *)
+(* *)
+(********************************************************)
+
+{ }
+unit Codebot.Text.Json;
+
+{$i codebot.inc}
+
+interface
+
+uses
+ SysUtils, Classes;
+
+{ EJsonException is the exception type used by TJsonNode. It is thrown
+ during parse if the string is invalid json or if an attempt is made to
+ access a non collection by name or index. }
+
+type
+ EJsonException = class(Exception);
+
+{ TJsonNodeKind is 1 of 6 possible values described below }
+
+ TJsonNodeKind = (
+ { Object such as curly braces }
+ nkObject,
+ { Array such as [ ] }
+ nkArray,
+ { The literal values true or false }
+ nkBool,
+ { The literal value null }
+ nkNull,
+ { A number value such as 123, 1.23e2, or -1.5 }
+ nkNumber,
+ { A string such as "hello\nworld!" }
+ nkString);
+
+ TJsonNode = class;
+
+{ TJsonNodeEnumerator is used to enumerate 'for ... in' statements }
+
+ TJsonNodeEnumerator = record
+ private
+ FNode: TJsonNode;
+ FIndex: Integer;
+ public
+ procedure Init(Node: TJsonNode);
+ function GetCurrent: TJsonNode;
+ function MoveNext: Boolean;
+ property Current: TJsonNode read GetCurrent;
+ end;
+
+{ TJsonNode is the class used to parse, build, and navigate a json document.
+ You should only create and free the root node of your document. The root
+ node will manage the lifetime of all children through methods such as Add,
+ Delete, and Clear.
+ When you create a TJsonNode node it will have no parent and is considered to
+ be the root node. The root node must be either an array or an object. Attempts
+ to convert a root to anything other than array or object will raise an
+ exception.
+ Note: The parser supports unicode by converting unicode characters escaped as
+ values such as \u20AC. If your json string has an escaped unicode character it
+ will be unescaped when converted to a pascal string.
+ See also:
+ JsonStringDecode to convert a JSON string to a normal string
+ JsonStringEncode to convert a normal string to a JSON string }
+
+ TJsonNode = class
+ private
+ FStack: Integer;
+ FParent: TJsonNode;
+ FName: string;
+ FKind: TJsonNodeKind;
+ FValue: string;
+ FList: TList;
+ procedure ParseObject(Node: TJsonNode; var C: PChar);
+ procedure ParseArray(Node: TJsonNode; var C: PChar);
+ procedure Error(const Msg: string = '');
+ function Format(const Indent: string): string;
+ function FormatCompact: string;
+ function Add(Kind: TJsonNodeKind; const Name, Value: string): TJsonNode; overload;
+ function GetRoot: TJsonNode;
+ procedure SetKind(Value: TJsonNodeKind);
+ function GetName: string;
+ procedure SetName(const Value: string);
+ function GetValue: string;
+ function GetCount: Integer;
+ function GetAsJson: string;
+ function GetAsArray: TJsonNode;
+ function GetAsObject: TJsonNode;
+ function GetAsNull: TJsonNode;
+ function GetAsBoolean: Boolean;
+ procedure SetAsBoolean(Value: Boolean);
+ function GetAsString: string;
+ procedure SetAsString(const Value: string);
+ function GetAsNumber: Double;
+ procedure SetAsNumber(Value: Double);
+ public
+ { A parent node owns all children. Only destroy a node if it has no parent.
+ To destroy a child node use Delete or Clear methods instead. }
+ destructor Destroy; override;
+ { GetEnumerator adds 'for ... in' statement support }
+ function GetEnumerator: TJsonNodeEnumerator;
+ { Loading and saving methods }
+ procedure LoadFromStream(Stream: TStream);
+ procedure SaveToStream(Stream: TStream);
+ procedure LoadFromFile(const FileName: string);
+ procedure SaveToFile(const FileName: string);
+ { Convert a json string into a value or a collection of nodes. If the
+ current node is root then the json must be an array or object. }
+ procedure Parse(const Json: string);
+ { The same as Parse, but returns true if no exception is caught }
+ function TryParse(const Json: string): Boolean;
+ { Add a child node by node kind. If the current node is an array then the
+ name parameter will be discarded. If the current node is not an array or
+ object the Add methods will convert the node to an object and discard
+ its current value.
+ Note: If the current node is an object then adding an existing name will
+ overwrite the matching child node instead of adding. }
+ function Add(const Name: string; K: TJsonNodeKind = nkObject): TJsonNode; overload;
+ function Add(const Name: string; B: Boolean): TJsonNode; overload;
+ function Add(const Name: string; const N: Double): TJsonNode; overload;
+ function Add(const Name: string; const S: string): TJsonNode; overload;
+ { Convert to an array and add an item }
+ function Add: TJsonNode; overload;
+ { Delete a child node by index or name }
+ procedure Delete(Index: Integer); overload;
+ procedure Delete(const Name: string); overload;
+ { Remove all child nodes }
+ procedure Clear;
+ { Get a child node by index. EJsonException is raised if node is not an
+ array or object or if the index is out of bounds.
+ See also: Count }
+ function Child(Index: Integer): TJsonNode; overload;
+ { Get a child node by name. If no node is found nil will be returned. }
+ function Child(const Name: string): TJsonNode; overload;
+ { Search for a node using a path string and return true if exists }
+ function Exists(const Path: string): Boolean;
+ { Search for a node using a path string }
+ function Find(const Path: string): TJsonNode; overload;
+ { Search for a node using a path string and return true if exists }
+ function Find(const Path: string; out Node: TJsonNode): Boolean; overload;
+ { Force a series of nodes to exist and return the end node }
+ function Force(const Path: string): TJsonNode;
+ { Format the node and all its children as json }
+ function ToString: string; override;
+ { Root node is read only. A node the root when it has no parent. }
+ property Root: TJsonNode read GetRoot;
+ { Parent node is read only }
+ property Parent: TJsonNode read FParent;
+ { Kind can also be changed using the As methods.
+ Note: Changes to Kind cause Value to be reset to a default value. }
+ property Kind: TJsonNodeKind read FKind write SetKind;
+ { Name is unique within the scope }
+ property Name: string read GetName write SetName;
+ { Value of the node in json e.g. '[]', '"hello\nworld!"', 'true', or '1.23e2' }
+ property Value: string read GetValue write Parse;
+ { The number of child nodes. If node is not an object or array this
+ property will return 0. }
+ property Count: Integer read GetCount;
+ { AsJson is the more efficient version of Value. Text returned from AsJson
+ is the most compact representation of the node in json form.
+ Note: If you are writing a services to transmit or receive json data then
+ use AsJson. If you want friendly human readable text use Value. }
+ property AsJson: string read GetAsJson write Parse;
+ { Convert the node to an array }
+ property AsArray: TJsonNode read GetAsArray;
+ { Convert the node to an object }
+ property AsObject: TJsonNode read GetAsObject;
+ { Convert the node to null }
+ property AsNull: TJsonNode read GetAsNull;
+ { Convert the node to a bool }
+ property AsBoolean: Boolean read GetAsBoolean write SetAsBoolean;
+ { Convert the node to a string }
+ property AsString: string read GetAsString write SetAsString;
+ { Convert the node to a number }
+ property AsNumber: Double read GetAsNumber write SetAsNumber;
+ end;
+
+{ JsonValidate tests if a string contains a valid json format }
+function JsonValidate(const Json: string): Boolean;
+{ JsonNumberValidate tests if a string contains a valid json formatted number }
+function JsonNumberValidate(const N: string): Boolean;
+{ JsonStringValidate tests if a string contains a valid json formatted string }
+function JsonStringValidate(const S: string): Boolean;
+{ JsonStringEncode converts a pascal string to a json string }
+function JsonStringEncode(const S: string): string;
+{ JsonStringEncode converts a json string to a pascal string }
+function JsonStringDecode(const S: string): string;
+{ JsonStringEncode converts a json string to xml }
+function JsonToXml(const S: string): string;
+
+implementation
+
+resourcestring
+ SNodeNotCollection = 'Node is not a container';
+ SRootNodeKind = 'Root node must be an array or object';
+ SIndexOutOfBounds = 'Index out of bounds';
+ SParsingError = 'Error while parsing text';
+
+type
+ TJsonTokenKind = (tkEnd, tkError, tkObjectOpen, tkObjectClose, tkArrayOpen,
+ tkArrayClose, tkColon, tkComma, tkNull, tkFalse, tkTrue, tkString, tkNumber);
+
+ TJsonToken = record
+ Head: PChar;
+ Tail: PChar;
+ Kind: TJsonTokenKind;
+ function Value: string;
+ end;
+
+const
+ Hex = ['0'..'9', 'A'..'F', 'a'..'f'];
+
+function TJsonToken.Value: string;
+begin
+ case Kind of
+ tkEnd: Result := #0;
+ tkError: Result := #0;
+ tkObjectOpen: Result := '{';
+ tkObjectClose: Result := '}';
+ tkArrayOpen: Result := '[';
+ tkArrayClose: Result := ']';
+ tkColon: Result := ':';
+ tkComma: Result := ',';
+ tkNull: Result := 'null';
+ tkFalse: Result := 'false';
+ tkTrue: Result := 'true';
+ else
+ SetString(Result, Head, Tail - Head);
+ end;
+end;
+
+function NextToken(var C: PChar; out T: TJsonToken): Boolean;
+begin
+ if C^ > #0 then
+ if C^ <= ' ' then
+ repeat
+ Inc(C);
+ if C^ = #0 then
+ Break;
+ until C^ > ' ';
+ T.Head := C;
+ T.Tail := C;
+ T.Kind := tkEnd;
+ if C^ = #0 then
+ Exit(False);
+ if C^ = '{' then
+ begin
+ Inc(C);
+ T.Tail := C;
+ T.Kind := tkObjectOpen;
+ Exit(True);
+ end;
+ if C^ = '}' then
+ begin
+ Inc(C);
+ T.Tail := C;
+ T.Kind := tkObjectClose;
+ Exit(True);
+ end;
+ if C^ = '[' then
+ begin
+ Inc(C);
+ T.Tail := C;
+ T.Kind := tkArrayOpen;
+ Exit(True);
+ end;
+ if C^ = ']' then
+ begin
+ Inc(C);
+ T.Tail := C;
+ T.Kind := tkArrayClose;
+ Exit(True);
+ end;
+ if C^ = ':' then
+ begin
+ Inc(C);
+ T.Tail := C;
+ T.Kind := tkColon;
+ Exit(True);
+ end;
+ if C^ = ',' then
+ begin
+ Inc(C);
+ T.Tail := C;
+ T.Kind := tkComma;
+ Exit(True);
+ end;
+ if (C[0] = 'n') and (C[1] = 'u') and (C[2] = 'l') and (C[3] = 'l') then
+ begin
+ Inc(C, 4);
+ T.Tail := C;
+ T.Kind := tkNull;
+ Exit(True);
+ end;
+ if (C[0] = 'f') and (C[1] = 'a') and (C[2] = 'l') and (C[3] = 's') and (C[4] = 'e') then
+ begin
+ Inc(C, 5);
+ T.Tail := C;
+ T.Kind := tkFalse;
+ Exit(True);
+ end;
+ if (C[0] = 't') and (C[1] = 'r') and (C[2] = 'u') and (C[3] = 'e') then
+ begin
+ Inc(C, 4);
+ T.Tail := C;
+ T.Kind := tkTrue;
+ Exit(True);
+ end;
+ if C^ = '"' then
+ begin
+ repeat
+ Inc(C);
+ if C^ = '\' then
+ begin
+ Inc(C);
+ if C^ < ' ' then
+ begin
+ T.Tail := C;
+ T.Kind := tkError;
+ Exit(False);
+ end;
+ if C^ = 'u' then
+ if not ((C[1] in Hex) and (C[2] in Hex) and (C[3] in Hex) and (C[4] in Hex)) then
+ begin
+ T.Tail := C;
+ T.Kind := tkError;
+ Exit(False);
+ end;
+ end
+ else if C^ = '"' then
+ begin
+ Inc(C);
+ T.Tail := C;
+ T.Kind := tkString;
+ Exit(True);
+ end;
+ until C^ in [#0, #10, #13];
+ T.Tail := C;
+ T.Kind := tkError;
+ Exit(False);
+ end;
+ if C^ in ['-', '0'..'9'] then
+ begin
+ if C^ = '-' then
+ Inc(C);
+ if C^ in ['0'..'9'] then
+ begin
+ while C^ in ['0'..'9'] do
+ Inc(C);
+ if C^ = '.' then
+ begin
+ Inc(C);
+ if C^ in ['0'..'9'] then
+ begin
+ while C^ in ['0'..'9'] do
+ Inc(C);
+ end
+ else
+ begin
+ T.Tail := C;
+ T.Kind := tkError;
+ Exit(False);
+ end;
+ end;
+ if C^ in ['E', 'e'] then
+ begin
+ Inc(C);
+ if C^ = '+' then
+ Inc(C)
+ else if C^ = '-' then
+ Inc(C);
+ if C^ in ['0'..'9'] then
+ begin
+ while C^ in ['0'..'9'] do
+ Inc(C);
+ end
+ else
+ begin
+ T.Tail := C;
+ T.Kind := tkError;
+ Exit(False);
+ end;
+ end;
+ T.Tail := C;
+ T.Kind := tkNumber;
+ Exit(True);
+ end;
+ end;
+ T.Kind := tkError;
+ Result := False;
+end;
+
+{ TJsonNodeEnumerator }
+
+procedure TJsonNodeEnumerator.Init(Node: TJsonNode);
+begin
+ FNode := Node;
+ FIndex := -1;
+end;
+
+function TJsonNodeEnumerator.GetCurrent: TJsonNode;
+begin
+ if FNode.FList = nil then
+ Result := nil
+ else if FIndex < 0 then
+ Result := nil
+ else if FIndex < FNode.FList.Count then
+ Result := TJsonNode(FNode.FList[FIndex])
+ else
+ Result := nil;
+end;
+
+function TJsonNodeEnumerator.MoveNext: Boolean;
+begin
+ Inc(FIndex);
+ if FNode.FList = nil then
+ Result := False
+ else
+ Result := FIndex < FNode.FList.Count;
+end;
+
+{ TJsonNode }
+
+destructor TJsonNode.Destroy;
+begin
+ Clear;
+ inherited Destroy;
+end;
+
+function TJsonNode.GetEnumerator: TJsonNodeEnumerator;
+begin
+ Result.Init(Self);
+end;
+
+procedure TJsonNode.LoadFromStream(Stream: TStream);
+var
+ S: string;
+ I: Int64;
+begin
+ I := Stream.Size - Stream.Position;
+ S := '';
+ SetLength(S, I);
+ Stream.Read(PChar(S)^, I);
+ Parse(S);
+end;
+
+procedure TJsonNode.SaveToStream(Stream: TStream);
+var
+ S: string;
+ I: Int64;
+begin
+ S := Value;
+ I := Length(S);
+ Stream.Write(PChar(S)^, I);
+end;
+
+procedure TJsonNode.LoadFromFile(const FileName: string);
+var
+ F: TFileStream;
+begin
+ F := TFileStream.Create(FileName, fmOpenRead);
+ try
+ LoadFromStream(F);
+ finally
+ F.Free;
+ end;
+end;
+
+procedure TJsonNode.SaveToFile(const FileName: string);
+var
+ F: TFileStream;
+begin
+ F := TFileStream.Create(FileName, fmCreate);
+ try
+ SaveToStream(F);
+ finally
+ F.Free;
+ end;
+end;
+
+const
+ MaxStack = 1000;
+
+procedure TJsonNode.ParseObject(Node: TJsonNode; var C: PChar);
+var
+ T: TJsonToken;
+ N: string;
+begin
+ Inc(FStack);
+ if FStack > MaxStack then
+ Error;
+ while NextToken(C, T) do
+ begin
+ case T.Kind of
+ tkString: N := JsonStringDecode(T.Value);
+ tkObjectClose:
+ begin
+ Dec(FStack);
+ Exit;
+ end
+ else
+ Error;
+ end;
+ NextToken(C, T);
+ if T.Kind <> tkColon then
+ Error;
+ NextToken(C, T);
+ case T.Kind of
+ tkObjectOpen: ParseObject(Node.Add(nkObject, N, ''), C);
+ tkArrayOpen: ParseArray(Node.Add(nkArray, N, ''), C);
+ tkNull: Node.Add(nkNull, N, 'null');
+ tkFalse: Node.Add(nkBool, N, 'false');
+ tkTrue: Node.Add(nkBool, N, 'true');
+ tkString: Node.Add(nkString, N, T.Value);
+ tkNumber: Node.Add(nkNumber, N, T.Value);
+ else
+ Error;
+ end;
+ NextToken(C, T);
+ if T.Kind = tkComma then
+ Continue;
+ if T.Kind = tkObjectClose then
+ begin
+ Dec(FStack);
+ Exit;
+ end;
+ Error;
+ end;
+ Error;
+end;
+
+procedure TJsonNode.ParseArray(Node: TJsonNode; var C: PChar);
+var
+ T: TJsonToken;
+begin
+ Inc(FStack);
+ if FStack > MaxStack then
+ Error;
+ while NextToken(C, T) do
+ begin
+ case T.Kind of
+ tkObjectOpen: ParseObject(Node.Add(nkObject, '', ''), C);
+ tkArrayOpen: ParseArray(Node.Add(nkArray, '', ''), C);
+ tkNull: Node.Add(nkNull, '', 'null');
+ tkFalse: Node.Add(nkBool, '', 'false');
+ tkTrue: Node.Add(nkBool, '', 'true');
+ tkString: Node.Add(nkString, '', T.Value);
+ tkNumber: Node.Add(nkNumber, '', T.Value);
+ tkArrayClose:
+ begin
+ Dec(FStack);
+ Exit;
+ end
+ else
+ Error;
+ end;
+ NextToken(C, T);
+ if T.Kind = tkComma then
+ Continue;
+ if T.Kind = tkArrayClose then
+ begin
+ Dec(FStack);
+ Exit;
+ end;
+ Error;
+ end;
+ Error;
+end;
+
+procedure TJsonNode.Parse(const Json: string);
+var
+ C: PChar;
+ T: TJsonToken;
+begin
+ Clear;
+ C := PChar(Json);
+ if FParent = nil then
+ begin
+ if NextToken(C, T) and (T.Kind in [tkObjectOpen, tkArrayOpen]) then
+ begin
+ try
+ if T.Kind = tkObjectOpen then
+ begin
+ FKind := nkObject;
+ ParseObject(Self, C);
+ end
+ else
+ begin
+ FKind := nkArray;
+ ParseArray(Self, C);
+ end;
+ NextToken(C, T);
+ if T.Kind <> tkEnd then
+ Error;
+ except
+ Clear;
+ raise;
+ end;
+ end
+ else
+ Error(SRootNodeKind);
+ end
+ else
+ begin
+ NextToken(C, T);
+ case T.Kind of
+ tkObjectOpen:
+ begin
+ FKind := nkObject;
+ ParseObject(Self, C);
+ end;
+ tkArrayOpen:
+ begin
+ FKind := nkArray;
+ ParseArray(Self, C);
+ end;
+ tkNull:
+ begin
+ FKind := nkNull;
+ FValue := 'null';
+ end;
+ tkFalse:
+ begin
+ FKind := nkBool;
+ FValue := 'false';
+ end;
+ tkTrue:
+ begin
+ FKind := nkBool;
+ FValue := 'true';
+ end;
+ tkString:
+ begin
+ FKind := nkString;
+ FValue := T.Value;
+ end;
+ tkNumber:
+ begin
+ FKind := nkNumber;
+ FValue := T.Value;
+ end;
+ else
+ Error;
+ end;
+ NextToken(C, T);
+ if T.Kind <> tkEnd then
+ begin
+ Clear;
+ Error;
+ end;
+ end;
+end;
+
+function TJsonNode.TryParse(const Json: string): Boolean;
+begin
+ try
+ Parse(Json);
+ Result := True;
+ except
+ Result := False;
+ end;
+end;
+
+procedure TJsonNode.Error(const Msg: string = '');
+begin
+ FStack := 0;
+ if Msg = '' then
+ raise EJsonException.Create(SParsingError)
+ else
+ raise EJsonException.Create(Msg);
+end;
+
+function TJsonNode.GetRoot: TJsonNode;
+begin
+ Result := Self;
+ while Result.FParent <> nil do
+ Result := Result.FParent;
+end;
+
+procedure TJsonNode.SetKind(Value: TJsonNodeKind);
+begin
+ if Value = FKind then Exit;
+ case Value of
+ nkObject: AsObject;
+ nkArray: AsArray;
+ nkBool: AsBoolean;
+ nkNull: AsNull;
+ nkNumber: AsNumber;
+ nkString: AsString;
+ end;
+end;
+
+function TJsonNode.GetName: string;
+begin
+ if FParent = nil then
+ Exit('0');
+ if FParent.FKind = nkArray then
+ Result := IntToStr(FParent.FList.IndexOf(Self))
+ else
+ Result := FName;
+end;
+
+procedure TJsonNode.SetName(const Value: string);
+var
+ N: TJsonNode;
+begin
+ if FParent = nil then
+ Exit;
+ if FParent.FKind = nkArray then
+ Exit;
+ N := FParent.Child(Value);
+ if N = Self then
+ Exit;
+ FParent.FList.Remove(N);
+ FName := Value;
+end;
+
+function TJsonNode.GetValue: string;
+begin
+ if FKind in [nkObject, nkArray] then
+ Result := Format('')
+ else
+ Result := FValue;
+end;
+
+function TJsonNode.GetAsJson: string;
+begin
+ if FKind in [nkObject, nkArray] then
+ Result := FormatCompact
+ else
+ Result := FValue;
+end;
+
+function TJsonNode.GetAsArray: TJsonNode;
+begin
+ if FKind <> nkArray then
+ begin
+ Clear;
+ FKind := nkArray;
+ FValue := '';
+ end;
+ Result := Self;
+end;
+
+function TJsonNode.GetAsObject: TJsonNode;
+begin
+ if FKind <> nkObject then
+ begin
+ Clear;
+ FKind := nkObject;
+ FValue := '';
+ end;
+ Result := Self;
+end;
+
+function TJsonNode.GetAsNull: TJsonNode;
+begin
+ if FParent = nil then
+ Error(SRootNodeKind);
+ if FKind <> nkNull then
+ begin
+ Clear;
+ FKind := nkNull;
+ FValue := 'null';
+ end;
+ Result := Self;
+end;
+
+function TJsonNode.GetAsBoolean: Boolean;
+begin
+ if FParent = nil then
+ Error(SRootNodeKind);
+ if FKind <> nkBool then
+ begin
+ Clear;
+ FKind := nkBool;
+ FValue := 'false';
+ Exit(False);
+ end;
+ Result := FValue = 'true';
+end;
+
+procedure TJsonNode.SetAsBoolean(Value: Boolean);
+begin
+ if FParent = nil then
+ Error(SRootNodeKind);
+ if FKind <> nkBool then
+ begin
+ Clear;
+ FKind := nkBool;
+ end;
+ if Value then
+ FValue := 'true'
+ else
+ FValue := 'false';
+end;
+
+function TJsonNode.GetAsString: string;
+begin
+ if FParent = nil then
+ Error(SRootNodeKind);
+ if FKind <> nkString then
+ begin
+ Clear;
+ FKind := nkString;
+ FValue := '""';
+ Exit('');
+ end;
+ Result := JsonStringDecode(FValue);
+end;
+
+procedure TJsonNode.SetAsString(const Value: string);
+begin
+ if FParent = nil then
+ Error(SRootNodeKind);
+ if FKind <> nkString then
+ begin
+ Clear;
+ FKind := nkString;
+ end;
+ FValue := JsonStringEncode(Value);
+end;
+
+function TJsonNode.GetAsNumber: Double;
+begin
+ if FParent = nil then
+ Error(SRootNodeKind);
+ if FKind <> nkNumber then
+ begin
+ Clear;
+ FKind := nkNumber;
+ FValue := '0';
+ Exit(0);
+ end;
+ Result := StrToFloatDef(FValue, 0);
+end;
+
+procedure TJsonNode.SetAsNumber(Value: Double);
+begin
+ if FParent = nil then
+ Error(SRootNodeKind);
+ if FKind <> nkNumber then
+ begin
+ Clear;
+ FKind := nkNumber;
+ end;
+ FValue := FloatToStr(Value);
+end;
+
+function TJsonNode.Add: TJsonNode;
+begin
+ Result := AsArray.Add('');
+end;
+
+function TJsonNode.Add(Kind: TJsonNodeKind; const Name, Value: string): TJsonNode;
+var
+ S: string;
+begin
+ if not (FKind in [nkArray, nkObject]) then
+ if Name = '' then
+ AsArray
+ else
+ AsObject;
+ if FKind in [nkArray, nkObject] then
+ begin
+ if FList = nil then
+ FList := TList.Create;
+ if FKind = nkArray then
+ S := IntToStr(FList.Count)
+ else
+ S := Name;
+ Result := Child(S);
+ if Result = nil then
+ begin
+ Result := TJsonNode.Create;
+ Result.FName := S;
+ FList.Add(Result);
+ end;
+ if Kind = nkNull then
+ Result.FValue := 'null'
+ else if Kind in [nkBool, nkString, nkNumber] then
+ Result.FValue := Value
+ else
+ begin
+ Result.FValue := '';
+ Result.Clear;
+ end;
+ Result.FParent := Self;
+ Result.FKind := Kind;
+ end
+ else
+ Error(SNodeNotCollection);
+end;
+
+function TJsonNode.Add(const Name: string; K: TJsonNodeKind = nkObject): TJsonNode; overload;
+begin
+ case K of
+ nkObject, nkArray: Result := Add(K, Name, '');
+ nkNull: Result := Add(K, Name, 'null');
+ nkBool: Result := Add(K, Name, 'false');
+ nkNumber: Result := Add(K, Name, '0');
+ nkString: Result := Add(K, Name, '""');
+ end;
+end;
+
+function TJsonNode.Add(const Name: string; B: Boolean): TJsonNode; overload;
+const
+ Bools: array[Boolean] of string = ('false', 'true');
+begin
+ Result := Add(nkBool, Name, Bools[B]);
+end;
+
+function TJsonNode.Add(const Name: string; const N: Double): TJsonNode; overload;
+begin
+ Result := Add(nkNumber, Name, FloatToStr(N));
+end;
+
+function TJsonNode.Add(const Name: string; const S: string): TJsonNode; overload;
+begin
+ Result := Add(nkString, Name, JsonStringEncode(S));
+end;
+
+procedure TJsonNode.Delete(Index: Integer);
+var
+ N: TJsonNode;
+begin
+ N := Child(Index);
+ if N <> nil then
+ begin
+ FList.Delete(Index);
+ if FList.Count = 0 then
+ begin
+ FList.Free;
+ FList := nil;
+ end;
+ end;
+end;
+
+procedure TJsonNode.Delete(const Name: string);
+var
+ N: TJsonNode;
+begin
+ N := Child(Name);
+ if N <> nil then
+ begin
+ FList.Remove(N);
+ if FList.Count = 0 then
+ begin
+ FList.Free;
+ FList := nil;
+ end;
+ end;
+end;
+
+procedure TJsonNode.Clear;
+var
+ I: Integer;
+begin
+ if FList <> nil then
+ begin
+ for I := 0 to FList.Count - 1 do
+ TObject(FList[I]).Free;
+ FList.Free;
+ FList := nil;
+ end;
+end;
+
+function TJsonNode.Child(Index: Integer): TJsonNode;
+begin
+ if FKind in [nkArray, nkObject] then
+ begin
+ if FList = nil then
+ Error(SIndexOutOfBounds);
+ if (Index < 0) or (Index > FList.Count - 1) then
+ Error(SIndexOutOfBounds);
+ Result := TJsonNode(FList[Index]);
+ end
+ else
+ Error(SNodeNotCollection);
+end;
+
+function TJsonNode.Child(const Name: string): TJsonNode;
+var
+ N: TJsonNode;
+ I: Integer;
+begin
+ Result := nil;
+ if (FList <> nil) and (FKind in [nkArray, nkObject]) then
+ if FKind = nkArray then
+ begin
+ I := StrToIntDef(Name, -1);
+ if (I > -1) and (I < FList.Count) then
+ Exit(TJsonNode(FList[I]));
+ end
+ else for I := 0 to FList.Count - 1 do
+ begin
+ N := TJsonNode(FList[I]);
+ if N.FName = Name then
+ Exit(N);
+ end;
+end;
+
+function TJsonNode.Exists(const Path: string): Boolean;
+begin
+ Result := Find(Path) <> nil;
+end;
+
+function TJsonNode.Find(const Path: string): TJsonNode;
+var
+ N: TJsonNode;
+ A, B: PChar;
+ S: string;
+begin
+ Result := nil;
+ if Path = '' then
+ Exit(Child(''));
+ if Path[1] = '/' then
+ begin
+ N := Self;
+ while N.Parent <> nil do
+ N := N.Parent;
+ end
+ else
+ N := Self;
+ A := PChar(Path);
+ if A^ = '/' then
+ begin
+ Inc(A);
+ if A^ = #0 then
+ Exit(N);
+ end;
+ if A^ = #0 then
+ Exit(N.Child(''));
+ B := A;
+ while B^ > #0 do
+ begin
+ if B^ = '/' then
+ begin
+ SetString(S, A, B - A);
+ N := N.Child(S);
+ if N = nil then
+ Exit(nil);
+ A := B + 1;
+ B := A;
+ end
+ else
+ begin
+ Inc(B);
+ if B^ = #0 then
+ begin
+ SetString(S, A, B - A);
+ N := N.Child(S);
+ end;
+ end;
+ end;
+ Result := N;
+end;
+
+function TJsonNode.Find(const Path: string; out Node: TJsonNode): Boolean;
+begin
+ Node := Find(Path);
+ Result := Node <> nil;
+end;
+
+function TJsonNode.Force(const Path: string): TJsonNode;
+var
+ N: TJsonNode;
+ A, B: PChar;
+ S: string;
+begin
+ Result := nil;
+ // AsObject;
+ if Path = '' then
+ begin
+ N := Child('');
+ if N = nil then
+ N := Add('');
+ Exit(N);
+ end;
+ if Path[1] = '/' then
+ begin
+ N := Self;
+ while N.Parent <> nil do
+ N := N.Parent;
+ end
+ else
+ N := Self;
+ A := PChar(Path);
+ if A^ = '/' then
+ begin
+ Inc(A);
+ if A^ = #0 then
+ Exit(N);
+ end;
+ if A^ = #0 then
+ begin
+ N := Child('');
+ if N = nil then
+ N := Add('');
+ Exit(N);
+ end;
+ B := A;
+ while B^ > #0 do
+ begin
+ if B^ = '/' then
+ begin
+ SetString(S, A, B - A);
+ if N.Child(S) = nil then
+ N := N.Add(S)
+ else
+ N := N.Child(S);
+ A := B + 1;
+ B := A;
+ end
+ else
+ begin
+ Inc(B);
+ if B^ = #0 then
+ begin
+ SetString(S, A, B - A);
+ if N.Child(S) = nil then
+ N := N.Add(S)
+ else
+ N := N.Child(S);
+ end;
+ end;
+ end;
+ Result := N;
+end;
+
+function TJsonNode.Format(const Indent: string): string;
+
+ function EnumNodes: string;
+ var
+ I, J: Integer;
+ S: string;
+ begin
+ if (FList = nil) or (FList.Count = 0) then
+ Exit(' ');
+ Result := #10;
+ J := FList.Count - 1;
+ S := Indent + #9;
+ for I := 0 to J do
+ begin
+ Result := Result + TJsonNode(FList[I]).Format(S);
+ if I < J then
+ Result := Result + ','#10
+ else
+ Result := Result + #10 + Indent;
+ end;
+ end;
+
+var
+ Prefix: string;
+begin
+ Result := '';
+ if (FParent <> nil) and (FParent.FKind = nkObject) then
+ Prefix := JsonStringEncode(FName) + ': '
+ else
+ Prefix := '';
+ case FKind of
+ nkObject: Result := Indent + Prefix +'{' + EnumNodes + '}';
+ nkArray: Result := Indent + Prefix + '[' + EnumNodes + ']';
+ else
+ Result := Indent + Prefix + FValue;
+ end;
+end;
+
+function TJsonNode.FormatCompact: string;
+
+ function EnumNodes: string;
+ var
+ I, J: Integer;
+ begin
+ Result := '';
+ if (FList = nil) or (FList.Count = 0) then
+ Exit;
+ J := FList.Count - 1;
+ for I := 0 to J do
+ begin
+ Result := Result + TJsonNode(FList[I]).FormatCompact;
+ if I < J then
+ Result := Result + ',';
+ end;
+ end;
+
+var
+ Prefix: string;
+begin
+ Result := '';
+ if (FParent <> nil) and (FParent.FKind = nkObject) then
+ Prefix := JsonStringEncode(FName) + ':'
+ else
+ Prefix := '';
+ case FKind of
+ nkObject: Result := Prefix + '{' + EnumNodes + '}';
+ nkArray: Result := Prefix + '[' + EnumNodes + ']';
+ else
+ Result := Prefix + FValue;
+ end;
+end;
+
+function TJsonNode.ToString: string;
+begin
+ Result := Format('');
+end;
+
+function TJsonNode.GetCount: Integer;
+begin
+ if FList <> nil then
+ Result := FList.Count
+ else
+ Result := 0;
+end;
+
+{ Json helper routines }
+
+function JsonValidate(const Json: string): Boolean;
+var
+ N: TJsonNode;
+begin
+ N := TJsonNode.Create;
+ try
+ Result := N.TryParse(Json);
+ finally
+ N.Free;
+ end;
+end;
+
+function JsonNumberValidate(const N: string): Boolean;
+var
+ C: PChar;
+ T: TJsonToken;
+begin
+ C := PChar(N);
+ Result := NextToken(C, T) and (T.Kind = tkNumber) and (T.Value = N);
+end;
+
+function JsonStringValidate(const S: string): Boolean;
+var
+ C: PChar;
+ T: TJsonToken;
+begin
+ C := PChar(S);
+ Result := NextToken(C, T) and (T.Kind = tkString) and (T.Value = S);
+end;
+
+{ Convert a pascal string to a json string }
+
+function JsonStringEncode(const S: string): string;
+
+ function Len(C: PChar): Integer;
+ var
+ I: Integer;
+ begin
+ I := 0;
+ while C^ > #0 do
+ begin
+ if C^ < ' ' then
+ if C^ in [#8..#13] then
+ Inc(I, 2)
+ else
+ Inc(I, 6)
+ else if C^ in ['"', '\'] then
+ Inc(I, 2)
+ else
+ Inc(I);
+ Inc(C);
+ end;
+ Result := I + 2;
+ end;
+
+const
+ EscapeChars: PChar = '01234567btnvfr';
+ HexChars: PChar = '0123456789ABCDEF';
+var
+ C: PChar;
+ R: string;
+ I: Integer;
+begin
+ if S = '' then
+ Exit('""');
+ C := PChar(S);
+ R := '';
+ SetLength(R, Len(C));
+ R[1] := '"';
+ I := 2;
+ while C^ > #0 do
+ begin
+ if C^ < ' ' then
+ begin
+ R[I] := '\';
+ Inc(I);
+ if C^ in [#8..#13] then
+ R[I] := EscapeChars[Ord(C^)]
+ else
+ begin
+ R[I] := 'u';
+ R[I + 1] := '0';
+ R[I + 2] := '0';
+ R[I + 3] := HexChars[Ord(C^) div $10];
+ R[I + 4] := HexChars[Ord(C^) mod $10];
+ Inc(I, 4);
+ end;
+ end
+ else if C^ in ['"', '\'] then
+ begin
+ R[I] := '\';
+ Inc(I);
+ R[I] := C^;
+ end
+ else
+ R[I] := C^;
+ Inc(I);
+ Inc(C);
+ end;
+ R[Length(R)] := '"';
+ Result := R;
+end;
+
+{ Convert a json string to a pascal string }
+
+function UnicodeToString(C: LongWord): string; inline;
+begin
+ if C = 0 then
+ Result := #0
+ else if C < $80 then
+ Result := Chr(C)
+ else if C < $800 then
+ Result := Chr((C shr $6) + $C0) + Chr((C and $3F) + $80)
+ else if C < $10000 then
+ Result := Chr((C shr $C) + $E0) + Chr(((C shr $6) and
+ $3F) + $80) + Chr((C and $3F) + $80)
+ else if C < $200000 then
+ Result := Chr((C shr $12) + $F0) + Chr(((C shr $C) and
+ $3F) + $80) + Chr(((C shr $6) and $3F) + $80) +
+ Chr((C and $3F) + $80)
+ else
+ Result := '';
+end;
+
+function UnicodeToSize(C: LongWord): Integer; inline;
+begin
+ if C = 0 then
+ Result := 1
+ else if C < $80 then
+ Result := 1
+ else if C < $800 then
+ Result := 2
+ else if C < $10000 then
+ Result := 3
+ else if C < $200000 then
+ Result := 4
+ else
+ Result := 0;
+end;
+
+function HexToByte(C: Char): Byte; inline;
+const
+ Zero = Ord('0');
+ UpA = Ord('A');
+ LoA = Ord('a');
+begin
+ if C < 'A' then
+ Result := Ord(C) - Zero
+ else if C < 'a' then
+ Result := Ord(C) - UpA + 10
+ else
+ Result := Ord(C) - LoA + 10;
+end;
+
+function HexToInt(A, B, C, D: Char): Integer; inline;
+begin
+ Result := HexToByte(A) shl 12 or HexToByte(B) shl 8 or HexToByte(C) shl 4 or
+ HexToByte(D);
+end;
+
+function JsonStringDecode(const S: string): string;
+
+ function Len(C: PChar): Integer;
+ var
+ I, J: Integer;
+ begin
+ if C^ <> '"' then
+ Exit(0);
+ Inc(C);
+ I := 0;
+ while C^ <> '"' do
+ begin
+ if C^ = #0 then
+ Exit(0);
+ if C^ = '\' then
+ begin
+ Inc(C);
+ if C^ = 'u' then
+ begin
+ if (C[1] in Hex) and (C[2] in Hex) and (C[3] in Hex) and (C[4] in Hex) then
+ begin
+ J := UnicodeToSize(HexToInt(C[1], C[2], C[3], C[4]));
+ if J = 0 then
+ Exit(0);
+ Inc(I, J - 1);
+ Inc(C, 4);
+ end
+ else
+ Exit(0);
+ end
+ else if C^ = #0 then
+ Exit(0)
+ end;
+ Inc(C);
+ Inc(I);
+ end;
+ Result := I;
+ end;
+
+const
+ Escape = ['b', 't', 'n', 'v', 'f', 'r'];
+var
+ C: PChar;
+ R: string;
+ I, J: Integer;
+ H: string;
+begin
+ C := PChar(S);
+ I := Len(C);
+ if I < 1 then
+ Exit('');
+ R := '';
+ SetLength(R, I);
+ I := 1;
+ Inc(C);
+ while C^ <> '"' do
+ begin
+ if C^ = '\' then
+ begin
+ Inc(C);
+ if C^ in Escape then
+ case C^ of
+ 'b': R[I] := #8;
+ 't': R[I] := #9;
+ 'n': R[I] := #10;
+ 'v': R[I] := #11;
+ 'f': R[I] := #12;
+ 'r': R[I] := #13;
+ end
+ else if C^ = 'u' then
+ begin
+ H := UnicodeToString(HexToInt(C[1], C[2], C[3], C[4]));
+ for J := 1 to Length(H) - 1 do
+ begin
+ R[I] := H[J];
+ Inc(I);
+ end;
+ R[I] := H[Length(H)];
+ Inc(C, 4);
+ end
+ else
+ R[I] := C^;
+ end
+ else
+ R[I] := C^;
+ Inc(C);
+ Inc(I);
+ end;
+ Result := R;
+end;
+
+function JsonToXml(const S: string): string;
+const
+ Kinds: array[TJsonNodeKind] of string =
+ (' kind="object"', ' kind="array"', ' kind="bool"', ' kind="null"', ' kind="number"', '');
+ Space = ' ';
+
+ function Escape(N: TJsonNode): string;
+ begin
+ Result := N.Value;
+ if N.Kind = nkString then
+ begin
+ Result := JsonStringDecode(Result);
+ Result := StringReplace(Result, '<', '<', [rfReplaceAll]);
+ Result := StringReplace(Result, '>', '>', [rfReplaceAll]);
+ end;
+ end;
+
+ function EnumNodes(P: TJsonNode; const Indent: string): string;
+ var
+ N: TJsonNode;
+ S: string;
+ begin
+ Result := '';
+ if P.Kind = nkArray then
+ S := 'item'
+ else
+ S := '';
+ for N in P do
+ begin
+ Result := Result + Indent + '<' + S + N.Name + Kinds[N.Kind];
+ case N.Kind of
+ nkObject, nkArray:
+ if N.Count > 0 then
+ Result := Result + '>'#10 + EnumNodes(N, Indent + Space) +
+ Indent + ''#10
+ else
+ Result := Result + '/>'#10;
+ nkNull: Result := Result + '/>'#10;
+ else
+ Result := Result + '>' + Escape(N) + ''#10;
+ end;
+ end;
+ end;
+
+var
+ N: TJsonNode;
+begin
+ Result := '';
+ N := TJsonNode.Create;
+ try
+ if N.TryParse(S) then
+ begin
+ Result :=
+ ''#10 +
+ ' 0 then
+ Result := Result + '>'#10 + EnumNodes(N, Space) + ''
+ else
+ Result := Result + '/>';
+ end;
+ finally
+ N.Free;
+ end;
+end;
+
+end.
+
diff --git a/source/codebot.text.pas b/source/codebot/codebot.text.pas
similarity index 78%
rename from source/codebot.text.pas
rename to source/codebot/codebot.text.pas
index 4ff1069..a27f33c 100644
--- a/source/codebot.text.pas
+++ b/source/codebot/codebot.text.pas
@@ -2,7 +2,7 @@
(* *)
(* Codebot Pascal Library *)
(* http://cross.codebot.org *)
-(* Modified March 2015 *)
+(* Modified February 2020 *)
(* *)
(********************************************************)
@@ -19,6 +19,28 @@ interface
{ Codebot units }
Codebot.System;
+{$region unicode utf8 conversion related routines}
+{ The following are some examples of unicode utf8 characters
+
+ Unicode number: U+00A2
+ ¢ = 11000010 10100010
+
+ Unicode number: U+03A3
+ Σ = 11001110 10100011
+
+ Unicode number: U+20AC
+ € = 11100010 10000010 10101100 }
+
+{ Seek to the next character and return the count of utf8 bytes [group unicode] }
+function UnicodeParse(var P: PChar): LongWord;
+{ Seek to the next character and return the utf8 character code [group unicode] }
+function UnicodeToChar(var P: PChar): LongWord;
+{ Return the number of utf8 characters in a string [group unicode] }
+function UnicodeLength(S: string): Integer;
+{ Covert a utf8 character code to a string [group unicode] }
+function UnicodeToStr(C: LongWord): string;
+{$endregion}
+
{$region encoding}
{ The encoding methods can be hexadecimal or base64 [group encoding] }
@@ -48,6 +70,8 @@ TBuffer = record
function GetSize: LongInt;
procedure SetSize(Value: LongInt);
function GetAsString: string;
+ function GetAsHex: string;
+ function GetAsBase64: string;
public
{ Allocate size number of bytes }
class function Create(Size: LongInt): TBuffer; static;
@@ -69,8 +93,12 @@ TBuffer = record
property Data: Pointer read GetData;
{ The number of bytes allocated by buffer }
property Size: LongInt read GetSize write SetSize;
- { If the buffer contains text, this is a shortcut to read back the text }
+ { Convert data to a string }
property AsString: string read GetAsString;
+ { Convert data to a hexidecimal string }
+ property AsHex: string read GetAsHex;
+ { Convert data to a base 64 string }
+ property AsBase64: string read GetAsBase64;
end;
{ TBufferStream can be used to convert a buffer to a stream [group stream]
@@ -118,6 +146,79 @@ function Base64Decode(const S: string): TBuffer;
implementation
+{$region unicode utf8 conversion related routines}
+function UnicodeParse(var P: PChar): LongWord;
+begin
+ if (P = nil) or (P^ = #0) then
+ Exit(0);
+ case Byte(P^) and $F0 of
+ $C0: Result := 2;
+ $E0: Result := 3;
+ $F0: Result := 4;
+ else
+ Result := 1;
+ end;
+ Inc(P, Result);
+end;
+
+function UnicodeToChar(var P: PChar): LongWord;
+begin
+ if (P = nil) or (P^ = #0) then
+ Exit(0);
+ case Byte(P^) and $F0 of
+ $C0:
+ begin
+ Result := ((Byte(P[0]) and $1F) shl 6) or (Byte(P[1]) and $3F);
+ Inc(P, 2);
+ end;
+ $E0:
+ begin
+ Result := ((Byte(P[0]) and $F) shl 12) or ((Byte(P[1]) and $3F) shl 6) or
+ (Byte(P[2]) and $3F);
+ Inc(P, 3);
+ end;
+ $F0:
+ begin
+ Result := ((Byte(P[1]) and $7) shl 18) or ((Byte(P[1]) and $3F) shl 12) or
+ ((Byte(P[2]) and $3F) shl 6) or (Byte(P[3]) and $3F);
+ Inc(P, 4);
+ end;
+ else
+ Result := Byte(P^);
+ Inc(P);
+ end;
+end;
+
+function UnicodeLength(S: string): Integer;
+var
+ P: PChar;
+begin
+ Result := 0;
+ P := PChar(S);
+ while UnicodeParse(P) > 0 do
+ Inc(Result);
+end;
+
+function UnicodeToStr(C: LongWord): string;
+begin
+ if C = 0 then
+ Result := #0
+ else if C < $80 then
+ Result := Chr(C)
+ else if C < $800 then
+ Result := Chr((C shr $6) + $C0) + Chr((C and $3F) + $80)
+ else if C < $10000 then
+ Result := Chr((C shr $C) + $E0) + Chr(((C shr $6) and
+ $3F) + $80) + Chr((C and $3F) + $80)
+ else if C < $200000 then
+ Result := Chr((C shr $12) + $F0) + Chr(((C shr $C) and
+ $3F) + $80) + Chr(((C shr $6) and $3F) + $80) +
+ Chr((C and $3F) + $80)
+ else
+ Result := '';
+end;
+{$endregion}
+
{$region encoding}
{ TBufferObject }
@@ -162,14 +263,20 @@ function TBufferObject.GetSize: LongInt;
end;
procedure TBufferObject.SetSize(Value: LongInt);
+var
+ OldSize: LongInt;
begin
if Value <> FSize then
begin
+ OldSize := FSize;
FSize := Value;
if FSize > 0 then
begin
if FData <> nil then
- ReallocMem(FData, FSize)
+ begin
+ if (FSize > OldSize) or (FSize > 4096) then
+ ReallocMem(FData, FSize);
+ end
else
GetMem(FData, FSize);
end
@@ -205,8 +312,6 @@ function TBuffer.Encode(Method: TEncodeMethod = encodeBase64): string;
case Method of
encodeHex: Result := HexEncode(Data, Size);
encodeBase64: Result := Base64Encode(Data, Size);
- else
- Result := '';
end;
end;
@@ -279,6 +384,22 @@ function TBuffer.GetAsString: string;
Move(PChar(Data)[0], PChar(Result)[0], I);
end;
+function TBuffer.GetAsHex: string;
+begin
+ if Size > 0 then
+ Result := LowerCase(HexEncode(Data, Size))
+ else
+ Result := '';
+end;
+
+function TBuffer.GetAsBase64: string;
+begin
+ if Size > 0 then
+ Result := Base64Encode(Data, Size)
+ else
+ Result := '';
+end;
+
{ TBufferStream }
constructor TBufferStream.Create(Buffer: TBuffer);
@@ -437,6 +558,7 @@ function HexDecode(const S: string): TBuffer;
end;
{ Base64 routines }
+
const
Base64: PChar = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/';
@@ -456,6 +578,7 @@ function Base64Encode(Buffer: Pointer; Size: LongInt): string;
I: LongInt;
J: LongInt;
begin
+ Result := '';
SetLength(Result, Base64EncodedSize(Size));
B := Buffer;
I := 0;
@@ -537,7 +660,7 @@ function Base64Decode(const S: string): TBuffer;
end;
type
- TOutput = array[0..0] of Byte;
+ TOutput = array[0..High(Word)] of Byte;
POutput = ^TOutput;
var
Buffer: TBuffer;
@@ -571,12 +694,15 @@ function Base64Decode(const S: string): TBuffer;
if S[I] = '=' then Zero(C, I) else if not Search(C, I) then Exit;
if S[I] = '=' then Zero(D, I) else if not Search(D, I) then Exit;
E := A shl 18 + B shl 12 + C shl 6 + D;
- if J = OutLen then Break;
- Output[J] := E shr 16 and $FF; Inc(J);
- if J = OutLen then Break;
- Output[J] := E shr 8 and $FF; Inc(J);
- if J = OutLen then Break;
- Output[J] := E and $FF; Inc(J);
+ if J >= OutLen then Break;
+ Output^[J] := E shr 16 and $FF;
+ Inc(J);
+ if J >= OutLen then Break;
+ Output^[J] := E shr 8 and $FF;
+ Inc(J);
+ if J >= OutLen then Break;
+ Output^[J] := E and $FF;
+ Inc(J);
end;
Result := Buffer;
end;
diff --git a/source/codebot/codebot.text.store.pas b/source/codebot/codebot.text.store.pas
new file mode 100644
index 0000000..21f1494
--- /dev/null
+++ b/source/codebot/codebot.text.store.pas
@@ -0,0 +1,212 @@
+(********************************************************)
+(* *)
+(* Codebot Pascal Library *)
+(* http://cross.codebot.org *)
+(* Modified September 2021 *)
+(* *)
+(********************************************************)
+
+{ }
+unit Codebot.Text.Store;
+
+{$i codebot.inc}
+
+interface
+
+uses
+ Codebot.System,
+ Codebot.Text.Xml,
+ Codebot.Text.Json,
+ Classes;
+
+{ TDataTextFormat }
+
+type
+ TDataTextFormat = (dfNone, dfJson, dfXml);
+
+{ TTextStorage }
+
+ TTextStorage = class(TComponent)
+ private
+ FDataFormat: TDataTextFormat;
+ FData: TStrings;
+ FJson: TJsonNode;
+ FXml: IDocument;
+ FJsonChanged: Boolean;
+ FXmlChanged: Boolean;
+ FUseAppConfig: Boolean;
+ procedure SetData(Value: TStrings);
+ procedure SetDataFormat(Value: TDataTextFormat);
+ procedure TextChanged(Sender: TObject);
+ protected
+ procedure Loaded; override;
+ public
+ constructor Create(AOwner: TComponent); override;
+ destructor Destroy; override;
+ procedure LoadAppConfig;
+ procedure SaveAppConfig;
+ procedure Commit;
+ procedure Restore;
+ function AsJson: TJsonNode;
+ function AsXml: IDocument;
+ published
+ property Data: TStrings read FData write SetData;
+ property DataFormat: TDataTextFormat read FDataFormat write SetDataFormat;
+ property UseAppConfig: Boolean read FUseAppConfig write FUseAppConfig;
+ end;
+
+implementation
+
+{ TTextStorage }
+
+constructor TTextStorage.Create(AOwner: TComponent);
+begin
+ inherited Create(AOwner);
+ FDataFormat := dfNone;
+ FJsonChanged := True;
+ FXmlChanged := True;
+ FData := TStringList.Create;
+ TStringList(FData).OnChange := TextChanged;
+end;
+
+destructor TTextStorage.Destroy;
+begin
+ if UseAppConfig then
+ SaveAppConfig;
+ FJSon.Free;
+ inherited Destroy;
+end;
+
+procedure TTextStorage.Loaded;
+begin
+ if UseAppConfig then
+ LoadAppConfig;
+end;
+
+const
+ DataExt: array[TDataTextFormat] of string = ('', '.json', '.xml');
+
+procedure TTextStorage.LoadAppConfig;
+var
+ FileName: string;
+begin
+ if FDataFormat = dfNone then
+ Exit;
+ FileName := Name;
+ FileName := FileName.Trim.ToLower;
+ if FileName = '' then
+ Exit;
+ FileName := PathCombine(ConfigAppDir(False, False), FileName) + DataExt[FDataFormat];
+ if FileExists(FileName) then
+ FData.LoadFromFile(FileName);
+end;
+
+procedure TTextStorage.SaveAppConfig;
+var
+ FileName: string;
+begin
+ if FDataFormat = dfNone then
+ Exit;
+ FileName := Name;
+ FileName := FileName.Trim.ToLower;
+ if FileName = '' then
+ Exit;
+ Commit;
+ FileName := PathCombine(ConfigAppDir(False, True), FileName) + DataExt[FDataFormat];
+ FData.SaveToFile(FileName);
+end;
+
+procedure TTextStorage.Commit;
+begin
+ TStringList(FData).OnChange := nil;
+ if FDataFormat = dfJson then
+ FData.Text := AsJson.Value
+ else if FDataFormat = dfXml then
+ begin
+ AsXml.Beautify;
+ FData.Text := AsXml.Text;
+ end;
+ FJsonChanged := False;
+ FXmlChanged := False;
+ TStringList(FData).OnChange := TextChanged;
+end;
+
+procedure TTextStorage.Restore;
+begin
+ FJsonChanged := True;
+ FXmlChanged := True;
+end;
+
+function TTextStorage.AsJson: TJsonNode;
+var
+ S: string;
+begin
+ FDataFormat := dfJson;
+ if FJson = nil then
+ FJson := TJsonNode.Create;
+ if FJsonChanged then
+ begin
+ FJsonChanged := False;
+ FXmlChanged := True;
+ S := FData.Text.Trim;
+ if S <> '' then
+ FJson.Parse(S)
+ else
+ FJson.Parse('{ }');
+ if FXml <> nil then
+ FXml.Nodes.Clear;
+ end;
+ Result := FJson;
+end;
+
+function TTextStorage.AsXml: IDocument;
+var
+ S: string;
+begin
+ FDataFormat := dfXml;
+ if FXml = nil then
+ FXml := DocumentCreate;
+ if FXmlChanged then
+ begin
+ FXmlChanged := False;
+ FJsonChanged := True;
+ S := FData.Text.Trim;
+ if S <> '' then
+ FXml.Nodes.Clear
+ else
+ FXml.Xml := S;
+ if FJson <> nil then
+ FJson.Parse('{ }');
+ end;
+ Result := FXml;
+end;
+
+procedure TTextStorage.SetData(Value: TStrings);
+begin
+ if Value = FData then
+ Exit;
+ FData.Assign(Value);
+end;
+
+procedure TTextStorage.SetDataFormat(Value: TDataTextFormat);
+begin
+ if Value = FDataFormat then
+ Exit;
+ FDataFormat := Value;
+ TextChanged(nil);
+end;
+
+procedure TTextStorage.TextChanged(Sender: TObject);
+begin
+ if csLoading in ComponentState then
+ Exit;
+ FJsonChanged := True;
+ FXmlChanged := True;
+ if FJson <> nil then
+ FJson.Parse('{ }');
+ if FXml <> nil then
+ FXml.Nodes.Clear;
+end;
+
+end.
+
diff --git a/source/codebot.text.xml.linux.inc b/source/codebot/codebot.text.xml.linux.inc
similarity index 96%
rename from source/codebot.text.xml.linux.inc
rename to source/codebot/codebot.text.xml.linux.inc
index 4309a64..e659b15 100644
--- a/source/codebot.text.xml.linux.inc
+++ b/source/codebot/codebot.text.xml.linux.inc
@@ -349,15 +349,20 @@ begin
end;
end;
+procedure free(Ptr: Pointer); cdecl; external 'c';
+
function xmlGetText(Node: xmlNodePtr): string;
var
B: PChar;
begin
+ Result := '';
if Node = nil then
- Exit('');
+ Exit;
B := xmlNodeGetContent(Node);
+ if B = nil then
+ Exit;
Result := B;
- xmlMemFree(B);
+ free(B);
end;
procedure xmlRemoveEmptyText(Node: xmlNodePtr);
@@ -403,7 +408,8 @@ type
function Instance: Pointer;
function Next: INode;
function SelectNode(const XPath: string): INode;
- function SelectList(const XPath: string): INodeList;
+ function SelectList(const XPath: string): INodeList; overload;
+ function SelectList(const XPath: string; out List: INodeList): Boolean; overload;
function Force(const Path: string): INode;
function GetDocument: IDocument;
function GetParent: INode;
@@ -616,14 +622,14 @@ begin
end;
function TNode.SelectList(const XPath: string): INodeList;
-var
- R: TXPathResult;
begin
- R := Execute(XPath);
- if Length(R) > 0 then
- Result := TXPathList.Create(R)
- else
- Result := nil;
+ Result := TXPathList.Create(Execute(XPath));
+end;
+
+function TNode.SelectList(const XPath: string; out List: INodeList): Boolean;
+begin
+ List := TXPathList.Create(Execute(XPath));
+ Result := List.Count > 0;
end;
function TNode.Force(const Path: string): INode;
@@ -743,6 +749,8 @@ begin
end;
XML_DOCUMENT_NODE:
SetXml(Value);
+ else
+ // Do nothing
end;
end;
@@ -784,7 +792,7 @@ type
constructor TNodeListEnumerator.Create(List: INodeList);
begin
- inherited Create;
+ inherited Create;
FList := List;
FPosition := -1;
end;
@@ -816,7 +824,7 @@ end;
function TNodeList.GetEnumerator: IEnumerator;
begin
- Result := TNodeListEnumerator.Create(Self);
+ Result := TNodeListEnumerator.Create(Self);
end;
procedure TNodeList.Clear;
@@ -834,6 +842,8 @@ begin
XML_ATTRIBUTE_NODE:
while FNode.properties <> nil do
xmlRemoveProp(FNode.properties);
+ else
+ // Do nothing ...
end;
end;
@@ -900,6 +910,8 @@ begin
if A <> nil then
xmlRemoveProp(A);
end;
+ else
+ // Do nothing ...
end;
end;
@@ -922,6 +934,8 @@ begin
if (A <> nil) then
Result := TNode.Create(N);
end;
+ else
+ // Do nothing ...
end;
end;
@@ -944,6 +958,8 @@ begin
if A <> nil then
Result := TNode.Create(xmlNodePtr(A));
end;
+ else
+ // Do nothing ...
end;
end;
@@ -955,6 +971,8 @@ begin
Result := xmlGetElementChildCount(FNode);
XML_ATTRIBUTE_NODE:
Result := xmlGetAttributeChildCount(FNode);
+ else
+ // Do nothing ...
end;
end;
@@ -974,7 +992,7 @@ type
constructor TXPathListEnumerator.Create(List: TXPathResult);
begin
- inherited Create;
+ inherited Create;
FList := List;
FPosition := -1;
end;
@@ -1146,10 +1164,16 @@ end;
{ DocumentCreate }
function DocumentCreate: IDocument;
+begin
+ Result := NewDocument;
+end;
+
+function NewDocument: IDocument;
begin
Xml2Init(True);
Result := TDocument.Create(nil);
end;
+
{$endregion}
{$endif}
diff --git a/source/codebot.text.xml.pas b/source/codebot/codebot.text.xml.pas
similarity index 91%
rename from source/codebot.text.xml.pas
rename to source/codebot/codebot.text.xml.pas
index 6e01675..3b511ef 100644
--- a/source/codebot.text.xml.pas
+++ b/source/codebot/codebot.text.xml.pas
@@ -2,7 +2,7 @@
(* *)
(* Codebot Pascal Library *)
(* http://cross.codebot.org *)
-(* Modified March 2015 *)
+(* Modified August 2019 *)
(* *)
(********************************************************)
@@ -43,6 +43,8 @@ interface
procedure WriteBool(const Key: string; Value: Boolean);
function ReadInt(const Key: string; const DefValue: Integer = 0; Stored: Boolean = False): Integer;
procedure WriteInt(const Key: string; Value: Integer);
+ function ReadInt64(const Key: string; const DefValue: Int64 = 0; Stored: Boolean = False): Int64;
+ procedure WriteInt64(const Key: string; Value: Int64);
function ReadFloat(const Key: string; const DefValue: Single = 0; Stored: Boolean = False): Single;
procedure WriteFloat(const Key: string; Value: Single);
function ReadDate(const Key: string; const DefValue: TDateTime = 0; Stored: Boolean = False): TDateTime;
@@ -68,7 +70,8 @@ interface
function Instance: Pointer;
function Next: INode;
function SelectNode(const XPath: string): INode;
- function SelectList(const XPath: string): INodeList;
+ function SelectList(const XPath: string): INodeList; overload;
+ function SelectList(const XPath: string; out List: INodeList): Boolean; overload;
function Force(const Path: string): INode;
property Document: IDocument read GetDocument;
property Parent: INode read GetParent;
@@ -121,6 +124,7 @@ interface
{ Create a new xml document }
function DocumentCreate: IDocument;
+function NewDocument: IDocument;
{ Create a new filer given a document and a node }
function FilerCreate(Document: IDocument; Node: INode): IFiler;
{$endregion}
@@ -160,6 +164,8 @@ TFiler = class(TInterfacedObject, IFiler)
procedure WriteBool(const Key: string; Value: Boolean);
function ReadInt(const Key: string; const DefValue: Integer = 0; Stored: Boolean = False): Integer;
procedure WriteInt(const Key: string; Value: Integer);
+ function ReadInt64(const Key: string; const DefValue: Int64 = 0; Stored: Boolean = False): Int64;
+ procedure WriteInt64(const Key: string; Value: Int64);
function ReadFloat(const Key: string; const DefValue: Single = 0; Stored: Boolean = False): Single;
procedure WriteFloat(const Key: string; Value: Single);
function ReadDate(const Key: string; const DefValue: TDateTime = 0; Stored: Boolean = False): TDateTime;
@@ -260,6 +266,20 @@ procedure TFiler.WriteInt(const Key: string; Value: Integer);
WriteStr(Key, IntToStr(Value));
end;
+function TFiler.ReadInt64(const Key: string; const DefValue: Int64 = 0; Stored: Boolean = False): Int64;
+var
+ S: string;
+begin
+ S := ReadStr(Key, IntToStr(DefValue), Stored);
+ Result := StrToInt64Def(S, DefValue);
+end;
+
+procedure TFiler.WriteInt64(const Key: string; Value: Int64);
+begin
+ WriteStr(Key, IntToStr(Value));
+end;
+
+
function TFiler.ReadFloat(const Key: string; const DefValue: Single = 0; Stored: Boolean = False): Single;
var
S: string;
diff --git a/source/codebot.text.xml.windows.inc b/source/codebot/codebot.text.xml.windows.inc
similarity index 99%
rename from source/codebot.text.xml.windows.inc
rename to source/codebot/codebot.text.xml.windows.inc
index b5ea20e..f2a4fe6 100644
--- a/source/codebot.text.xml.windows.inc
+++ b/source/codebot/codebot.text.xml.windows.inc
@@ -94,7 +94,7 @@ var
begin
Result := nil;
if FNode = nil then
- Exit;
+ Exit;
if FNode.nodeType = NODE_DOCUMENT then
Exit;
T := FNode.nodeType;
@@ -102,7 +102,7 @@ begin
while N <> nil do
begin
if N.nodeType = T then
- Exit(TNode.Create(N));
+ Exit(TNode.Create(N));
N := FNode.nextSibling;
end;
end;
@@ -335,7 +335,7 @@ type
constructor TNodeListEnumerator.Create(List: INodeList);
begin
- inherited Create;
+ inherited Create;
FList := List;
FPosition := -1;
end;
@@ -367,7 +367,7 @@ end;
function TNodeList.GetEnumerator: IEnumerator