Author: hhubner Date: Tue Jan 29 07:06:27 2008 New Revision: 2415 Added: branches/trunk-reorg/thirdparty/cl-smtp/ branches/trunk-reorg/thirdparty/cl-smtp/CHANGELOG branches/trunk-reorg/thirdparty/cl-smtp/INSTALL branches/trunk-reorg/thirdparty/cl-smtp/LGPL-LICENSE branches/trunk-reorg/thirdparty/cl-smtp/LLGPL-LICENSE branches/trunk-reorg/thirdparty/cl-smtp/README branches/trunk-reorg/thirdparty/cl-smtp/attachments.lisp branches/trunk-reorg/thirdparty/cl-smtp/cl-smtp.asd branches/trunk-reorg/thirdparty/cl-smtp/cl-smtp.lisp branches/trunk-reorg/thirdparty/cl-smtp/index.html branches/trunk-reorg/thirdparty/cl-smtp/mime-types.lisp branches/trunk-reorg/thirdparty/cl-smtp/style.css branches/trunk-reorg/thirdparty/split-sequence/ branches/trunk-reorg/thirdparty/split-sequence/README.cCLan-install branches/trunk-reorg/thirdparty/split-sequence/split-sequence.asd branches/trunk-reorg/thirdparty/split-sequence/split-sequence.lisp branches/trunk-reorg/thirdparty/usocket-0.3.5/ branches/trunk-reorg/thirdparty/usocket-0.3.5/LICENSE branches/trunk-reorg/thirdparty/usocket-0.3.5/Makefile branches/trunk-reorg/thirdparty/usocket-0.3.5/README branches/trunk-reorg/thirdparty/usocket-0.3.5/TODO branches/trunk-reorg/thirdparty/usocket-0.3.5/backend/ branches/trunk-reorg/thirdparty/usocket-0.3.5/backend/allegro.lisp branches/trunk-reorg/thirdparty/usocket-0.3.5/backend/armedbear.lisp branches/trunk-reorg/thirdparty/usocket-0.3.5/backend/clisp.lisp branches/trunk-reorg/thirdparty/usocket-0.3.5/backend/cmucl.lisp branches/trunk-reorg/thirdparty/usocket-0.3.5/backend/lispworks.lisp branches/trunk-reorg/thirdparty/usocket-0.3.5/backend/openmcl.lisp branches/trunk-reorg/thirdparty/usocket-0.3.5/backend/sbcl.lisp branches/trunk-reorg/thirdparty/usocket-0.3.5/backend/scl.lisp branches/trunk-reorg/thirdparty/usocket-0.3.5/condition.lisp branches/trunk-reorg/thirdparty/usocket-0.3.5/doc/ branches/trunk-reorg/thirdparty/usocket-0.3.5/doc/backends.txt branches/trunk-reorg/thirdparty/usocket-0.3.5/doc/design.txt branches/trunk-reorg/thirdparty/usocket-0.3.5/notes/ branches/trunk-reorg/thirdparty/usocket-0.3.5/notes/abcl-socket.txt branches/trunk-reorg/thirdparty/usocket-0.3.5/notes/active-sockets-apis.txt branches/trunk-reorg/thirdparty/usocket-0.3.5/notes/address-apis.txt branches/trunk-reorg/thirdparty/usocket-0.3.5/notes/allegro-socket.txt branches/trunk-reorg/thirdparty/usocket-0.3.5/notes/clisp-sockets.txt branches/trunk-reorg/thirdparty/usocket-0.3.5/notes/cmucl-sockets.txt branches/trunk-reorg/thirdparty/usocket-0.3.5/notes/errors.txt branches/trunk-reorg/thirdparty/usocket-0.3.5/notes/lw-sockets.txt branches/trunk-reorg/thirdparty/usocket-0.3.5/notes/openmcl-sockets.txt branches/trunk-reorg/thirdparty/usocket-0.3.5/notes/sb-bsd-sockets.txt branches/trunk-reorg/thirdparty/usocket-0.3.5/notes/usock-sockets.txt branches/trunk-reorg/thirdparty/usocket-0.3.5/package.lisp branches/trunk-reorg/thirdparty/usocket-0.3.5/run-usocket-tests.sh (contents, props changed) branches/trunk-reorg/thirdparty/usocket-0.3.5/test/ branches/trunk-reorg/thirdparty/usocket-0.3.5/test/abcl.conf.in branches/trunk-reorg/thirdparty/usocket-0.3.5/test/allegro.conf.in branches/trunk-reorg/thirdparty/usocket-0.3.5/test/clisp.conf.in branches/trunk-reorg/thirdparty/usocket-0.3.5/test/cmucl.conf.in branches/trunk-reorg/thirdparty/usocket-0.3.5/test/package.lisp branches/trunk-reorg/thirdparty/usocket-0.3.5/test/sbcl.conf.in branches/trunk-reorg/thirdparty/usocket-0.3.5/test/test-usocket.lisp branches/trunk-reorg/thirdparty/usocket-0.3.5/test/usocket-test.asd branches/trunk-reorg/thirdparty/usocket-0.3.5/test/usocket.asd (contents, props changed) branches/trunk-reorg/thirdparty/usocket-0.3.5/test/your-lisp.conf.in branches/trunk-reorg/thirdparty/usocket-0.3.5/usocket.asd branches/trunk-reorg/thirdparty/usocket-0.3.5/usocket.lisp Removed: branches/trunk-reorg/thirdparty/portableaserve/ Modified: branches/trunk-reorg/thirdparty/parenscript/src/parser.lisp Log: update and add packages to replace portableaserve Added: branches/trunk-reorg/thirdparty/cl-smtp/CHANGELOG ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/cl-smtp/CHANGELOG Tue Jan 29 07:06:27 2008 @@ -0,0 +1,85 @@ +Version 20071113.1 +2007.11.13 +Add SSL support, thank Timothy Ritchey for the suggestions. +New boolean keyword argument ssl added to send-email. +Change cl-smtp.lisp, cl-smtp.asd, README, CHANGELOG + +Version 20071104.1 +2007.11.04 +Fixed bug with the file attachments to solve corrupted files when +processed with chunking turned on. (Brian Sorg) +Added automatically including mime types for attachesments +of common known extensions. (Brian Sorg) +Added Html-messages option to send-mail function. (Brian Sorg) +Change attachments.lisp, cl-smtp.asd, cl-smtp.lisp, README, CHANGELOG +Add mime-type.lisp + +Version 20071018.1 +2007.10.18 +Reverted the non allegro base64 functionality in attachment.lisp, +now it is used cl-base64 again. Thanks Attila Lendvai for the bug report. +Change attachments.lisp, cl-smtp.asd, CHANGELOG + +Version 20070904.1 +2007-09-04 +Remove implementation dependent sockets code by adding usocket dependency. +Change cl-smtp.asd cl-smtp.lisp README INSTALL + (remove acl.lisp clisp.lisp cmucl.lisp sbcl.lisp lispworks.lisp openmcl.lisp) + +Version 20060404.1 +2006-04-04 +"ADD" support for attachment, thanks Brian Sorg for the implementation +Added attachments.lisp +Change cl-smtp.asd cl-smtp.lisp README + +Version 20051220.1 +2005-12-20 +"ADD" win32 support for clisp +"REMOVE" :cl-smtp-authentication +"CHANGE" always use CL-BASE64 package +Change cl-smtp.asd, cl-smtp.lisp, clisp.lisp, README, CHANGELOG + +Version 20051211.1 +2005-12-11 +"ADD" :cl-smtp-authentication for reader macro, that you can use cl-smtp with and +without authentication support +Change cl-smtp.asd, cl-smtp.lisp, README, CHANGELOG + +Version 20051210.1 +2005-12-10 +"ADD" key authentication for smtp authentication: '(:plain "username" "password") +or '(:login "username" "password") +add dependency to CL-BASE64 except allegro +Change cl-smtp.asd, cl-smtp.lisp, CHANGELOG + +Version 20050729.1 +2005-07-29 +"CHANGE" license from LGPL to LLGPL +"ADD" key display-name for optional display name of the from email adress +(RFC 2822 3.4. Address Specification) +Added LLGPL-LICENSE +Change all files + +Version 20050127.1 +2005-01-27 +"FIXED" add correct multiline replies in read-from-smtp (RFC 822 APPENDIX E) +"ADD" key extra-headers to send-email, send-smtp +thanks Dave Bakkash to inform me about the wrong implemantation +of read-from-smtp and the tip with the extra-headers +Change cl-smtp.asd, cl-smtp.lisp, README, CHANGELOG + +Version 20050119.1 +2005-01-19 +Add portability file "lispworks.lisp" to work with Lispworks, +thanks Sean Ross for this file +Added lispworks.lisp +Change cl-smtp.asd, README, INSTALL, CHANGELOG + +Version 20050104.1 +2005-01-04 +"Fixed" month "Sep" missed in get-email-date-string +Added this CHANGELOG + +Version 20040812.1 +2004-08-12 +Initial release Added: branches/trunk-reorg/thirdparty/cl-smtp/INSTALL ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/cl-smtp/INSTALL Tue Jan 29 07:06:27 2008 @@ -0,0 +1,13 @@ + +CL-SMTP works in all implementations supported by its dependencies. + +For all implementations you'll need usocket +and cl-base64 (the latter isn't a requirement on ACL). + +CL-SMTP has a asdf system definition file. + +To load this file: + +(asdf:operate 'asdf:load-op 'cl-smtp) + +thats all. Added: branches/trunk-reorg/thirdparty/cl-smtp/LGPL-LICENSE ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/cl-smtp/LGPL-LICENSE Tue Jan 29 07:06:27 2008 @@ -0,0 +1,504 @@ + GNU LESSER GENERAL PUBLIC LICENSE + Version 2.1, February 1999 + + Copyright (C) 1991, 1999 Free Software Foundation, Inc. + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + +[This is the first released version of the Lesser GPL. It also counts + as the successor of the GNU Library Public License, version 2, hence + the version number 2.1.] + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +Licenses are intended to guarantee your freedom to share and change +free software--to make sure the software is free for all its users. + + This license, the Lesser General Public License, applies to some +specially designated software packages--typically libraries--of the +Free Software Foundation and other authors who decide to use it. You +can use it too, but we suggest you first think carefully about whether +this license or the ordinary General Public License is the better +strategy to use in any particular case, based on the explanations below. + + When we speak of free software, we are referring to freedom of use, +not price. Our General Public Licenses are designed to make sure that +you have the freedom to distribute copies of free software (and charge +for this service if you wish); that you receive source code or can get +it if you want it; that you can change the software and use pieces of +it in new free programs; and that you are informed that you can do +these things. + + To protect your rights, we need to make restrictions that forbid +distributors to deny you these rights or to ask you to surrender these +rights. These restrictions translate to certain responsibilities for +you if you distribute copies of the library or if you modify it. + + For example, if you distribute copies of the library, whether gratis +or for a fee, you must give the recipients all the rights that we gave +you. You must make sure that they, too, receive or can get the source +code. If you link other code with the library, you must provide +complete object files to the recipients, so that they can relink them +with the library after making changes to the library and recompiling +it. And you must show them these terms so they know their rights. + + We protect your rights with a two-step method: (1) we copyright the +library, and (2) we offer you this license, which gives you legal +permission to copy, distribute and/or modify the library. + + To protect each distributor, we want to make it very clear that +there is no warranty for the free library. Also, if the library is +modified by someone else and passed on, the recipients should know +that what they have is not the original version, so that the original +author's reputation will not be affected by problems that might be +introduced by others. + + Finally, software patents pose a constant threat to the existence of +any free program. We wish to make sure that a company cannot +effectively restrict the users of a free program by obtaining a +restrictive license from a patent holder. Therefore, we insist that +any patent license obtained for a version of the library must be +consistent with the full freedom of use specified in this license. + + Most GNU software, including some libraries, is covered by the +ordinary GNU General Public License. This license, the GNU Lesser +General Public License, applies to certain designated libraries, and +is quite different from the ordinary General Public License. We use +this license for certain libraries in order to permit linking those +libraries into non-free programs. + + When a program is linked with a library, whether statically or using +a shared library, the combination of the two is legally speaking a +combined work, a derivative of the original library. The ordinary +General Public License therefore permits such linking only if the +entire combination fits its criteria of freedom. The Lesser General +Public License permits more lax criteria for linking other code with +the library. + + We call this license the "Lesser" General Public License because it +does Less to protect the user's freedom than the ordinary General +Public License. It also provides other free software developers Less +of an advantage over competing non-free programs. These disadvantages +are the reason we use the ordinary General Public License for many +libraries. However, the Lesser license provides advantages in certain +special circumstances. + + For example, on rare occasions, there may be a special need to +encourage the widest possible use of a certain library, so that it becomes +a de-facto standard. To achieve this, non-free programs must be +allowed to use the library. A more frequent case is that a free +library does the same job as widely used non-free libraries. In this +case, there is little to gain by limiting the free library to free +software only, so we use the Lesser General Public License. + + In other cases, permission to use a particular library in non-free +programs enables a greater number of people to use a large body of +free software. For example, permission to use the GNU C Library in +non-free programs enables many more people to use the whole GNU +operating system, as well as its variant, the GNU/Linux operating +system. + + Although the Lesser General Public License is Less protective of the +users' freedom, it does ensure that the user of a program that is +linked with the Library has the freedom and the wherewithal to run +that program using a modified version of the Library. + + The precise terms and conditions for copying, distribution and +modification follow. Pay close attention to the difference between a +"work based on the library" and a "work that uses the library". The +former contains code derived from the library, whereas the latter must +be combined with the library in order to run. + + GNU LESSER GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License Agreement applies to any software library or other +program which contains a notice placed by the copyright holder or +other authorized party saying it may be distributed under the terms of +this Lesser General Public License (also called "this License"). +Each licensee is addressed as "you". + + A "library" means a collection of software functions and/or data +prepared so as to be conveniently linked with application programs +(which use some of those functions and data) to form executables. + + The "Library", below, refers to any such software library or work +which has been distributed under these terms. A "work based on the +Library" means either the Library or any derivative work under +copyright law: that is to say, a work containing the Library or a +portion of it, either verbatim or with modifications and/or translated +straightforwardly into another language. (Hereinafter, translation is +included without limitation in the term "modification".) + + "Source code" for a work means the preferred form of the work for +making modifications to it. For a library, complete source code means +all the source code for all modules it contains, plus any associated +interface definition files, plus the scripts used to control compilation +and installation of the library. + + Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running a program using the Library is not restricted, and output from +such a program is covered only if its contents constitute a work based +on the Library (independent of the use of the Library in a tool for +writing it). Whether that is true depends on what the Library does +and what the program that uses the Library does. + + 1. You may copy and distribute verbatim copies of the Library's +complete source code as you receive it, in any medium, provided that +you conspicuously and appropriately publish on each copy an +appropriate copyright notice and disclaimer of warranty; keep intact +all the notices that refer to this License and to the absence of any +warranty; and distribute a copy of this License along with the +Library. + + You may charge a fee for the physical act of transferring a copy, +and you may at your option offer warranty protection in exchange for a +fee. + + 2. You may modify your copy or copies of the Library or any portion +of it, thus forming a work based on the Library, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) The modified work must itself be a software library. + + b) You must cause the files modified to carry prominent notices + stating that you changed the files and the date of any change. + + c) You must cause the whole of the work to be licensed at no + charge to all third parties under the terms of this License. + + d) If a facility in the modified Library refers to a function or a + table of data to be supplied by an application program that uses + the facility, other than as an argument passed when the facility + is invoked, then you must make a good faith effort to ensure that, + in the event an application does not supply such function or + table, the facility still operates, and performs whatever part of + its purpose remains meaningful. + + (For example, a function in a library to compute square roots has + a purpose that is entirely well-defined independent of the + application. Therefore, Subsection 2d requires that any + application-supplied function or table used by this function must + be optional: if the application does not supply it, the square + root function must still compute square roots.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Library, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Library, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote +it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Library. + +In addition, mere aggregation of another work not based on the Library +with the Library (or with a work based on the Library) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may opt to apply the terms of the ordinary GNU General Public +License instead of this License to a given copy of the Library. To do +this, you must alter all the notices that refer to this License, so +that they refer to the ordinary GNU General Public License, version 2, +instead of to this License. (If a newer version than version 2 of the +ordinary GNU General Public License has appeared, then you can specify +that version instead if you wish.) Do not make any other change in +these notices. + + Once this change is made in a given copy, it is irreversible for +that copy, so the ordinary GNU General Public License applies to all +subsequent copies and derivative works made from that copy. + + This option is useful when you wish to copy part of the code of +the Library into a program that is not a library. + + 4. You may copy and distribute the Library (or a portion or +derivative of it, under Section 2) in object code or executable form +under the terms of Sections 1 and 2 above provided that you accompany +it with the complete corresponding machine-readable source code, which +must be distributed under the terms of Sections 1 and 2 above on a +medium customarily used for software interchange. + + If distribution of object code is made by offering access to copy +from a designated place, then offering equivalent access to copy the +source code from the same place satisfies the requirement to +distribute the source code, even though third parties are not +compelled to copy the source along with the object code. + + 5. A program that contains no derivative of any portion of the +Library, but is designed to work with the Library by being compiled or +linked with it, is called a "work that uses the Library". Such a +work, in isolation, is not a derivative work of the Library, and +therefore falls outside the scope of this License. + + However, linking a "work that uses the Library" with the Library +creates an executable that is a derivative of the Library (because it +contains portions of the Library), rather than a "work that uses the +library". The executable is therefore covered by this License. +Section 6 states terms for distribution of such executables. + + When a "work that uses the Library" uses material from a header file +that is part of the Library, the object code for the work may be a +derivative work of the Library even though the source code is not. +Whether this is true is especially significant if the work can be +linked without the Library, or if the work is itself a library. The +threshold for this to be true is not precisely defined by law. + + If such an object file uses only numerical parameters, data +structure layouts and accessors, and small macros and small inline +functions (ten lines or less in length), then the use of the object +file is unrestricted, regardless of whether it is legally a derivative +work. (Executables containing this object code plus portions of the +Library will still fall under Section 6.) + + Otherwise, if the work is a derivative of the Library, you may +distribute the object code for the work under the terms of Section 6. +Any executables containing that work also fall under Section 6, +whether or not they are linked directly with the Library itself. + + 6. As an exception to the Sections above, you may also combine or +link a "work that uses the Library" with the Library to produce a +work containing portions of the Library, and distribute that work +under terms of your choice, provided that the terms permit +modification of the work for the customer's own use and reverse +engineering for debugging such modifications. + + You must give prominent notice with each copy of the work that the +Library is used in it and that the Library and its use are covered by +this License. You must supply a copy of this License. If the work +during execution displays copyright notices, you must include the +copyright notice for the Library among them, as well as a reference +directing the user to the copy of this License. Also, you must do one +of these things: + + a) Accompany the work with the complete corresponding + machine-readable source code for the Library including whatever + changes were used in the work (which must be distributed under + Sections 1 and 2 above); and, if the work is an executable linked + with the Library, with the complete machine-readable "work that + uses the Library", as object code and/or source code, so that the + user can modify the Library and then relink to produce a modified + executable containing the modified Library. (It is understood + that the user who changes the contents of definitions files in the + Library will not necessarily be able to recompile the application + to use the modified definitions.) + + b) Use a suitable shared library mechanism for linking with the + Library. A suitable mechanism is one that (1) uses at run time a + copy of the library already present on the user's computer system, + rather than copying library functions into the executable, and (2) + will operate properly with a modified version of the library, if + the user installs one, as long as the modified version is + interface-compatible with the version that the work was made with. + + c) Accompany the work with a written offer, valid for at + least three years, to give the same user the materials + specified in Subsection 6a, above, for a charge no more + than the cost of performing this distribution. + + d) If distribution of the work is made by offering access to copy + from a designated place, offer equivalent access to copy the above + specified materials from the same place. + + e) Verify that the user has already received a copy of these + materials or that you have already sent this user a copy. + + For an executable, the required form of the "work that uses the +Library" must include any data and utility programs needed for +reproducing the executable from it. However, as a special exception, +the materials to be distributed need not include anything that is +normally distributed (in either source or binary form) with the major +components (compiler, kernel, and so on) of the operating system on +which the executable runs, unless that component itself accompanies +the executable. + + It may happen that this requirement contradicts the license +restrictions of other proprietary libraries that do not normally +accompany the operating system. Such a contradiction means you cannot +use both them and the Library together in an executable that you +distribute. + + 7. You may place library facilities that are a work based on the +Library side-by-side in a single library together with other library +facilities not covered by this License, and distribute such a combined +library, provided that the separate distribution of the work based on +the Library and of the other library facilities is otherwise +permitted, and provided that you do these two things: + + a) Accompany the combined library with a copy of the same work + based on the Library, uncombined with any other library + facilities. This must be distributed under the terms of the + Sections above. + + b) Give prominent notice with the combined library of the fact + that part of it is a work based on the Library, and explaining + where to find the accompanying uncombined form of the same work. + + 8. You may not copy, modify, sublicense, link with, or distribute +the Library except as expressly provided under this License. Any +attempt otherwise to copy, modify, sublicense, link with, or +distribute the Library is void, and will automatically terminate your +rights under this License. However, parties who have received copies, +or rights, from you under this License will not have their licenses +terminated so long as such parties remain in full compliance. + + 9. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Library or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Library (or any work based on the +Library), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Library or works based on it. + + 10. Each time you redistribute the Library (or any work based on the +Library), the recipient automatically receives a license from the +original licensor to copy, distribute, link with or modify the Library +subject to these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties with +this License. + + 11. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Library at all. For example, if a patent +license would not permit royalty-free redistribution of the Library by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Library. + +If any portion of this section is held invalid or unenforceable under any +particular circumstance, the balance of the section is intended to apply, +and the section as a whole is intended to apply in other circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 12. If the distribution and/or use of the Library is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Library under this License may add +an explicit geographical distribution limitation excluding those countries, +so that distribution is permitted only in or among countries not thus +excluded. In such case, this License incorporates the limitation as if +written in the body of this License. + + 13. The Free Software Foundation may publish revised and/or new +versions of the Lesser General Public License from time to time. +Such new versions will be similar in spirit to the present version, +but may differ in detail to address new problems or concerns. + +Each version is given a distinguishing version number. If the Library +specifies a version number of this License which applies to it and +"any later version", you have the option of following the terms and +conditions either of that version or of any later version published by +the Free Software Foundation. If the Library does not specify a +license version number, you may choose any version ever published by +the Free Software Foundation. + + 14. If you wish to incorporate parts of the Library into other free +programs whose distribution conditions are incompatible with these, +write to the author to ask for permission. For software which is +copyrighted by the Free Software Foundation, write to the Free +Software Foundation; we sometimes make exceptions for this. Our +decision will be guided by the two goals of preserving the free status +of all derivatives of our free software and of promoting the sharing +and reuse of software generally. + + NO WARRANTY + + 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO +WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. +EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR +OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY +KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE +LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME +THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN +WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY +AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU +FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR +CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE +LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING +RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A +FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF +SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH +DAMAGES. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Libraries + + If you develop a new library, and you want it to be of the greatest +possible use to the public, we recommend making it free software that +everyone can redistribute and change. You can do so by permitting +redistribution under these terms (or, alternatively, under the terms of the +ordinary General Public License). + + To apply these terms, attach the following notices to the library. It is +safest to attach them to the start of each source file to most effectively +convey the exclusion of warranty; and each file should have at least the +"copyright" line and a pointer to where the full notice is found. + + <one line to give the library's name and a brief idea of what it does.> + Copyright (C) <year> <name of author> + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Lesser General Public + License as published by the Free Software Foundation; either + version 2.1 of the License, or (at your option) any later version. + + This library is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + +Also add information on how to contact you by electronic and paper mail. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the library, if +necessary. Here is a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the + library `Frob' (a library for tweaking knobs) written by James Random Hacker. + + <signature of Ty Coon>, 1 April 1990 + Ty Coon, President of Vice + +That's all there is to it! + + Added: branches/trunk-reorg/thirdparty/cl-smtp/LLGPL-LICENSE ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/cl-smtp/LLGPL-LICENSE Tue Jan 29 07:06:27 2008 @@ -0,0 +1,18 @@ + + +Preamble to the Gnu Lesser General Public License + + +Copyright (c) 2000 Franz Incorporated, Berkeley, CA 94704 + +The concept of the GNU Lesser General Public License version 2.1 ("LGPL") has been adopted to govern the use and distribution of above-mentioned application. However, the LGPL uses terminology that is more appropriate for a program written in C than one written in Lisp. Nevertheless, the LGPL can still be applied to a Lisp program if certain clarifications are made. This document details those clarifications. Accordingly, the license for the open-source Lisp applications consists of this document plus the LGPL. Wherever there is a conflict between this document and the LGPL, this document takes precedence over the LGPL. + +A "Library" in Lisp is a collection of Lisp functions, data and foreign modules. The form of the Library can be Lisp source code (for processing by an interpreter) or object code (usually the result of compilation of source code or built with some other mechanisms). Foreign modules are object code in a form that can be linked into a Lisp executable. When we speak of functions we do so in the most general way to include, in addition, methods and unnamed functions. Lisp "data" is also a general term that includes the data structures resulting from defining Lisp classes. A Lisp application may include the same set of Lisp objects as does a Library, but this does not mean that the application is necessarily a "work based on the Library" it contains. + +The Library consists of everything in the distribution file set before any modifications are made to the files. If any of the functions or classes in the Library are redefined in other files, then those redefinitions ARE considered a work based on the Library. If additional methods are added to generic functions in the Library, those additional methods are NOT considered a work based on the Library. If Library classes are subclassed, these subclasses are NOT considered a work based on the Library. If the Library is modified to explicitly call other functions that are neither part of Lisp itself nor an available add-on module to Lisp, then the functions called by the modified Library ARE considered a work based on the Library. The goal is to ensure that the Library will compile and run without getting undefined function errors. + +It is permitted to add proprietary source code to the Library, but it must be done in a way such that the Library will still run without that proprietary code present. Section 5 of the LGPL distinguishes between the case of a library being dynamically linked at runtime and one being statically linked at build time. Section 5 of the LGPL states that the former results in an executable that is a "work that uses the Library." Section 5 of the LGPL states that the latter results in one that is a "derivative of the Library", which is therefore covered by the LGPL. Since Lisp only offers one choice, which is to link the Library into an executable at build time, we declare that, for the purpose applying the LGPL to the Library, an executable that results from linking a "work that uses the Library" with the Library is considered a "work that uses the Library" and is therefore NOT covered by the LGPL. + +Because of this declaration, section 6 of LGPL is not applicable to the Library. However, in connection with each distribution of this executable, you must also deliver, in accordance with the terms and conditions of the LGPL, the source code of Library (or your derivative thereof) that is incorporated into this executable. + +End of Document \ No newline at end of file Added: branches/trunk-reorg/thirdparty/cl-smtp/README ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/cl-smtp/README Tue Jan 29 07:06:27 2008 @@ -0,0 +1,61 @@ + +CL-SMTP is a simple lisp smtp client. +It works in ACL, SBCL, CMUCL, OPENMCL, LISPWORKS, CLISP and ECL. + +new with support for send attachments, thanks Brian Sorg for the implementation + +with authentication support for PLAIN and LOGIN authentication method + +and ssl support with cl+ssl package + +used cl-base64 and usocket packages (cl-base64 isn't a requirement on ACL) + +See INSTALL for prerequisites and build details. + +To use cl-smtp: + +(asdf:operate 'asdf:load-op 'cl-smtp) + +------------------------------------------------ + +(cl-smtp:send-email host from to subject message + &key (port 25) cc bcc reply-to extra-headers html-message + authentication attachments (buffer-size 256) ssl) + + Arguments: + - host (String) : hostname or ip-adress of the smtpserver + - from (String) : email adress + - to (String or Cons of Strings) : email adress + - subject (String) : subject text + - message (String) : message body + keywords: + - cc (String or Cons of Strings) : email adress carbon copy + - bcc (String or Cons of Strings): email adress blind carbon copy + - reply-to (String) : email adress + - displayname (String) : displayname of the sender + - extra-headers (Cons) : extra headers as alist + - html-message (String) : message body formatted with HTML tags + - authentication (Cons) : list with 3 elements + (:method "username" "password") + method is a keyword :plain or :login + - attachments (String or Pathname: attachments to send + Cons of String/Pathnames) + - buffer-size (Number default 256): controls how much of a attachment file + is read on each loop before encoding + and transmitting the contents, + the number is interpretted in KB + - ssl (Boolean) : if true than use the STARTTLS functionality to make a ssl connection + +Returns nil or error with message + +For debug output set the parameter *debug* to t (default nil) +(setf cl-smtp::*debug* t) + +CL-SMTP set automaticly the Date header and the X-Mailer header. +X-Mailer: cl-smtp ((lisp-implementation-type) (lisp-implementation-version)) + +You can change this with setting the parameter *x-mailer* +(setf cl-smtp::*x-mailer* "my x-mailer string) + +If you find bugs or want to send patches for enhancements, by email to +Jan Idzikowski <jidzikowski@common-lisp.net> Added: branches/trunk-reorg/thirdparty/cl-smtp/attachments.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/cl-smtp/attachments.lisp Tue Jan 29 07:06:27 2008 @@ -0,0 +1,167 @@ +;;; -*- mode: Lisp -*- + +;;; This file is part of CL-SMTP, the Lisp SMTP Client + + +;;; Copyright (C) 2004/2005/2006/2007 Jan Idzikowski + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the Lisp Lesser General Public License +;;; (http://opensource.franz.com/preamble.html), known as the LLGPL. + +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; Lisp Lesser GNU General Public License for more details. + +;;; File: attachments.lisp +;;; Description: encoding and transmitting login to include a mime attachment + +;;; +;;; Contributed by Brian Sorg +;;; +;;; Thanks to David Cooper for make-random-boundary +;;; +(in-package :cl-smtp) + +;;; Addition to allow for sending mime attachments along with the smtp message + +;;---- Initialize array of possible boundary characters to make start of attachments +(defparameter *boundary-chars* + (let* ((chars (list #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m + #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z + #\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M + #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z + #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)) + (arr (make-array (length chars)))) + (dotimes (i (length chars) arr) + (setf (aref arr i) (pop chars))))) + +(defun make-random-boundary (&optional (length 30) + (boundary-chars *boundary-chars*)) + (let ((boundary (make-string length)) + (prefix "_---------_") + (chars-length (length boundary-chars))) + (dotimes (i length (concatenate 'string prefix boundary)) + (setf (aref boundary i) + (svref *boundary-chars* (random chars-length)))))) + +(defun generate-multipart-header (sock boundary &key (multipart-type "mixed")) + (write-to-smtp sock + (format nil "Content-type: multipart/~a;~%~tBoundary=\"~a\"" + multipart-type boundary))) + +(defun generate-message-header (sock + &key boundary ;; uniques string of character -- see make-random-boundary + content-type ;; "text/plain; charset=ISO-8859-1" + content-disposition ;; inline attachment + content-transfer-encoding ;; 7 bit or 8 bit + (include-blank-line? t)) + (when boundary + (write-to-smtp sock (format nil "--~a" boundary))) + (when content-type + (write-to-smtp sock (format nil "Content-type: ~a" content-type))) + (when content-disposition + (write-to-smtp sock (format nil "Content-Disposition: ~A" + content-disposition))) + (when content-transfer-encoding + (write-to-smtp sock (format nil "Content-Transfer-Encoding: ~A" + content-transfer-encoding))) + (when include-blank-line? (write-blank-line sock))) + +(defun send-attachment-header (sock boundary name) + + (generate-message-header + sock + :boundary boundary + :content-type (format nil "~a;~%~tname=\"~a\"" (lookup-mime-type name) name) + :content-transfer-encoding "base64" + :content-disposition (format nil "attachment; filename=\"~a\"" name))) + +(defun send-end-marker (sock boundary) + ;; Note the -- at beginning and end of boundary is required + (write-to-smtp sock (format nil "~%--~a--~%" boundary))) + +(defun send-attachment (sock attachment boundary buffer-size) + (when (probe-file attachment) + (let ((name (file-namestring attachment))) + (send-attachment-header sock boundary name) + (base64-encode-file attachment sock :buffer-size buffer-size)))) + +(defun base64-encode-file (file-in sock + &key + (buffer-size 256) ;; in KB + (wrap-at-column 70)) + "Encodes the file contents given by file-in, which can be of any form appropriate to with-open-file, and write the base-64 encoded version to sock, which is a socket. + +Buffer-size, given in KB, controls how much of the file is processed and written to the socket at one time. A buffer-size of 0, processes the file all at once, regardless of its size. One will have to weigh the speed vs, memory consuption risks when chosing which way is best. + +Wrap-at-column controls where the encode string is divided for line breaks." + (when (probe-file file-in) + ;;-- open filein --------- + (with-open-file (strm-in file-in + :element-type '(unsigned-byte 8)) + (let* ((;; convert buffer size given to bytes + ;; or compute bytes based on file + max-buffer-size + (if (zerop buffer-size) + (file-length strm-in) + ;; Ensures 64 bit encoding is properly + ;; divided so that filler + ;; characters are not required between chunks + (* 24 (truncate (/ (* buffer-size 1024) 24))))) + (column-count 0) + (eof? nil) + (buffer (make-array max-buffer-size + :element-type '(unsigned-byte 8)))) + (loop + (print-debug (format nil "~%Process attachment ~a~%" file-in)) + (let* ((;; read a portion of the file into the buffer arrary and + ;; returns the index where it stopped + byte-count (dotimes (i max-buffer-size max-buffer-size) + (let ((bchar (read-byte strm-in nil 'EOF))) + (if (eql bchar 'EOF) + (progn + (setq eof? t) + (return i)) + (setf (aref buffer i) bchar)))))) + (if (zerop buffer-size) + ;; send file all at once to socket. + #+allegro + (write-string (excl:usb8-array-to-base64-string + buffer wrap-at-column) sock) + #-allegro + (cl-base64:usb8-array-to-base64-stream + buffer sock :columns wrap-at-column) + ;; otherwise process file in chunks. + ;; The extra encoded-string, + ;; and its subseq functions are brute force methods + ;; to properly handle the wrap-at-column feature + ;; between buffers. + ;; Not the most efficient way, + ;; but it works and uses existing functions + ;; in the cl-base64 package. + (let* ((;; drops off extra elements that were not filled in in reading, this is important for lisp systems that default a value into + ;; the array when it is created. -- ie Lispworks, SBCL + trimmed-buffer (if eof? + (subseq buffer 0 byte-count) + buffer)) + (encoded-string + #+allegro + (excl:usb8-array-to-base64-string + trimmed-buffer) + #-allegro + (cl-base64:usb8-array-to-base64-string + trimmed-buffer))) + (loop for ch across encoded-string + do (progn + (write-char ch sock) + (incf column-count) + (when (= column-count wrap-at-column) + (setq column-count 0) + (write-char #\Newline sock)))))) + (force-output sock) + (print-debug (format nil "~% Eof is ~a~%" eof?)) + (when (or (zerop buffer-size) + eof?) + (return)))))))) Added: branches/trunk-reorg/thirdparty/cl-smtp/cl-smtp.asd ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/cl-smtp/cl-smtp.asd Tue Jan 29 07:06:27 2008 @@ -0,0 +1,40 @@ +;;; -*- mode: Lisp -*- + +;;; This file is part of CL-SMTP, the Lisp SMTP Client + +;;; Copyright (C) 2004/2005/2006/2007 Jan Idzikowski + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the Lisp Lesser General Public License +;;; (http://opensource.franz.com/preamble.html), known as the LLGPL. + +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; Lisp Lesser GNU General Public License for more details. + +;;; File: cl-smtp.asd +;;; Description: cl-smtp ASDF system definition file + +(defpackage :cl-smtp + (:use :cl :asdf) + (:export :send-email)) + +(in-package :cl-smtp) + +(defparameter *debug* nil) + +(defmacro print-debug (str) + `(when *debug* + (print ,str))) + +(asdf:defsystem :cl-smtp + :version "20071113.1" + :perform (load-op :after (op webpage) + (pushnew :cl-smtp cl:*features*)) + :depends-on (:usocket #-allegro :cl-base64 + #-allegro :flexi-streams + #-allegro :cl+ssl) + :components ((:file "cl-smtp" :depends-on ("attachments")) + (:file "attachments") + (:file "mime-types"))) Added: branches/trunk-reorg/thirdparty/cl-smtp/cl-smtp.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/cl-smtp/cl-smtp.lisp Tue Jan 29 07:06:27 2008 @@ -0,0 +1,341 @@ +;;; -*- mode: Lisp -*- + +;;; This file is part of CL-SMTP, the Lisp SMTP Client + +;;; Copyright (C) 2004/2005/2006/2007 Jan Idzikowski + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the Lisp Lesser General Public License +;;; (http://opensource.franz.com/preamble.html), known as the LLGPL. + +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; Lisp Lesser GNU General Public License for more details. + +;;; File: cl-smtp.lisp +;;; Description: main smtp client logic + +(in-package :cl-smtp) + +(defparameter *content-type* "text/plain; charset=ISO-8859-1") + +(defparameter *x-mailer* (format nil "(~A ~A)" + (lisp-implementation-type) + (lisp-implementation-version))) + +(defun check-arg (arg name) + (cond + ((or (stringp arg) + (pathnamep arg)) + (list arg)) + ((listp arg) + arg) + (t + (error "the \"~A\" argument is not a string or cons" name)))) + +(defun mask-dot (str) + "replace \r\n.\r\n with \r\n..\r\n" + (let ((dotstr (format nil "~C~C.~C~C" #\Return #\NewLine + #\Return #\NewLine)) + (maskdotsr (format nil "~C~C..~C~C" #\Return #\NewLine + #\Return #\NewLine)) + (resultstr "")) + (labels ((mask (tempstr) + (let ((n (search dotstr tempstr))) + (cond + (n + (setf resultstr (concatenate 'string resultstr + (subseq tempstr 0 n) + maskdotsr)) + (mask (subseq tempstr (+ n 5)))) + (t + (setf resultstr (concatenate 'string resultstr + tempstr))))))) + (mask str)) + resultstr)) + +(defun string-to-base64-string (str) + (declare (ignorable str)) + #+allegro (excl:string-to-base64-string str) + #-allegro (cl-base64:string-to-base64-string str)) + + +(defun send-email (host from to subject message + &key (port 25) cc bcc reply-to extra-headers + html-message display-name authentication + attachments (buffer-size 256) ssl) + (send-smtp host from (check-arg to "to") subject (mask-dot message) + :port port :cc (check-arg cc "cc") :bcc (check-arg bcc "bcc") + :reply-to reply-to + :extra-headers extra-headers + :html-message html-message + :display-name display-name + :authentication authentication + :attachments (check-arg attachments "attachments") + :buffer-size (if (numberp buffer-size) + buffer-size + 256) + :ssl ssl)) + + +(defun send-smtp (host from to subject message + &key (port 25) cc bcc reply-to extra-headers html-message + display-name authentication attachments buffer-size ssl) + (let* ((sock (usocket:socket-stream (usocket:socket-connect host port))) + (boundary (make-random-boundary)) + (html-boundary (if (and attachments html-message) + (make-random-boundary) + boundary))) + (unwind-protect + (let ((stream (open-smtp-connection sock + :authentication authentication + :ssl ssl))) + (send-smtp-headers stream :from from :to to :cc cc :bcc bcc + :reply-to reply-to + :display-name display-name + :extra-headers extra-headers :subject subject) + (when (or attachments html-message) + (send-multipart-headers + stream :attachment-boundary (when attachments boundary) + :html-boundary html-boundary)) + ;;----------- Send the body Message --------------------------- + ;;--- Send the proper headers depending on plain-text, + ;;--- multi-part or html email + (cond ((and attachments html-message) + ;; if both present, start attachment section, + ;; then define alternative section, + ;; then write alternative header + (progn + (generate-message-header + stream :boundary boundary :include-blank-line? nil) + (generate-multipart-header stream html-boundary + :multipart-type "alternative") + (write-blank-line stream) + (generate-message-header + stream :boundary html-boundary :content-type *content-type* + :content-disposition "inline" :include-blank-line? nil))) + (attachments + (generate-message-header + stream :boundary boundary + :content-type *content-type* :content-disposition "inline" + :include-blank-line? nil)) + (html-message + (generate-message-header + stream :boundary html-boundary :content-type *content-type* + :content-disposition "inline")) + (t + (generate-message-header stream :content-type *content-type* + :include-blank-line? nil))) + (write-blank-line stream) + (write-to-smtp stream message) + (write-blank-line stream) + ;;---------- Send Html text if needed ------------------------- + (when html-message + (generate-message-header + stream :boundary html-boundary + :content-type "text/html; charset=ISO-8859-1" + :content-disposition "inline") + (write-to-smtp stream html-message) + (send-end-marker stream html-boundary)) + ;;---------- Send Attachments ----------------------------------- + (when attachments + (dolist (attachment attachments) + (send-attachment stream attachment boundary buffer-size)) + (send-end-marker stream boundary)) + (write-char #\. stream) + (write-blank-line stream) + (force-output stream) + (multiple-value-bind (code msgstr) + (read-from-smtp stream) + (when (/= code 250) + (error "Message send failed: ~A" msgstr))) + (write-to-smtp stream "QUIT") + (multiple-value-bind (code msgstr) + (read-from-smtp stream) + (when (/= code 221) + (error "in QUIT command:: ~A" msgstr)))) + (close sock)))) + +(defun open-smtp-connection (stream &key authentication ssl) + (multiple-value-bind (code msgstr) + (read-from-smtp stream) + (when (/= code 220) + (error "wrong response from smtp server: ~A" msgstr))) + (when ssl + (write-to-smtp stream (format nil "EHLO ~A" + (usocket::get-host-name))) + (multiple-value-bind (code msgstr lines) + (read-from-smtp stream) + (when (/= code 250) + (error "wrong response from smtp server: ~A" msgstr)) + (when ssl + (cond + ((find "STARTTLS" lines :test #'equal) + (print-debug "this server supports TLS") + (write-to-smtp stream "STARTTLS") + (multiple-value-bind (code msgstr) + (read-from-smtp stream) + (when (/= code 220) + (error "Unable to start TLS: ~A" msgstr)) + (setf stream + #+allegro (socket:make-ssl-client-stream stream) + #-allegro + (let ((s stream)) + (cl+ssl:make-ssl-client-stream + (cl+ssl:stream-fd stream) + :close-callback (lambda () (close s))))) + #-allegro + (setf stream (flexi-streams:make-flexi-stream + stream + :external-format + (flexi-streams:make-external-format + :latin-1 :eol-style :lf))))) + (t + (error "this server does not supports TLS")))))) + (cond + (authentication + (write-to-smtp stream (format nil "EHLO ~A" + (usocket::get-host-name))) + (multiple-value-bind (code msgstr) + (read-from-smtp stream) + (when (/= code 250) + (error "wrong response from smtp server: ~A" msgstr))) + (cond + ((eq (car authentication) :plain) + (write-to-smtp stream (format nil "AUTH PLAIN ~A" + (string-to-base64-string + (format nil "~A~C~A~C~A" + (cadr authentication) + #\null (cadr authentication) + #\null + (caddr authentication))))) + (multiple-value-bind (code msgstr) + (read-from-smtp stream) + (when (/= code 235) + (error "plain authentication failed: ~A" msgstr)))) + ((eq (car authentication) :login) + (write-to-smtp stream "AUTH LOGIN") + (multiple-value-bind (code msgstr) + (read-from-smtp stream) + (when (/= code 334) + (error "login authentication failed: ~A" msgstr))) + (write-to-smtp stream (string-to-base64-string (cadr authentication))) + (multiple-value-bind (code msgstr) + (read-from-smtp stream) + (when (/= code 334) + (error "login authentication send username failed: ~A" msgstr))) + (write-to-smtp stream (string-to-base64-string (caddr authentication))) + (multiple-value-bind (code msgstr) + (read-from-smtp stream) + (when (/= code 235) + (error "login authentication send password failed: ~A" msgstr)))) + (t + (error "authentication ~A is not supported in cl-smtp" + (car authentication))))) + (t + (write-to-smtp stream (format nil "HELO ~A" (usocket::get-host-name))) + (multiple-value-bind (code msgstr) + (read-from-smtp stream) + (when (/= code 250) + (error "wrong response from smtp server: ~A" msgstr))))) + stream) + +(defun send-smtp-headers (stream + &key from to cc bcc reply-to + extra-headers display-name subject) + (write-to-smtp stream + (format nil "MAIL FROM:~@[~A ~]<~A>" display-name from)) + (multiple-value-bind (code msgstr) + (read-from-smtp stream) + (when (/= code 250) + (error "in MAIL FROM command: ~A" msgstr))) + (compute-rcpt-command stream to) + (compute-rcpt-command stream cc) + (compute-rcpt-command stream bcc) + (write-to-smtp stream "DATA") + (multiple-value-bind (code msgstr) + (read-from-smtp stream) + (when (/= code 354) + (error "in DATA command: ~A" msgstr))) + (write-to-smtp stream (format nil "Date: ~A" (get-email-date-string))) + (write-to-smtp stream (format nil "From: ~@[~A <~]~A~@[>~]" + display-name from display-name)) + (write-to-smtp stream (format nil "To: ~{ ~a~^,~}" to)) + (when cc + (write-to-smtp stream (format nil "Cc: ~{ ~a~^,~}" cc))) + (write-to-smtp stream (format nil "Subject: ~A" subject)) + (write-to-smtp stream (format nil "X-Mailer: cl-smtp ~A" + *x-mailer*)) + (when reply-to + (write-to-smtp stream (format nil "Reply-To: ~A" reply-to))) + (when (and extra-headers + (listp extra-headers)) + (dolist (l extra-headers) + (write-to-smtp stream + (format nil "~A: ~{~a~^,~}" (car l) (rest l))))) + (write-to-smtp stream "Mime-Version: 1.0")) + +(defun send-multipart-headers (stream &key attachment-boundary html-boundary) + (cond (attachment-boundary + (generate-multipart-header stream attachment-boundary + :multipart-type "mixed")) + (html-boundary (generate-multipart-header + stream html-boundary + :multipart-type "alternative")) + (t nil))) + +(defun compute-rcpt-command (stream adresses) + (dolist (to adresses) + (write-to-smtp stream (format nil "RCPT TO:<~A>" to)) + (multiple-value-bind (code msgstr) + (read-from-smtp stream) + (when (/= code 250) + (error "in RCPT TO command: ~A" msgstr))))) + +(defun write-to-smtp (stream command) + (print-debug (format nil "to server: ~A" command)) + (write-string command stream) + (write-char #\Return stream) + (write-char #\NewLine stream) + (force-output stream)) + +(defun write-blank-line (stream) + (write-char #\Return stream) + (write-char #\NewLine stream) + (force-output stream)) + +(defun read-from-smtp (stream &optional lines) + (let* ((line (read-line stream)) + (response (string-trim '(#\Return #\NewLine) (subseq line 4))) + (response-code (parse-integer line :start 0 :junk-allowed t))) + (print-debug (format nil "from server: ~A" line)) + (if (= (char-code (elt line 3)) (char-code #\-)) + (read-from-smtp stream (append lines (list response))) + (values response-code line lines)))) + +(defun get-email-date-string () + (multiple-value-bind (sec min h d m y wd) (get-decoded-time) + (let* ((month (elt '("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec") (- m 1))) + (weekday (elt '("Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun") wd)) + (timezone (get-timezone-from-integer + (- (encode-universal-time sec min h d m y 0) + (get-universal-time))))) + (format nil "~A, ~2,'0d ~A ~d ~2,'0d:~2,'0d:~2,'0d ~D" + weekday d month y h min sec timezone)))) + +(defun get-timezone-from-integer (x) + (let ((min (/ x 60)) + (hour (/ x 3600))) + (if (integerp hour) + (cond + ((>= hour 0) + (format nil "+~2,'0d00" hour)) + ((< hour 0) + (format nil "-~2,'0d00" (* -1 hour)))) + (multiple-value-bind (h m) (truncate min 60) + (cond + ((>= hour 0) + (format nil "+~2,'0d~2,'0d" h (truncate m))) + ((< hour 0) + (format nil "-~2,'0d~2,'0d" (* -1 h) (* -1 (truncate m))))))))) Added: branches/trunk-reorg/thirdparty/cl-smtp/index.html ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/cl-smtp/index.html Tue Jan 29 07:06:27 2008 @@ -0,0 +1,93 @@ +<?xml version="1.0"?> +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" + "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en"> + <head> + <title>CL-SMTP</title> + <link rel="stylesheet" type="text/css" href="style.css"/> + <meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1"/> +</head> + +<body> + <div class="header"> + <h1>CL-SMTP at common-lisp.net</h1> + </div> + + <h3>Introduction</h3> + + <p>CL-SMTP is a simple lisp Networking Library that provides SMTP client protocol, supported LOGIN and PLAIN authentication methods.</p> + + <p><b>New Version</b> [20071018.1] Reverted the non allegro base64 functionality in attachment.lisp, now it is used cl-base64 again. Thanks Attila Lendvai for the bug report.</p> + + <h3>Download</h3> + + <p>ASDF package <a href="cl-smtp.tar.gz">cl-smtp.tar.gz</a></p> + + <h3>CVS</h3> + + <p>You can <a + href="http://common-lisp.net/cgi-bin/viewcvs.cgi/?cvsroot=cl-smtp"> +browse our CVS repository</a> or download the current development tree via + anonymous cvs, as described <a href="/faq.shtml#checkout">here</a></p> + + <h3>Portability</h3> + + <p>CL-SMTP requires USOCKET and CL-BASE64 (CL-BASE64 isn't a requirement on ACL)</p> + <p>It works in all implementations supported by its dependencies (Allegro, SBCL, CMU CL, OpenMCL, Lispworks, CLISP and ECL).</p> + <p>Test results for Linux/x86/amd64:</p> + <table cellspacing="0" cellpadding="2" border="1"> + <thead> + <tr> + <th>Lisp Implementation</th> + <th>Status</th> + <th>Comments</th> + </tr> + </thead> + <tr> + <td>Allegro</td> + <td class="working">working</td> + </tr> + <tr> + <td>CLISP</td> + <td class="working">working</td> + </tr> + <tr> + <td>CMU CL</td> + <td class="working">working</td> + </tr> + <tr> + <td>Lispworks</td> + <td class="working">working</td> + </tr> + <tr> + <td>SBCL</td> + <td class="working">working</td> + </tr> + <tr> + <td>OpemMCL</td> + <td class="working">working</td> + </tr> + </table> + + <h3>Mailing Lists</h3> + <ul> + <li> + <a + href="http://www.common-lisp.net/mailman/listinfo/cl-smtp-devel"> + CL-SMTP-devel</a><br/>for developers</li> + <li> + <a + href="http://www.common-lisp.net/mailman/listinfo/cl-smtp-cvs"> + CL-SMTP-cvs</a><br/>CVS log feed.</li> + </ul> + + <div class="footer"> + <a href="mailto:jidzikowski (at) common-lisp (dot) net">Jan Idzikowski</a>, 24. May 2005. + </div> + + <div class="check"> + <a href="http://validator.w3.org/check/referer"> + Valid XHTML 1.0 Strict</a> + </div> + </body> +</html> Added: branches/trunk-reorg/thirdparty/cl-smtp/mime-types.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/cl-smtp/mime-types.lisp Tue Jan 29 07:06:27 2008 @@ -0,0 +1,556 @@ +;;; -*- mode: Lisp -*- + +;;; This file is part of CL-SMTP, the Lisp SMTP Client + + +;;; Copyright (C) 2004/2005/2006/2007 Jan Idzikowski + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the Lisp Lesser General Public License +;;; (http://opensource.franz.com/preamble.html), known as the LLGPL. + +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; Lisp Lesser GNU General Public License for more details. + +;;; File: attachments.lisp +;;; Description: encoding and transmitting login to include a mime attachment + +;;; +;;; Contributed by Brian Sorg +;;; +(in-package :cl-smtp) + +(eval-when (:compile-toplevel :load-toplevel) +;;; Some of the most common file extensions with the mime types and descriptions. +;;; Extracted from numberous webpages. + (defparameter *mime-type-descriptions* + '(("386" "application/octet-stream" + "Windows Enhanced Mode Driver or Swap File") + ("001" "application/x-001" "FAX Datafile") + ("3GPP" "audio/3gpp" + "3rd +Generation Partnership Project. Multimedia over 3rd generation wireless +networks. H.263 video is the mandatory video format in 3GPP and AMR is +the main audio/speech format.") + ("7CB" "application/vnd.ecdis-update" + "Electronic Chart Display and Information System (ECDIS)") + ("aa" "audio/audible" "Audible file format (audio books)") + ("aab" "application/x-authorware-bin" "Macromedia Authorware Binary") + ("aac" "audio/aac" + "Advanced Audio Coding File. Part of MPEG-2 and MPEG-4 standard. (Apple iTunes Store)") + ("aam" "application/x-authorware-map" "Authorware Map (Shockwave?)") + ("aas" "application/x-authorware-seg" + "Authorware Shocked Packet (Segment) ") + ("aba" "text/x-palm-aba" "AddressBook Archive (Palm)") + ("ac3" "audio/ac3" + "Adaptive Transform Coder 3 (relates to the bitstream format of Dolby Digital)") + ("adr" "application/x-msaddr" "Address Book") + ("aexpk" "application/pgp-keys" "Armored extracted public key (PGP)") + ("afl" "video/animaflex" "Font file (for Allways) (Lotus 1-2-3)") + ("ahtml" "magnus-internal/cgi-advertiser" " ") + ("ai" "application/postscript" + "Encapsulated PostScript (metafile) (Adobe Illustrator)") + ("aif" "audio/x-aiff" "Audio Interchange File Format") + ("aifc" "audio/x-aiff" "Audio Interchange File Format") + ("aiff" "audio/x-aiff" "Audio Interchange File Format") + ("aim" "application/x-aim" "AIM file - AOL Instant Messanger") + ("alt" "application/x-up-alert" "Menu file (WordPerfect Library)") + ("aos" "application/x-nokia-" "Add-On Software (Nokia 9000)") + ("arj" "application/x-arj" + "Compressed file archive created by ARJ or winzip") + ("art" "image/x-jg" + "AOL Johnson-Grace Compressed File and Another Ray Tracer Format") + ("asc" "application/pgp-encrypted" "Armored Encrypted file (PGP)") + ("asd" "application/astound" "Autosave file (Word for Windows)") + ("asf" "application/vnd.ms-asf video/x-ms-asf video/x-ms-wm" + "Windows Media file - Advanced Streaming Format (ASF), NetShow") + ("asn" "application/astound" " ") + ("asp" "text/html" + "Active Server Pages - standard HTML documents interlaced with ActiveX script code ") + ("asr" "video/x-ms-asf" "Microsoft NetShow") + ("asx" "video/x-ms-asf application/x-mplayer2" + "VXtreme (Microsoft streaming AV)") + ("asz" "application/astound" " ") + ("au" "audio/basic" "8-bit u-law [PCM] / 8000 Hz") + ("avi" "video/x-msvideo" "Windows Video file") + ("axs" "application/olescript" " ") + ("bas" "text/plain" "BASIC program") + ("bat" "application/octet-stream" "DOS BAT (Batch) file.") + ("bcpio" "application/x-bcpio" "Old Binary CPIO") + ("bexpk" "application/pgp-keys" "binary extracted public key (PGP)") + ("bin" "application/octet-stream" "Uninterpreted Binary Data") + ("bk" "application/vnd.framemaker" "FrameMaker book ") + ("bleep" "application/bleeper" " ") + ("bmp" "image/x-bmp" "Windows Bitmap (PaintBrush)") + ("btf" "image/prs.btf" "NationsBank Check Images (also .btif)") + ("c" "text/plain" "C program") + ("c++" "text/plain" "C program") + ("cab" "application/cab" + "Cabinet file Microsoft installation archive. opersyss=win32, mac cpu=x86, ppc, mips, alpha") + ("cal" "application/x-msschedplus" "MS schedplus or calendar") + ("cat" "application/pdf" + "PDF Catalog (Used with Acrobat Reader and Search plug-in)") + ("cat" "application/vnd.ms-pki.seccat" "Security Catalog") + ("ccs" "text/ccs" + "Cluster Configuration System used with the Global File System (GFS) in Red Hat Linux") + ("cdda" "audio/aiff" "CD Audio Track") + ("cda" "audio/x-cda" "CD Audio Track") + ("cdf" "text/plain" "Channel Definition Format - MS push std") + ("cdr" "application/x-coreldrw" "Corel Draw (metafile)") + ("cer" " application/pkix-cert" "Certificatefile") + ("cfm" "wwwserver/wsapi" "Cold Fusion Markup") + ("cgi" "magnus-internal/cgi" "Common Gateway Interface") + ("cgm" "image/cgm" "Computer Graphics Metafile ") + ("chat" "application/x-chat" " ") + ("che" "application/x-up-cacheop" " ") + ("cht" "audio/x-dspeech" + "Chart (Harvard Graphics 2.0 - SoftCraft Presenter)") + ("cil" "application/vnd.ms-artgalry" "Clip Gallery Download Packages") + ("class" "application/java-vm" "Java") + ("cli" "application/vnd.ms-artgalry" " ") + ("clp" "application/x-msclip" "Windows Clipboard (metafile)") + ("cmx" "image/x-cmx" " ") + ("cnc" "application/x-cnc" "CNC general program data") + ("cod" "image/cis-cod" + "Datafile (Forecast Plus - MS Multiplan - StatPac Gold)") + ("coda" "application/x-coda" " ") + ("com" "application/octet-stream" + "DOS COM Executable (similar to exe, but a direct memory image)") + ("cpi" "image/cpi" "ColorLab Processed Image ") + ("cpio" "application/x-cpio" "IEEE Std1003.2 (`POSIX') CPIO") + ("cpt" "application/mac-compactpro" "Compact Pro Archive") + ("crd" "application/x-mscardfile" "MS cardfile") + ("crt" "application/x-x509-ca-cert" "Certificatefile") + ("csh" "application/x-csh" "CSH Script") + ("csm" "application/x-cu-seeme" "Precompiled headers (Borland C++ 4.5)") + ("css" "text/css" "Cascading Style Sheets") + ("csv" "text/csv" + "Comma-Separated Values (Excel, Lotus 123, FoxPro, MS Outlook)") + ("ct" "image/" "Iris CT Graphic or Scitex CT Handshake Bitmap ") + ("cu" "application/x-cu-seeme" " ") + ("cut" "image/x-halo-cut" "Bitmap graphics") + ("dat" "application/octet-stream" + "Data file. Can be anything, text, graphics, binary, ...") + ("dba" "text/x-palm-dba" "DateBook Archive (Palm)") + ("dbf" "application/octet-stream" "DataBase File (FoxPro, dBase) ") + ("dbm" "wwwserver/wsapi" "ColdFusion IIS Plugin") + ("dca" "application/dca-rft" "IBM Doc Content Arch") + ("dcr" "application/x-director" "Macromedia Director (Shockwave)") + ("deb" "application/octet-stream" "Binary for debian UNIX") + ("der" "application/x-x509-ca-cert" "Certificatefile") + ("dir" "application/x-director" "Macromedia Director (Shockwave)") + ("dll" "application/x-msdownload" + "Dynamically Linked Library (DOS) pe-portable executable opersys=win32, mac cpu=x86, ppc, mips, alpha") + ("dms" "application/octet-stream" + "Compressed Amiga file archive created by DISKMASHER") + ("doc" "application/msword" "MS Word") + ("dot" "application/msword" "MS Word (Template)") + ("dsf" "image/x-mgx-dsf" "Micrografx Designer 6 (metafile)") + ("dst" "application/tajima" "PC-RDist Distribution file ") + ("dtd" "text/xml" "SGML Document (Type) Definition file") + ("dus" "audio/x-dspeech" "Readiris font dictionary") + ("dvi" "application/x-dvi" "TeX DVI (Device Independent)") + ("dwc" "application/dwc" "compressed archive") + ("dwf" "drawing/x-dwf" "Autodesk WHIP! Drawing Web file") + ("dwg" "application/x-acad" "AutoCAD Drawing") + ("dxf" "application/vnd.dxf" + "Drawing eXchange Format, Data Exchange File, AutoCAD (vector)") + ("dxr" "application/x-director" "Macromedia Director (Shockwave)") + ("ebk" "application/x-expandedbook" " ") + ("emf" "image/x-emf" + "Enhanced metafile created in Microsoft Windows and Visio 2002 applications") + ("eml" "message/rfc822" + "MS Internet Mail Message (Outlook Express and others)") + ("enc" "application/pre-encrypted" + "Pre-encrypted Data (also Sniffer trace)") + ("eps" "application/postscript" "Encapsulated PostScript (raster)") + ("erf" "application/x-hsp-erf" " ") + ("es" "audio/echospeech" " ") + ("etf" "image/x-etf" "Enriched Text file") + ("etx" "text/x-setext" "Structure Enchanced Text") + ("evy" "application/x-envoy" "Document (WordPerfect Envoy)") + ("exe" "application/x-pe-" + "pe-portable executable opersys=win32, mac cpu=x86, ppc, mips, alpha") + ("fdf" "application/vnd.fdf" "acrobat reader") + ("fh4" "image/x-freehand" "Vector graphics (Aldus FreeHand 4.x)") + ("fh5" "image/x-freehand" "Freehand 5") + ("fhc" "image/x-freehand" "Freehand") + ("fif" "image/fif" "Fractal Image Format file") + ("fla" "application/x-shockwave-flash" " ") + ("flac" "audio/flac" "Free Lossless Audio Codec") + ("flc" "video/flc " "FLIC Animated Picture Autodesk ") + ("fli" "video/fli " "FLIC Animated Picture Autodesk ") + ("fm" "application/vnd.framemaker " "FrameMaker Document") + ("fm3" "application/x-maker " "FrameMaker") + ("fm4" "application/vnd.framemaker" "FrameMaker") + ("fm5" "application/vnd.framemaker" "FrameMaker") + ("fml" "application/fml" " ") + ("fp5" "application/filemaker5" "FileMaker Pro") + ("frl" "application/freeloader" "FormFlow file") + ("frm" "application/vnd.framemaker" "FrameMaker") + ("fs" "application/X-FSRecipe" " ") + ("g3f" "image/g3fax" "Group III FAX") + ("gb" "application/chinese-gb" "Chinese Text") + ("gif" "image/gif" + "GIF - Graphics Interchange Format - Compuserve (raster)") + ("gsd" "audio/x-gsm" "GSM Internet Realtime Audio ") + ("gsm" "audio/x-gsm" "Raw GSM 6.10 Audio Stream ") + ("gtar" "application/x-gtar" "Gnu Tar") + ("gz" "application/x-gzip" "Unix Gzip (gnu-compress ecnapsulation)") + ("hdf" "application/x-hdf" "NCSA HDF (Hierarchical Data Format)") + ("hdml" "text/x-hdml" " ") + ("hlb" "vms/help" "VMS help libraries") + ("hlp" "application/x-mshelp" "Windows Help") + ("hpgl" "application/vnd.hp-HPGL" "HP Graphic Language") + ("hqx" "application/mac-binhex40" + "BinHex 4.0 Format - Macintosh Binary to ASCII conversion.") + ("htm" "text/html" "HTML - HyperText Markup Language") + ("html" "text/html" "HTML - HyperText Markup Language") + ("hz" "application/chinese-hz" "Chinese") + ("ica" "application/x-ica" + "Bitmap graphics (Image Object Content Architecture)") + ("ice" "x-conference/x-cooltalk" " ") + ("ico" "image/ico" "Windows icon") + ("icq" "application/x-icq" "Saved ") + ("ics" "text/calendar" "iCalendar Calendar Data (Mac)") + ("ief" "image/ief" "Image Exchange Format") + ("iff" "image/iff " "Amiga Bitmap Graphic ") + ("iges" "model/iges" " ") + ("img" "image/img" + "Venture Publisher, GEM Draw (bit mapped), AutoCAD CAD-Camera, others") + ("inc" "text/plain" " ") + ("inf" "application/x-setupscript" + "Setup scripts (For Installing Drivers, etc.), Autorun - auto-start file for a CD-ROM") + ("ins" "application/x-NET-Install" "Data (WordPerfect)") + ("ipx" "application/x-ipix" "IPIX AV file") + ("isapi" "wwwserver/isapi" + "Internet Server API - Application Program(ming) Interface") + ("ivr" "i-world/i-vrml" "Virtual Reality World Live Picture ") + ("jar" "application/java-archive" " ") + ("java" "text/plain" " ") + ("jfx" "application/octet-stream" + "eFax Fax Document (J2 Global Communications ") + ("jpe" "image/jpeg" "JPEG-JFIF - Joint Photographic Experts Group") + ("jpeg" "image/jpeg" "JPEG-JFIF - Joint Photographic Experts Group") + ("jpg" "image/jpeg" + "JPEG-JFIF - Joint Photographic Experts Group (raster)") + ("jps" "image/x-jps" "Stereo Image") + ("js" "application/x-javascript" "Java Script") + ("jsc" "application/x-javascript-config" " ") + ("jsp" "magnus-internal/jsp" "Java Script") + ("la" "audio/nspaudio" "Netscape Packetized audio ") + ("latex" "application/x-latex" "LaTeX Source") + ("ldif" "text/x-ldif" + "LDAP Data Interchange Format ( Netscape Address Book)") + ("lha" "application/octet-stream" "LHA Archive") + ("lisp" "text/plain" "Lisp Files") + ("lma" "audio/nspaudio" "Netscape Packetized audio ") + ("loe" "application/vnd.framemaker" "FrameMaker list of exhibits ") + ("lof" "application/vnd.framemaker" "FrameMaker list of figures ") + ("lot" "application/vnd.framemaker" "FrameMaker list of tables ") + ("lwp" "WordPro 9.5 " " ") + ("lzh" "application/octet-stream" "compressed") + ("lzs" "application/octet-stream" "compressed") + ("lzx" "application/octet-stream" "compressed") + ("m13" "application/x-msmediaview" "MS mediaview") + ("m14" "application/x-msmediaview" "MS mediaview") + ("m3u" "audio/x-mpegurl" "Music Playlist (Winamp)") + ("m4a" "audio/" "Apple iTunes AAC and ALE unprotected") + ("ma" "application/mathmetica" "Mathmetica Notebook") + ("m4p" "audio/" "Apple iTunes AAC protected") + ("m4b" "audio/" "Apple iTunes AAC protected autiobook") + ("man" "application/x-troff-man" "Troff w/MAN Macros") + ("map" "application/x-httpd-imap" "Image Configuration File (HTML Image Map)") + ("mbd" "application/mbedlet" " ") + ("mcf" "image/vasa" "Mathcad font") + ("mda" "application/x-msaccess" "MS Access (May not be desirable)") + ("mdb" "application/x-msaccess" "MS access") + ("me" "application/x-troff-me" "Troff w/ME Macros") + ("mesh" "model/mesh" " ") + ("mfp" "application/mirage" " ") + ("mht" "message/rfc822" "Microsoft Web Archiv") + ("mid" "audio/x-midi" "MIDI") + ("midi" "audio/x-midi" "MIDI") + ("mif" "application/vnd.mif" "Maker Interchange Format (FrameMaker)") + ("mime" "message/rfc822" + "base64 (6-bit) is the standard for encoding binary attachme") + ("mk" "application/vnd.framemaker" "FrameMaker") + ("mmf" "application/x-smaf application/vnd.smaf" + "SMAF = \"Synthetic music Mobile Application Format\" - Polyphonic Ringtone File for Phones - Yamaha") + ("mmm" "application/pdf" "Acrobat Media Clip") + ("mny" "application/x-msmoney" "MS money") + ("mocha" "application/x-javascript" "Java Script") + ("mol" "chemical/x-mdl-molfile" "MDL Molfile ") + ("mov" "video/quicktime" "QuickTime digital video") + ("movie" "video/x-sgi-movie" "SGI \"movieplayer\" movie") + ("mp2" "audio/mpeg" "MPEG Audio Stream, Layer II ") + ("mp3" "audio/mpeg" "MPEG Audio Stream, Layer III ") + ("mp4" "video/mp4v-es" + "MPEG Audio Stream, Layer IV (QuickTime and RealPlayer)") + ("mpa" "audio/mpeg" "MPEG Audio Stream, Layer I, II or III ") + ("mpe" "video/mpeg" "MPEG - Motion Picture Experts Group") + ("mpeg" "video/mpeg" "MPEG - Motion Picture Experts Group") + ("mpg" "video/mpeg" "MPEG - Motion Picture Experts Group") + ("mpga" "audio/mpeg" " ") + ("mpire" "application/x-mpire" " ") + ("mpl" "application/x-mpire" " ") + ("mpp" "application/vnd.ms-project" "MS Project") + ("mpt" "application/vnd.ms-project" "MS Project") + ("mpv" "application/vnd.ms-project" "MS Project view") + ("mpw" "application/vnd.ms-project" "MS Project") + ("mpx" "application/vnd.ms-project" "MS Project") + ("ms" "application/x-troff-ms" "Troff w/MS Macros") + ("msh" "model/mesh" "2 and 2-D visualization") + ("n2p" "application/n2p" " ") + ("nc" "application/x-netcdf" "Unidata netCDF data file") + ("npx" "application/x-netfpx" " ") + ("nsc" "application/x-nschat" "Noder file (Polish)") + ("nsf" "application/x-notes" "Lotus Notes ") + ("ntf" "application/x-notes" "Lotus Notes ") + ("ocx" "application/x-oleobject" + "Object Linking and Embedding (OLE) Control Extension (ActiveX Control)") + ("oda" "application/oda" "ODA/ODIF Open Document Architecture ") + ("ods" "application/vnd.oasis.opendocument.spreadsheet" + "Open Office Version 2 spreedsheet") + ("odt" "application/vnd.oasis.opendocument.text;" + "Open Office Version 2 writer") + ("odp" "application/vnd.oasis.opendocument.presentation" + "Open Office Version 2 presentor") + ("ofml" "application/fml" " ") + ("ogg" "audio/x-ogg" "Ogg Vorbis open-source audio format") + ("olb" "vms/olb" "Vax Object Library or MS Project Object Library") + ("or2" "application/x-organizer" "Lotus Organizer") + ("ovl" "application/octet-stream" "PC OVL File") + ("pac" "application/x-ns-proxy-autoconfig" " ") + ("page" "application/x-coda" " ") + ("pbd" "application/vnd.powerbuilder6" "Phone book (FaxNOW! - Faxit)") + ("pbm" "image/x-portable-bitmap" "PBM Bitmap Format") + ("pcd" "image/x-photo-cd" "Kodak Photo CD (raster)") + ("pcl" "application/pcl" " +Printer Control Language (HP)") + ("pcx" "image/pcx" "PC Paintbrush (ZSoft Image)") + ("pdb" "text/x-palm-pdb" "Palm Database File") + ("pdf" "application/pdf" "Portable Document Format (Adobe Acrobat)") + ("pfm" "application/pdf" "Acrobat Font") + ("pfr" "application/font-tdpfr" " ") + ("pgm" "image/x-portable-graymap" "PBM Graymap Format") + ("pgp" "application/pgp-encrypted" "PGP Encrypted file ") + ("pgr" "text/parsnegar-document" " ") + ("php3" "application/x-httpd-php3" " ") + ("phtml" "application/x-httpd-php" "PHP Script ") + ("pic" "image/pict" "Macintosh QuickDraw format (metafile)") + ("pict" "image/pict" "Macintosh QuickDraw format (metafile)") + ("pif" "application/x-mspif" "Program Information File (Windows)") + ("pkr" "application/pgp-keys" "Public Keyring (PGP)") + ("pnc" "text/x-palm-pnc" "Palm Network Configuration File") + ("png" "image/png" "Portable Network Graphics") + ("pnm" "image/x-portable-anymap" "PBM Anymap Format") + ("pot" "application/ms-powerpoint" "MS PowerPoint template") + ("ppa" "application/vnd.ms-powerpoint" "MS PowerPoint addin") + ("ppm" "image/x-portable-pixmap" "PBM Pixmap Format") + ("pps" "application/ms-powerpoint" "MS PowerPoint Slideshow") + ("ppt" "application/ms-powerpoint" "MS PowerPoint Presentation") + ("ppz" "applications/ms-powerpoint" "MS PowerPoint Animation") + ("pqa" "text/x-palm-pqa" "Palm Query Application") + ("pqf" "application/x-cprplayer" " ") + ("pqi" "application/cprplayer" "Power Quest Drive imaging") + ("prc" "text/x-palm-prc" "Palm Application") + ("prvkr" "application/pgp-keys" "Private Keyring (PGP)") + ("ps" "application/postscript" "PostScript") + ("psd" "image/x-photoshop" "Adobe PhotoShop Image") + ("psr" "application/datawindow" "Project Scheduler Resource file") + ("ptlk" "application/listenup" " ") + ("pub" "application/x-mspublisher" "MS publisher or PageMaker 2") + ("pubkr" "application/pgp-keys" "Public Keyring (PGP)") + ("push" "multipart/x-mixed-replace" " ") + ("qd3" "x-world/x-3dmf" "Data file - segment 3 (Omnis Quartz)") + ("qd3d" "x-world/x-3dmf" " ") + ("qrt" "application/quest" "Qrt ray tracing graphics") + ("qt" "video/quicktime" "QuickTime") + ("ra" "audio/x-realaudio" "Music (RealAudio)") + ("ram" "audio/x-pn-realaudio" "Real Audio Player") + ("ras" "image/x-cmu-raster" "Sun Raster Format (raster)") + ("rax" "audio/" "RealAudio 10 - RealMedia Streaming File") + ("rgb" "image/x-rgb" "RGB Color Image") + ("rip" "image/rip" "Graphics (Remote Access)") + ("rm" "audio/x-pn-realaudio" " ") + ("rmf" "audio/x-rmf" "Rich Music Format audio file from Beatnik") + ("rmi" "audio/mid" "MIDI File ") + ("roff" "application/x-troff" "Troff") + ("rpm" "audio/x-pn-realaudio-plugin" + "Real Audio Plugin and RedHat Package Manager") + ("rrf" "application/x-InstallFromTheWeb" " ") + ("rtc" "application/rtc" " ") + ("rtf" "application/rtf" "Rich Text Format (Microsoft)") + ("rtx" "text/richtext" "MIME Richtext format (see also rtf)") + ("rtsp" "application/x-rtsp" + "QuickTime Real-Time Streaming Protocol File ") + ("sb" "application/x-xsb" "Superbook") + ("sbx" "application/x-xsb" + "ArcView Spatial Index For Read-Write Shapefiles ") + ("sca" "application/x-supercard" "Datafile (SCA)") + ("scp" "text/x-palm-scp" "Palm Network Script File") + ("sdp" "application/sdp" "Scalable Multicast (RealNetworks)") + ("ser" "application/java-" " ") + ("sgm" "text/x-sgml" "Standard Generalized Markup Lang (SGML)") + ("sgml" "text/x-sgml" "Standard Generalized Markup Lang (SGML)") + ("sh" "application/x-sh" "SH Script") + ("shar" "application/x-shar" "Sh Shar") + ("shtml" "magnus-internal/parsed-html" " ") + ("shw" "application/presentations" + "Presentation (Harvard Graphics 2.0 - CorelShow)") + ("sig" "application/pgp-signature" "Detached signature file (PGP)") + ("silo" "model/mesh" " ") + ("sit" "application/x-stuffit" + "StuffIt - Macintosh Compression Format. By Aladdin for Mac.") + ("sitx" "application/x-stuffit" + "StuffIt X file format integrates compression with security and safety options. By Aladdin for Mac.") + ("skd" "application/x-koan" " ") + ("skm" "application/x-koan" " ") + ("skp" "application/x-koan" " ") + ("skr" "application/pgp-keys" "Private Keyring (PGP)") + ("skt" "application/x-koan" " ") + ("smil" "application/smil" + "SMIL Synchronized Multimedia Integration Language. App:RealPlayer") + ("sml" "application/smil" + "SMIL Synchronized Multimedia Integration Language") + ("smp" "application/studiom" "Sample (sound file)") + ("snd" "audio/basic" "8-bit u-law [PCM] / 8000 Hz Audio") + ("spc" "text/x-palm-spc" "Palm Configuration File") + ("spl" "application/futuresplash" "FutureSplash from FutureWave Sftwr") + ("spr" "application/x-sprite" "Document letter (Sprint)") + ("sprite" "application/x-sprite" " ") + ("src" "application/x-wais-source" "WAIS Source") + ("stk" "application/hstu" " ") + ("stream" "audio/x-qt-stream" " ") + ("sty" "application/msword" "MS Word Style sheet") + ("sv4cpio" "application/x-sv4cpio" "SVR4 CPIO") + ("sv4crc" "application/x-sv4crc" "SVR4 CPIO w/CRC") + ("svf" "image/vnd" " ") + ("svh" "image/svh" " ") + ("svr" "x-world/x-svr" " ") + ("swf" "application/x-shockwave-flash" + "Macromedia Flash Format File for animations") + ("sxc" "application/vnd.sun.xml.calc" + "Open Office Version 1 Spreedsheet") + ("sxi" "application/vnd.sun.xml.impress" + "Open Office Version 1 Presentations") + ("sxw" " application/vnd.sun.xml.writer" + "Open Office Version 1 Writer") + ("syl" "application/sylk" + "SYLK - Symbolic Link WingZ/Excel/Lotus (old MultiPlan form") + ("sys" "application/octet-stream" "PC System File") + ("talk" "application/talker" "Text to Speech ") + ("tar" "application/x-tar" "4.3BSD Tar ") + ("targa" "image/targa" "Targa Image File") + ("tbk" "application/toolbook" "Memo backup (dBASE IV - FoxPro)") + ("tcl" "application/x-tcl" "TCL Script") + ("tda" "text/x-palm-tda" "ToDo Archive (Palm)") + ("tex" "application/x-tex" "TeX Source") + ("texi" "application/x-texinfo" "Texinfo") + ("texinfo" "application/x-texinfo" "Texinfo") + ("tga" "image/targa" "Targa/Truevision Image File") + ("tgz" "application/x-gzip" "UNIX GTar Arvhive") + ("tif" "image/tiff" "TIFF - Tag Image File Format") + ("tiff" "image/tiff" "TIFF - Tagged Image File Format") + ("tlk" "application/x-tlk" " ") + ("tmv" "application/x-Parable-Thing" "Template (TextMaker)") + ("toc" "application/vnd.framemaker" "FrameMaker TOC") + ("tr" "application/x-troff" "Troff") + ("trm" "application/x-msterminal" "MS terminal") + ("tsi" "audio/tsplayer" " ") + ("tsp" "application/dsptype" "Windows Telephony Service Provider") + ("tsv" "text/tab-separated-values" "Tab Separated Values") + ("txt" "text/plain" "Plain Text") + ("uin" "application/x-icq" "ICQ 2001+ Saved ICQ Contact Information ") + ("url" "application/x-url" + "wwwserver/redirection application/internet-shortcut " + "Uniform resource Locator (Internet Address)") + ("ustar" "application/x-ustar" "IEEE Std1003.2 (``POSIX'') Tar") + ("v5d" "application/vis5d" "5-D data set visualization") + ("vbd" "application/activexdocument" "ActiveX file") + ("vcs" "text/x-vcalendar" + "Personal Data Interchange (PDI) Calendar entry - Outlook") + ("vcd" "application/x-cdlink" "VirtualDrive CD Image File ") + ("vcf" "text/x-vcard" "vCard (Business Card)") + ("vdo" "video/vdo" "VDOLive Script Video image (Story Board)") + ("vgm" "video/x-videogram" " ") + ("vgp" "video/x-videogram-plugin" " ") + ("vgx" "video/x-videogram" " ") + ("viv" "video/vnd.vivo" "VivoActive Player Video file") + ("vivo" "video/vnd.vivo" " ") + ("vmd" "application/vocaltec-media-desc" " ") + ("vmf" "application/vocaltec-media-file" + "Font characteristics (Ventura Publisher)") + ("vob" "video/dvd" "DVD Video Movie File") + ("vox" "audio/voxware" "Vox Audio") + ("vqe" "audio/x-twinvq-plugin" "Yamaha Sound-VQ Locator file") + ("vqf" "audio/x-twinvq" "Yamaha Sound-VQ file") + ("vql" "audio/x-twinvq" "Yamaha Sound-VQ Locator file") + ("vrml" "model/vrml" " ") + ("vrt" "x-world/x-vrt" " ") + ("vts" "workbook/formulaone" + "Forumle One - A Java Spread sheet and report generator from ") + ("waf" "plugin/wanimate" + "Mayim's WAF Compiler file for interactive 3D with Walkabout browser plug-in") + ("wan" "plugin/wanimate" " ") + ("wav" "audio/x-wav" "Windows Audio File WAVE format") + ("wax" "audio/x-ms-wax" "Windows Media Audio Redirector to WMA file.") + ("wbmp" "image/vnd.wap.wbmp" + "Wireless Bitmap File Format - Mobil phones") + ("wi" "image/wavelet" " ") + ("wid" "application/x-DemoShield" "Width table (Ventura Publisher)") + ("wis" "application/x-InstallShield" " ") + ("wks" "application/x-msworks" "MS Works or Lotus 1-2-3 Worksheets") + ("wlt" "application/x-mswallet" "eWallet file") + ("wm" "video/x-ms-wm" " ") + ("wma" "audio/x-ms-wma" "Windows Media Audio. Stored in ASF.") + ("wmf" "image/x-wmf" "Windows MetaFile vector graphics") + ("wml" "text/vnd.wap.wml" "Wireless Markup Language File") + ("wmv" "video/x-ms-wmv" "Windows Media Video (Stored in ASF format)") + ("wp" "application/wordperfect" "WordPerfect") + ("wpc" "application/wpc" + "Text-format converters used 1990-1997 by MS Word and Write") + ("wpc" "application/pcms_wp" "WordPerfect Character Mapping File ") + ("wpd," "application/wordperfect5.1" "Document (WordPerfect)") + ("wps" "application/vnd.ms-works" "MS Works ") + ("wri" "application/x-mswrite" "Write format (MS Windows)") + ("wrl" "model/vrml" "Plain Text VRML File ") + ("wrz" "x-world/x-vrml" " ") + ("wtx" "audio/x-wtx" " ") + ("wvx" "video/x-ms-wvx" " ") + ("xbm" "image/x-xbitmap" "X Bitmaps") + ("xdr" "video/x-videogram" " ") + ("xla" "application/vnd.ms-excel" "MS Excel (Add in)") + ("xlc" "application/vnd.ms-excel" "MS Excel (Chart)") + ("xlm" "application/vnd.ms-excel" "MS Excel") + ("xls" "application/vnd.ms-excel" "MS Excel") + ("xlt" "application/vnd.ms-excel" "MS Excel (template)") + ("xlw" "application/vnd.ms-excel" "MS Excel (workbook)") + ("xml" "text/xml" "Extensible Markup Language") + ("xpm" "image/x-xpixmap" "X Pixmap format") + ("xsb" "application/x-xsb" "Superbook") + ("xwd" "image/x-xwindowdump" "X Window Dump (xwd)") + ("xyz" "chemical/x-pdb" "ASCII RPG Maker Graphic Format") + ("zip" "application/zip" + "Compressed file archive created by PKZIP (pkz204g.exe)") + ("zpa" "application/pcphoto" " "))) + + (defvar *mime-types* (make-hash-table + :test #'equal + :size (length *mime-type-descriptions*))) + + ;;--- Initialize File extension/Mime Type hash table + (dolist (type-lst *mime-type-descriptions*) + (setf (gethash (first type-lst) *mime-types*) (second type-lst)))) + +(defun lookup-mime-type (file-name + &optional (default "application/octet-stream")) + "Extract mime type based on file-extension" + (let ((pos-ext (position #\. file-name :test #'char= :from-end t))) + (when (and pos-ext + (< (1+ pos-ext) (length file-name))) + (or (gethash (subseq file-name (1+ pos-ext)) *mime-types*) + default)))) Added: branches/trunk-reorg/thirdparty/cl-smtp/style.css ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/cl-smtp/style.css Tue Jan 29 07:06:27 2008 @@ -0,0 +1,62 @@ + +.header { + font-size: medium; + background-color:#336699; + color:#ffffff; + border-style:solid; + border-width: 5px; + border-color:#002244; + padding: 1mm 1mm 1mm 5mm; +} + +.footer { + font-size: small; + font-style: italic; + text-align: right; + background-color:#336699; + color:#ffffff; + border-style:solid; + border-width: 2px; + border-color:#002244; + padding: 1mm 1mm 1mm 1mm; +} + +.footer a:link { + font-weight:bold; + color:#ffffff; + text-decoration:underline; +} + +.footer a:visited { + font-weight:bold; + color:#ffffff; + text-decoration:underline; +} + +.footer a:hover { + font-weight:bold; + color:#002244; + text-decoration:underline; } + +.check {font-size: x-small; + text-align:right;} + +.check a:link { font-weight:bold; + color:#a0a0ff; + text-decoration:underline; } + +.check a:visited { font-weight:bold; + color:#a0a0ff; + text-decoration:underline; } + +.check a:hover { font-weight:bold; + color:#000000; + text-decoration:underline; } + +th { background-color: #8b0000; + color: white; + text-align: left; } + +.working { background-color: #90ee90; } + +.broken { background-color: #c5c5c5; } \ No newline at end of file Modified: branches/trunk-reorg/thirdparty/parenscript/src/parser.lisp ============================================================================== --- branches/trunk-reorg/thirdparty/parenscript/src/parser.lisp (original) +++ branches/trunk-reorg/thirdparty/parenscript/src/parser.lisp Tue Jan 29 07:06:27 2008 @@ -19,6 +19,7 @@ (lambda (&rest ,arglist) (destructuring-bind ,lambda-list ,arglist + (declare (ignorable ,(car lambda-list))) ,@body))))) (defun get-ps-special-form (name) Added: branches/trunk-reorg/thirdparty/split-sequence/README.cCLan-install ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/split-sequence/README.cCLan-install Tue Jan 29 07:06:27 2008 @@ -0,0 +1,13 @@ +1. Make a symlink in "~/lisp-systems/"[*] pointing to the .asd file +2. Start your asdf-enabled lisp +2a. Ensure that "~/lisp-systems/"[*] is in asdf:*central-registry* +3. At the lisp prompt, type '(asdf:oos 'asdf:load-op "split-sequence")'. This + will compile and load the system into your running lisp. + +[*] This path ("~/lisp-systems/") is only a suggestion; the important +thing is that asdf know where to find the .asd file. Adsf uses the +contents of the variable ASDF:*CENTRAL-REGISTRY* to find its system +definitions. + +These instructions were automatically generated by cCLan software. Use +at your own peril. Added: branches/trunk-reorg/thirdparty/split-sequence/split-sequence.asd ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/split-sequence/split-sequence.asd Tue Jan 29 07:06:27 2008 @@ -0,0 +1,7 @@ +;;; -*- Lisp -*- mode +(defpackage #:split-sequence-system (:use #:cl #:asdf)) +(in-package :split-sequence-system) + +(defsystem :split-sequence + :version "20011114.1" + :components ((:file "split-sequence"))) Added: branches/trunk-reorg/thirdparty/split-sequence/split-sequence.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/split-sequence/split-sequence.lisp Tue Jan 29 07:06:27 2008 @@ -0,0 +1,243 @@ +;;;; SPLIT-SEQUENCE +;;; +;;; This code was based on Arthur Lemmens' in +;;; <URL:http://groups.google.com/groups?as_umsgid=39F36F1A.B8F19D20%40simplex.nl>; +;;; +;;; changes include: +;;; +;;; * altering the behaviour of the :from-end keyword argument to +;;; return the subsequences in original order, for consistency with +;;; CL:REMOVE, CL:SUBSTITUTE et al. (:from-end being non-NIL only +;;; affects the answer if :count is less than the number of +;;; subsequences, by analogy with the above-referenced functions). +;;; +;;; * changing the :maximum keyword argument to :count, by analogy +;;; with CL:REMOVE, CL:SUBSTITUTE, and so on. +;;; +;;; * naming the function SPLIT-SEQUENCE rather than PARTITION rather +;;; than SPLIT. +;;; +;;; * adding SPLIT-SEQUENCE-IF and SPLIT-SEQUENCE-IF-NOT. +;;; +;;; * The second return value is now an index rather than a copy of a +;;; portion of the sequence; this index is the `right' one to feed to +;;; CL:SUBSEQ for continued processing. + +;;; There's a certain amount of code duplication here, which is kept +;;; to illustrate the relationship between the SPLIT-SEQUENCE +;;; functions and the CL:POSITION functions. + +;;; Examples: +;;; +;;; * (split-sequence #\; "a;;b;c") +;;; -> ("a" "" "b" "c"), 6 +;;; +;;; * (split-sequence #\; "a;;b;c" :from-end t) +;;; -> ("a" "" "b" "c"), 0 +;;; +;;; * (split-sequence #\; "a;;b;c" :from-end t :count 1) +;;; -> ("c"), 4 +;;; +;;; * (split-sequence #\; "a;;b;c" :remove-empty-subseqs t) +;;; -> ("a" "b" "c"), 6 +;;; +;;; * (split-sequence-if (lambda (x) (member x '(#\a #\b))) "abracadabra") +;;; -> ("" "" "r" "c" "d" "" "r" ""), 11 +;;; +;;; * (split-sequence-if-not (lambda (x) (member x '(#\a #\b))) "abracadabra") +;;; -> ("ab" "a" "a" "ab" "a"), 11 +;;; +;;; * (split-sequence #\; ";oo;bar;ba;" :start 1 :end 9) +;;; -> ("oo" "bar" "b"), 9 + +(defpackage "SPLIT-SEQUENCE" + (:use "CL") + (:nicknames "PARTITION") + (:export "SPLIT-SEQUENCE" "SPLIT-SEQUENCE-IF" "SPLIT-SEQUENCE-IF-NOT" + "PARTITION" "PARTITION-IF" "PARTITION-IF-NOT")) + +(in-package "SPLIT-SEQUENCE") + +(defun split-sequence (delimiter seq &key (count nil) (remove-empty-subseqs nil) (from-end nil) (start 0) (end nil) (test nil test-supplied) (test-not nil test-not-supplied) (key nil key-supplied)) + "Return a list of subsequences in seq delimited by delimiter. + +If :remove-empty-subseqs is NIL, empty subsequences will be included +in the result; otherwise they will be discarded. All other keywords +work analogously to those for CL:SUBSTITUTE. In particular, the +behaviour of :from-end is possibly different from other versions of +this function; :from-end values of NIL and T are equivalent unless +:count is supplied. The second return value is an index suitable as an +argument to CL:SUBSEQ into the sequence indicating where processing +stopped." + (let ((len (length seq)) + (other-keys (nconc (when test-supplied + (list :test test)) + (when test-not-supplied + (list :test-not test-not)) + (when key-supplied + (list :key key))))) + (unless end (setq end len)) + (if from-end + (loop for right = end then left + for left = (max (or (apply #'position delimiter seq + :end right + :from-end t + other-keys) + -1) + (1- start)) + unless (and (= right (1+ left)) + remove-empty-subseqs) ; empty subseq we don't want + if (and count (>= nr-elts count)) + ;; We can't take any more. Return now. + return (values (nreverse subseqs) right) + else + collect (subseq seq (1+ left) right) into subseqs + and sum 1 into nr-elts + until (< left start) + finally (return (values (nreverse subseqs) (1+ left)))) + (loop for left = start then (+ right 1) + for right = (min (or (apply #'position delimiter seq + :start left + other-keys) + len) + end) + unless (and (= right left) + remove-empty-subseqs) ; empty subseq we don't want + if (and count (>= nr-elts count)) + ;; We can't take any more. Return now. + return (values subseqs left) + else + collect (subseq seq left right) into subseqs + and sum 1 into nr-elts + until (>= right end) + finally (return (values subseqs right)))))) + +(defun split-sequence-if (predicate seq &key (count nil) (remove-empty-subseqs nil) (from-end nil) (start 0) (end nil) (key nil key-supplied)) + "Return a list of subsequences in seq delimited by items satisfying +predicate. + +If :remove-empty-subseqs is NIL, empty subsequences will be included +in the result; otherwise they will be discarded. All other keywords +work analogously to those for CL:SUBSTITUTE-IF. In particular, the +behaviour of :from-end is possibly different from other versions of +this function; :from-end values of NIL and T are equivalent unless +:count is supplied. The second return value is an index suitable as an +argument to CL:SUBSEQ into the sequence indicating where processing +stopped." + (let ((len (length seq)) + (other-keys (when key-supplied + (list :key key)))) + (unless end (setq end len)) + (if from-end + (loop for right = end then left + for left = (max (or (apply #'position-if predicate seq + :end right + :from-end t + other-keys) + -1) + (1- start)) + unless (and (= right (1+ left)) + remove-empty-subseqs) ; empty subseq we don't want + if (and count (>= nr-elts count)) + ;; We can't take any more. Return now. + return (values (nreverse subseqs) right) + else + collect (subseq seq (1+ left) right) into subseqs + and sum 1 into nr-elts + until (< left start) + finally (return (values (nreverse subseqs) (1+ left)))) + (loop for left = start then (+ right 1) + for right = (min (or (apply #'position-if predicate seq + :start left + other-keys) + len) + end) + unless (and (= right left) + remove-empty-subseqs) ; empty subseq we don't want + if (and count (>= nr-elts count)) + ;; We can't take any more. Return now. + return (values subseqs left) + else + collect (subseq seq left right) into subseqs + and sum 1 into nr-elts + until (>= right end) + finally (return (values subseqs right)))))) + +(defun split-sequence-if-not (predicate seq &key (count nil) (remove-empty-subseqs nil) (from-end nil) (start 0) (end nil) (key nil key-supplied)) + "Return a list of subsequences in seq delimited by items satisfying +(CL:COMPLEMENT predicate). + +If :remove-empty-subseqs is NIL, empty subsequences will be included +in the result; otherwise they will be discarded. All other keywords +work analogously to those for CL:SUBSTITUTE-IF-NOT. In particular, +the behaviour of :from-end is possibly different from other versions +of this function; :from-end values of NIL and T are equivalent unless +:count is supplied. The second return value is an index suitable as an +argument to CL:SUBSEQ into the sequence indicating where processing +stopped." + (let ((len (length seq)) + (other-keys (when key-supplied + (list :key key)))) + (unless end (setq end len)) + (if from-end + (loop for right = end then left + for left = (max (or (apply #'position-if-not predicate seq + :end right + :from-end t + other-keys) + -1) + (1- start)) + unless (and (= right (1+ left)) + remove-empty-subseqs) ; empty subseq we don't want + if (and count (>= nr-elts count)) + ;; We can't take any more. Return now. + return (values (nreverse subseqs) right) + else + collect (subseq seq (1+ left) right) into subseqs + and sum 1 into nr-elts + until (< left start) + finally (return (values (nreverse subseqs) (1+ left)))) + (loop for left = start then (+ right 1) + for right = (min (or (apply #'position-if-not predicate seq + :start left + other-keys) + len) + end) + unless (and (= right left) + remove-empty-subseqs) ; empty subseq we don't want + if (and count (>= nr-elts count)) + ;; We can't take any more. Return now. + return (values subseqs left) + else + collect (subseq seq left right) into subseqs + and sum 1 into nr-elts + until (>= right end) + finally (return (values subseqs right)))))) + +;;; clean deprecation + +(defun partition (&rest args) + (apply #'split-sequence args)) + +(defun partition-if (&rest args) + (apply #'split-sequence-if args)) + +(defun partition-if-not (&rest args) + (apply #'split-sequence-if-not args)) + +(define-compiler-macro partition (&whole form &rest args) + (declare (ignore args)) + (warn "PARTITION is deprecated; use SPLIT-SEQUENCE instead.") + form) + +(define-compiler-macro partition-if (&whole form &rest args) + (declare (ignore args)) + (warn "PARTITION-IF is deprecated; use SPLIT-SEQUENCE-IF instead.") + form) + +(define-compiler-macro partition-if-not (&whole form &rest args) + (declare (ignore args)) + (warn "PARTITION-IF-NOT is deprecated; use SPLIT-SEQUENCE-IF-NOT instead") + form) + +(pushnew :split-sequence *features*) Added: branches/trunk-reorg/thirdparty/usocket-0.3.5/LICENSE ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/usocket-0.3.5/LICENSE Tue Jan 29 07:06:27 2008 @@ -0,0 +1,23 @@ +(This is the MIT / X Consortium license as taken from + http://www.opensource.org/licenses/mit-license.html) + +Copyright (c) 2003 Erik Enge + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. Added: branches/trunk-reorg/thirdparty/usocket-0.3.5/Makefile ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/usocket-0.3.5/Makefile Tue Jan 29 07:06:27 2008 @@ -0,0 +1,9 @@ +# $Id: Makefile 80 2006-02-12 10:09:49Z ehuelsmann $ +# $URL: svn+ssh://ehuelsmann@common-lisp.net/project/usocket/svn/usocket/tags/0.3.5/Makefile $ + +clean: + find -name -o -name "*~" -o -name "*.err" -o -name "*.x86f" -o -name "*.lib" -o -name "*.fas" -o -name "*.fasl" -o -name "*.faslmt" -o -name "*.ufsl" -o -name "*.abcl" | xargs rm + +commit: + make clean; svn up; svn ci + Added: branches/trunk-reorg/thirdparty/usocket-0.3.5/README ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/usocket-0.3.5/README Tue Jan 29 07:06:27 2008 @@ -0,0 +1,136 @@ + -*- text -*- + +$Id: README 189 2007-01-20 12:57:27Z ehuelsmann $ + +Content +======= + + * Introduction + * Non-support for :external-format + * API definition + * Known problems + +Introduction +============ +This is the usocket Common Lisp sockets library: a library to bring +sockets access to the broadest of common lisp implementations as possible. + + +The library currently supports: + + - SBCL + - CMUCL + - ArmedBear (post feb 11th, 2006 versions) + - clisp + - Allegro Common Lisp + - LispWorks + - OpenMCL + - ECL + - Scieneer Common Lisp + - <Your favorite Common Lisp here?> + +If your favorite common lisp misses in the list above, please contact +usocket-devel@common-lisp.net and submit a request. Please include +references to available sockets functions in your lisp implementation. + +The library has been ASDF (http://cliki.net/ASDF) enabled, meaning +that you can tar up a checkout and use that to ASDF-INSTALL:INSTALL +the package in your system package site. (Or use your usual ASDF +tricks to use the checkout directly.) + + +Non-support of :external-format +=============================== + +Because of its definition in the hyperspec, there's no common +external-format between lisp implementations: every vendor has chosen +a different way to solve the problem of newline translation or +character set recoding. + +Because there's no way to avoid platform specific code in the application +when using external-format, the purpose of a portability layer gets +defeated. So, for now, usocket doesn't support external-format. + +The workaround to get reasonably portable external-format support is to +layer a flexi-stream (from flexi-streams) on top of a usocket stream. + + +API definition +============== + + - usocket (class) + - stream-usocket (class; usocket derivative) + - stream-server-usocket (class; usocket derivative) + - socket-connect (function) [ to create an active/connected socket ] + socket-connect host port &key element-type + where `host' is a vectorized ip + or a string representation of a dotted ip address + or a hostname for lookup in the DNS system + - socket-listen (function) [ to create a passive/listening socket ] + socket-listen host port &key reuseaddress backlog element-type + where `host' has the same definition as above + - socket-accept (method) [ to create an active/connected socket ] + socket-accept socket &key element-type + returns (server side) a connected socket derived from a + listening/passive socket. + - socket-close (method) + socket-close socket + where socket a previously returned socket + - socket (usocket slot accessor), + the internal/implementation defined socket representation + - socket-stream (usocket slot accessor), + socket-stream socket + the return value of which satisfies the normal stream interface + + + + +Errors: + - address-in-use-error + - address-not-available-error + - bad-file-descriptor-error + - connection-refused-error + - connection-aborted-error + - connection-reset-error + - invalid-argument-error + - no-buffers-error + - operation-not-supported-error + - operation-not-permitted-error + - protocol-not-supported-error + - socket-type-not-supported-error + - network-unreachable-error + - network-down-error + - network-reset-error + - host-down-error + - host-unreachable-error + - shutdown-error + - timeout-error + - unkown-error + +Non-fatal conditions: + - interrupted-condition + - unkown-condition + + + + +Known problems +============== +- CMUCL error reporting wrt sockets raises only simple-errors + meaning there's no way to tell different error conditions apart. + All errors are mapped to unknown-error on CMUCL. + +- When running the test suite through the run-usocket-tests.sh shell + script, ArmedBear 0.0.9 will report failure - even when it didn't. + You need a CVS version later than 2006-02-11, or later than 0.0.9 + release version for the script to work correctly. + +- The ArmedBear backend doesn't do any error mapping (yet). Java + defines exceptions at the wrong level (IMO), since the exception + reported bares a relation to the function failing, not the actual + error that occurred: for example 'Address already in use' (when + creating a passive socket) is reported as a BindException with + an error text of 'Address already in use'. There's no way to sanely + map 'BindException' to a meaningfull error in usocket. [This does not + mean the backend should not at least map to 'unknown-error'!] + Added: branches/trunk-reorg/thirdparty/usocket-0.3.5/TODO ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/usocket-0.3.5/TODO Tue Jan 29 07:06:27 2008 @@ -0,0 +1,8 @@ + +- Extend ABCL socket support with the 4 java errors in java.net.* + so that they can map to our usocket errors instead of mapping + all errors to unknown-error. + +- Add INET6 support. + +For more TODO items, see http://trac.common-lisp.net/usocket/report. Added: branches/trunk-reorg/thirdparty/usocket-0.3.5/backend/allegro.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/usocket-0.3.5/backend/allegro.lisp Tue Jan 29 07:06:27 2008 @@ -0,0 +1,125 @@ +;;;; $Id: allegro.lisp 294 2007-09-17 19:50:34Z ehuelsmann $ +;;;; $URL: svn+ssh://ehuelsmann@common-lisp.net/project/usocket/svn/usocket/tags/0.3.5/backend/allegro.lisp $ + +;;;; See LICENSE for licensing information. + +(in-package :usocket) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require :sock) + ;; note: the line below requires ACL 6.2+ + (require :osi)) + +(defun get-host-name () + ;; note: the line below requires ACL 7.0+ to actually *work* on windows + (excl.osi:gethostname)) + +(defparameter +allegro-identifier-error-map+ + '((:address-in-use . address-in-use-error) + (:address-not-available . address-not-available-error) + (:network-down . network-down-error) + (:network-reset . network-reset-error) + (:network-unreachable . network-unreachable-error) + (:connection-aborted . connection-aborted-error) + (:connection-reset . connection-reset-error) + (:no-buffer-space . no-buffers-error) + (:shutdown . shutdown-error) + (:connection-timed-out . timeout-error) + (:connection-refused . connection-refused-error) + (:host-down . host-down-error) + (:host-unreachable . host-unreachable-error))) + +(defun handle-condition (condition &optional (socket nil)) + "Dispatch correct usocket condition." + (typecase condition + (excl:socket-error + (let ((usock-err + (cdr (assoc (excl:stream-error-identifier condition) + +allegro-identifier-error-map+)))) + (if usock-err + (error usock-err :socket socket) + (error 'unknown-error + :real-error condition + :socket socket)))))) + +(defun to-format (element-type) + (if (subtypep element-type 'character) + :text + :binary)) + +(defun socket-connect (host port &key (element-type 'character)) + (let ((socket)) + (setf socket + (with-mapped-conditions (socket) + (socket:make-socket :remote-host (host-to-hostname host) + :remote-port port + :format (to-format element-type)))) + (make-stream-socket :socket socket :stream socket))) + + +;; One socket close method is sufficient, +;; because socket-streams are also sockets. +(defmethod socket-close ((usocket usocket)) + "Close socket." + (with-mapped-conditions (usocket) + (close (socket usocket)))) + +(defun socket-listen (host port + &key reuseaddress + (reuse-address nil reuse-address-supplied-p) + (backlog 5) + (element-type 'character)) + ;; Allegro and OpenMCL socket interfaces bear very strong resemblence + ;; whatever you change here, change it also for OpenMCL + (let* ((reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress)) + (sock (with-mapped-conditions () + (apply #'socket:make-socket + (append (list :connect :passive + :reuse-address reuseaddress + :local-port port + :backlog backlog + :format (to-format element-type) + ;; allegro now ignores :format + ) + (when (ip/= host *wildcard-host*) + (list :local-host host))))))) + (make-stream-server-socket sock :element-type element-type))) + +(defmethod socket-accept ((socket stream-server-usocket) &key element-type) + (declare (ignore element-type)) ;; allegro streams are multivalent + (let ((stream-sock (with-mapped-conditions () + (socket:accept-connection (socket socket))))) + (make-stream-socket :socket stream-sock :stream stream-sock))) + +(defmethod get-local-address ((usocket usocket)) + (hbo-to-vector-quad (socket:local-host (socket usocket)))) + +(defmethod get-peer-address ((usocket stream-usocket)) + (hbo-to-vector-quad (socket:remote-host (socket usocket)))) + +(defmethod get-local-port ((usocket usocket)) + (socket:local-port (socket usocket))) + +(defmethod get-peer-port ((usocket stream-usocket)) + (socket:remote-port (socket usocket))) + +(defmethod get-local-name ((usocket usocket)) + (values (get-local-address usocket) + (get-local-port usocket))) + +(defmethod get-peer-name ((usocket stream-usocket)) + (values (get-peer-address usocket) + (get-peer-port usocket))) + + +(defun get-host-by-address (address) + (with-mapped-conditions () + (socket:ipaddr-to-hostname (host-to-hbo address)))) + +(defun get-hosts-by-name (name) + ;;###FIXME: ACL has the acldns module which returns all A records + ;; only problem: it doesn't fall back to tcp (from udp) if the returned + ;; structure is too long. + (with-mapped-conditions () + (list (hbo-to-vector-quad (socket:lookup-hostname + (host-to-hostname name)))))) Added: branches/trunk-reorg/thirdparty/usocket-0.3.5/backend/armedbear.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/usocket-0.3.5/backend/armedbear.lisp Tue Jan 29 07:06:27 2008 @@ -0,0 +1,107 @@ +;;;; $Id: armedbear.lisp 295 2007-09-17 19:53:12Z ehuelsmann $ +;;;; $URL: svn+ssh://ehuelsmann@common-lisp.net/project/usocket/svn/usocket/tags/0.3.5/backend/armedbear.lisp $ + +;;;; See LICENSE for licensing information. + +(in-package :usocket) + + +(defmacro jmethod-call (instance (method &rest arg-spec) &rest args) + (let ((isym (gensym))) + `(let* ((,isym ,instance) + (class-name (java:jclass-name (java:jclass-of ,isym)))) + (java:jcall (java:jmethod class-name ,method ,@arg-spec) + ,isym ,@args)))) + +(defmacro jnew-call ((class &rest arg-spec) &rest args) + `(java:jnew (java:jconstructor ,class ,@arg-spec) + ,@args)) + +(defun get-host-name () + (let ((localAddress (java:jstatic + (java:jmethod "java.net.InetAddress" + "getLocalHost") + (java:jclass "java.net.InetAddress")))) + (java:jcall (java:jmethod "java.net.InetAddress" "getHostName") + localAddress))) + +(defun handle-condition (condition &optional socket) + (typecase condition + (error (error 'unknown-error :socket socket :real-error condition)))) + +(defun socket-connect (host port &key (element-type 'character)) + (let ((usock)) + (with-mapped-conditions (usock) + (let ((sock (ext:make-socket (host-to-hostname host) port))) + (setf usock + (make-stream-socket + :socket sock + :stream (ext:get-socket-stream sock + :element-type element-type))))))) + +(defun socket-listen (host port + &key reuseaddress + (reuse-address nil reuse-address-supplied-p) + (backlog 5) + (element-type 'character)) + (let* ((reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress)) + (sock-addr (jnew-call ("java.net.InetSocketAddress" + "java.lang.String" "int") + (host-to-hostname host) port)) + (sock (jnew-call ("java.net.ServerSocket")))) + (when reuseaddress + (with-mapped-conditions () + (jmethod-call sock + ("setReuseAddress" "boolean") + (java:make-immediate-object reuseaddress :boolean)))) + (with-mapped-conditions () + (jmethod-call sock + ("bind" "java.net.SocketAddress" "int") + sock-addr backlog)) + (make-stream-server-socket sock :element-type element-type))) + +(defmethod socket-accept ((socket stream-server-usocket) &key element-type) + (let* ((jsock (socket socket)) + (jacc-sock (with-mapped-conditions (socket) + (jmethod-call jsock ("accept")))) + (jacc-stream + (ext:get-socket-stream jacc-sock + :element-type (or element-type + (element-type socket))))) + (make-stream-socket :socket jacc-sock + :stream jacc-stream))) + +;;(defun print-java-exception (e) +;; (let* ((native-exception (java-exception-cause e))) +;; (print (jcall (jmethod "java.net.BindException" "getMessage") native-exception)))) + +(defmethod socket-close ((usocket usocket)) + (with-mapped-conditions (usocket) + (ext:socket-close (socket usocket)))) + +;; Socket streams are different objects than +;; socket streams. Closing the stream flushes +;; its buffers *and* closes the socket. +(defmethod socket-close ((usocket stream-usocket)) + (with-mapped-conditions (usocket) + (close (socket-stream usocket)))) + +(defmethod get-local-address ((usocket usocket)) + (dotted-quad-to-vector-quad (ext:socket-local-address (socket usocket)))) + +(defmethod get-peer-address ((usocket stream-usocket)) + (dotted-quad-to-vector-quad (ext:socket-peer-address (socket usocket)))) + +(defmethod get-local-port ((usocket usocket)) + (ext:socket-local-port (socket usocket))) + +(defmethod get-peer-port ((usocket stream-usocket)) + (ext:socket-peer-port (socket usocket))) + +(defmethod get-local-name ((usocket usocket)) + (values (get-local-address usocket) + (get-local-port usocket))) + +(defmethod get-peer-name ((usocket stream-usocket)) + (values (get-peer-address usocket) + (get-peer-port usocket))) Added: branches/trunk-reorg/thirdparty/usocket-0.3.5/backend/clisp.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/usocket-0.3.5/backend/clisp.lisp Tue Jan 29 07:06:27 2008 @@ -0,0 +1,130 @@ +;;;; $Id: clisp.lisp 296 2007-09-17 20:14:43Z ehuelsmann $ +;;;; $URL: svn+ssh://ehuelsmann@common-lisp.net/project/usocket/svn/usocket/tags/0.3.5/backend/clisp.lisp $ + +;;;; See LICENSE for licensing information. + +(in-package :usocket) + + +;; utility routine for looking up the current host name +(FFI:DEF-CALL-OUT get-host-name-internal + (:name "gethostname") + (:arguments (name (FFI:C-PTR (FFI:C-ARRAY-MAX ffi:character 256)) + :OUT :ALLOCA) + (len ffi:int)) + #+win32 (:library "WS2_32") + (:language #-win32 :stdc + #+win32 :stdc-stdcall) + (:return-type ffi:int)) + + +(defun get-host-name () + (multiple-value-bind (retcode name) + (get-host-name-internal 256) + (when (= retcode 0) + name))) + + +#+win32 +(defun remap-maybe-for-win32 (z) + (mapcar #'(lambda (x) + (cons (mapcar #'(lambda (y) + (+ 10000 y)) + (car x)) + (cdr x))) + z)) + +(defparameter +clisp-error-map+ + #+win32 + (append (remap-maybe-for-win32 +unix-errno-condition-map+) + (remap-maybe-for-win32 +unix-errno-error-map+)) + #-win32 + (append +unix-errno-condition-map+ + +unix-errno-error-map+)) + +(defun handle-condition (condition &optional (socket nil)) + "Dispatch correct usocket condition." + (typecase condition + (system::simple-os-error + (let ((usock-err + (cdr (assoc (car (simple-condition-format-arguments condition)) + +clisp-error-map+ :test #'member)))) + (if usock-err + (if (subtypep usock-err 'error) + (error usock-err :socket socket) + (signal usock-err :socket socket)) + (error 'unknown-error + :socket socket + :real-error condition)))))) + +(defun socket-connect (host port &key (element-type 'character)) + (let ((socket) + (hostname (host-to-hostname host))) + (with-mapped-conditions (socket) + (setf socket + (socket:socket-connect port hostname + :element-type element-type + :buffered t))) + (make-stream-socket :socket socket + :stream socket))) ;; the socket is a stream too + +(defun socket-listen (host port + &key reuseaddress + (reuse-address nil reuse-address-supplied-p) + (backlog 5) + (element-type 'character)) + ;; clisp 2.39 sets SO_REUSEADDRESS to 1 by default; no need to + ;; to explicitly turn it on; unfortunately, there's no way to turn it off... + (declare (ignore reuseaddress reuse-address reuse-address-supplied-p)) + (let ((sock (with-mapped-conditions () + (apply #'socket:socket-server + (append (list port + :backlog backlog) + (when (ip/= host *wildcard-host*) + (list :interface host))))))) + (make-stream-server-socket sock :element-type element-type))) + +(defmethod socket-accept ((socket stream-server-usocket) &key element-type) + (let ((stream + (with-mapped-conditions (socket) + (socket:socket-accept (socket socket) + :element-type (or element-type + (element-type socket)))))) + (make-stream-socket :socket stream + :stream stream))) + +;; Only one close method required: +;; sockets and their associated streams +;; are the same object +(defmethod socket-close ((usocket usocket)) + "Close socket." + (with-mapped-conditions (usocket) + (close (socket usocket)))) + +(defmethod socket-close ((usocket stream-server-usocket)) + (socket:socket-server-close (socket usocket))) + +(defmethod get-local-name ((usocket usocket)) + (multiple-value-bind + (address port) + (socket:socket-stream-local (socket usocket) t) + (values (dotted-quad-to-vector-quad address) port))) + +(defmethod get-peer-name ((usocket stream-usocket)) + (multiple-value-bind + (address port) + (socket:socket-stream-peer (socket usocket) t) + (values (dotted-quad-to-vector-quad address) port))) + +(defmethod get-local-address ((usocket usocket)) + (nth-value 0 (get-local-name usocket))) + +(defmethod get-peer-address ((usocket stream-usocket)) + (nth-value 0 (get-peer-name usocket))) + +(defmethod get-local-port ((usocket usocket)) + (nth-value 1 (get-local-name usocket))) + +(defmethod get-peer-port ((usocket stream-usocket)) + (nth-value 1 (get-peer-name usocket))) + Added: branches/trunk-reorg/thirdparty/usocket-0.3.5/backend/cmucl.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/usocket-0.3.5/backend/cmucl.lisp Tue Jan 29 07:06:27 2008 @@ -0,0 +1,167 @@ +;;;; $Id: cmucl.lisp 294 2007-09-17 19:50:34Z ehuelsmann $ +;;;; $URL: svn+ssh://ehuelsmann@common-lisp.net/project/usocket/svn/usocket/tags/0.3.5/backend/cmucl.lisp $ + +;;;; See LICENSE for licensing information. + +(in-package :usocket) + +#+win32 +(defun remap-for-win32 (z) + (mapcar #'(lambda (x) + (cons (mapcar #'(lambda (y) + (+ 10000 y)) + (car x)) + (cdr x))) + z)) + +(defparameter +cmucl-error-map+ + #+win32 + (append (remap-for-win32 +unix-errno-condition-map+) + (remap-for-win32 +unix-errno-error-map+)) + #-win32 + (append +unix-errno-condition-map+ + +unix-errno-error-map+)) + +(defun cmucl-map-socket-error (err &key condition socket) + (let ((usock-err + (cdr (assoc err +cmucl-error-map+ :test #'member)))) + (if usock-err + (if (subtypep usock-err 'error) + (error usock-err :socket socket) + (signal usock-err :socket socket)) + (error 'unknown-error + :socket socket + :real-error condition)))) + +;; CMUCL error handling is brain-dead: it doesn't preserve any +;; information other than the OS error string from which the +;; error can be determined. The OS error string isn't good enough +;; given that it may have been localized (l10n). +;; +;; The above applies to versions pre 19b; 19d and newer are expected to +;; contain even better error reporting. +;; +;; +;; Just catch the errors and encapsulate them in an unknown-error +(defun handle-condition (condition &optional (socket nil)) + "Dispatch correct usocket condition." + (typecase condition + (ext::socket-error (cmucl-map-socket-error (ext::socket-errno condition) + :socket socket + :condition condition)) + (simple-error (error 'unknown-error + :real-condition condition + :socket socket)) + (condition (error condition)))) + +(defun socket-connect (host port &key (element-type 'character)) + (let* ((socket)) + (setf socket + (with-mapped-conditions (socket) + (ext:connect-to-inet-socket (host-to-hbo host) port :stream))) + (if socket + (let* ((stream (sys:make-fd-stream socket :input t :output t + :element-type element-type + :buffering :full)) + ;;###FIXME the above line probably needs an :external-format + (usocket (make-stream-socket :socket socket + :stream stream))) + usocket) + (let ((err (unix:unix-errno))) + (when err (cmucl-map-socket-error err)))))) + +(defun socket-listen (host port + &key reuseaddress + (reuse-address nil reuse-address-supplied-p) + (backlog 5) + (element-type 'character)) + (let* ((reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress)) + (server-sock + (with-mapped-conditions () + (apply #'ext:create-inet-listener + (append (list port :stream + :backlog backlog + :reuse-address reuseaddress) + (when (ip/= host *wildcard-host*) + (list :host + (host-to-hbo host)))))))) + (make-stream-server-socket server-sock :element-type element-type))) + +(defmethod socket-accept ((usocket stream-server-usocket) &key element-type) + (with-mapped-conditions (usocket) + (let* ((sock (ext:accept-tcp-connection (socket usocket))) + (stream (sys:make-fd-stream sock :input t :output t + :element-type (or element-type + (element-type usocket)) + :buffering :full))) + (make-stream-socket :socket sock :stream stream)))) + +;; Sockets and socket streams are represented +;; by different objects. Be sure to close the +;; socket stream when closing a stream socket. +(defmethod socket-close ((usocket stream-usocket)) + "Close socket." + (with-mapped-conditions (usocket) + (close (socket-stream usocket)))) + +(defmethod socket-close ((usocket usocket)) + "Close socket." + (with-mapped-conditions (usocket) + (ext:close-socket (socket usocket)))) + +(defmethod get-local-name ((usocket usocket)) + (multiple-value-bind + (address port) + (ext:get-socket-host-and-port (socket usocket)) + (values (hbo-to-vector-quad address) port))) + +(defmethod get-peer-name ((usocket stream-usocket)) + (multiple-value-bind + (address port) + (ext:get-peer-host-and-port (socket usocket)) + (values (hbo-to-vector-quad address) port))) + +(defmethod get-local-address ((usocket usocket)) + (nth-value 0 (get-local-name usocket))) + +(defmethod get-peer-address ((usocket stream-usocket)) + (nth-value 0 (get-peer-name usocket))) + +(defmethod get-local-port ((usocket usocket)) + (nth-value 1 (get-local-name usocket))) + +(defmethod get-peer-port ((usocket stream-usocket)) + (nth-value 1 (get-peer-name usocket))) + + +(defun lookup-host-entry (host) + (multiple-value-bind + (entry errno) + (ext:lookup-host-entry host) + (if entry + entry + ;;###The constants below work on *most* OSes, but are defined as the + ;; constants mentioned in C + (let ((exception + (second (assoc errno + '((1 ns-host-not-found-error) ;; HOST_NOT_FOUND + (2 ns-no-recovery-error) ;; NO_DATA + (3 ns-no-recovery-error) ;; NO_RECOVERY + (4 ns-try-again)))))) ;; TRY_AGAIN + (when exception + (error exception)))))) + + +(defun get-host-by-address (address) + (handler-case (ext:host-entry-name + (lookup-host-entry (host-byte-order address))) + (condition (condition) (handle-condition condition)))) + +(defun get-hosts-by-name (name) + (handler-case (mapcar #'hbo-to-vector-quad + (ext:host-entry-addr-list + (lookup-host-entry name))) + (condition (condition) (handle-condition condition)))) + +(defun get-host-name () + (unix:unix-gethostname)) Added: branches/trunk-reorg/thirdparty/usocket-0.3.5/backend/lispworks.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/usocket-0.3.5/backend/lispworks.lisp Tue Jan 29 07:06:27 2008 @@ -0,0 +1,137 @@ +;;;; $Id: lispworks.lisp 294 2007-09-17 19:50:34Z ehuelsmann $ +;;;; $URL: svn+ssh://ehuelsmann@common-lisp.net/project/usocket/svn/usocket/tags/0.3.5/backend/lispworks.lisp $ + +;;;; See LICENSE for licensing information. + +(in-package :usocket) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require "comm")) + +#+win32 +(fli:register-module "ws2_32") + +(fli:define-foreign-function (get-host-name-internal "gethostname" :source) + ((return-string (:reference-return (:ef-mb-string :limit 257))) + (namelen :int)) + :lambda-list (&aux (namelen 256) return-string) + :result-type :int + #+win32 :module #+win32 "ws2_32") + +(defun get-host-name () + (multiple-value-bind (retcode name) + (get-host-name-internal) + (when (= 0 retcode) + name))) + +#+win32 +(defun remap-maybe-for-win32 (z) + (mapcar #'(lambda (x) + (cons (mapcar #'(lambda (y) + (+ 10000 y)) + (car x)) + (cdr x))) + z)) + +(defparameter +lispworks-error-map+ + #+win32 + (append (remap-maybe-for-win32 +unix-errno-condition-map+) + (remap-maybe-for-win32 +unix-errno-error-map+)) + #-win32 + (append +unix-errno-condition-map+ + +unix-errno-error-map+)) + + + +(defun handle-condition (condition &optional (socket nil)) + "Dispatch correct usocket condition." + (typecase condition + (simple-error (destructuring-bind (&optional host port err-msg errno) + (simple-condition-format-arguments condition) + (declare (ignore host port err-msg)) + (let* ((usock-err + (cdr (assoc errno +lispworks-error-map+ + :test #'member)))) + (if usock-err + (if (subtypep usock-err 'error) + (error usock-err :socket socket) + (signal usock-err :socket socket)) + (error 'unknown-error + :socket socket + :real-error condition))))))) + +(defun socket-connect (host port &key (element-type 'base-char)) + (let ((hostname (host-to-hostname host)) + (stream)) + (setf stream + (with-mapped-conditions () + (comm:open-tcp-stream hostname port + :element-type element-type))) + (if stream + (make-stream-socket :socket (comm:socket-stream-socket stream) + :stream stream) + (error 'unknown-error)))) + +(defun socket-listen (host port + &key reuseaddress + (reuse-address nil reuse-address-supplied-p) + (backlog 5) + (element-type 'base-char)) + (let* ((reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress)) + (comm::*use_so_reuseaddr* reuseaddress) + (hostname (host-to-hostname host)) + (sock (with-mapped-conditions () + #-lispworks4.1 (comm::create-tcp-socket-for-service + port :address hostname :backlog backlog) + #+lispworks4.1 (comm::create-tcp-socket-for-service port)))) + (make-stream-server-socket sock :element-type element-type))) + +(defmethod socket-accept ((usocket stream-server-usocket) &key element-type) + (let* ((sock (with-mapped-conditions (usocket) + (comm::get-fd-from-socket (socket usocket)))) + (stream (make-instance 'comm:socket-stream + :socket sock + :direction :io + :element-type (or element-type + (element-type usocket))))) + (make-stream-socket :socket sock :stream stream))) + +;; Sockets and their streams are different objects +;; close the stream in order to make sure buffers +;; are correctly flushed and the socket closed. +(defmethod socket-close ((usocket stream-usocket)) + "Close socket." + (close (socket-stream usocket))) + +(defmethod socket-close ((usocket usocket)) + (with-mapped-conditions (usocket) + (comm::close-socket (socket usocket)))) + +(defmethod get-local-name ((usocket usocket)) + (multiple-value-bind + (address port) + (comm:get-socket-address (socket usocket)) + (values (hbo-to-vector-quad address) port))) + +(defmethod get-peer-name ((usocket stream-usocket)) + (multiple-value-bind + (address port) + (comm:get-socket-peer-address (socket usocket)) + (values (hbo-to-vector-quad address) port))) + +(defmethod get-local-address ((usocket usocket)) + (nth-value 0 (get-local-name usocket))) + +(defmethod get-peer-address ((usocket stream-usocket)) + (nth-value 0 (get-peer-name usocket))) + +(defmethod get-local-port ((usocket usocket)) + (nth-value 1 (get-local-name usocket))) + +(defmethod get-peer-port ((usocket stream-usocket)) + (nth-value 1 (get-peer-name usocket))) + +(defun get-hosts-by-name (name) + (with-mapped-conditions () + (mapcar #'hbo-to-vector-quad + (comm:get-host-entry name :fields '(:addresses))))) Added: branches/trunk-reorg/thirdparty/usocket-0.3.5/backend/openmcl.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/usocket-0.3.5/backend/openmcl.lisp Tue Jan 29 07:06:27 2008 @@ -0,0 +1,146 @@ +;;;; $Id: openmcl.lisp 294 2007-09-17 19:50:34Z ehuelsmann $ +;;;; $URL: svn+ssh://ehuelsmann@common-lisp.net/project/usocket/svn/usocket/tags/0.3.5/backend/openmcl.lisp $ + +;;;; See LICENSE for licensing information. + +(in-package :usocket) + +(defun get-host-name () + (ccl::%stack-block ((resultbuf 256)) + (when (zerop (#_gethostname resultbuf 256)) + (ccl::%get-cstring resultbuf)))) + +(defparameter +openmcl-error-map+ + '((:address-in-use . address-in-use-error) + (:connection-aborted . connection-aborted-error) + (:no-buffer-space . no-buffers-error) + (:connection-timed-out . timeout-error) + (:connection-refused . connection-refused-error) + (:host-unreachable . host-unreachable-error) + (:host-down . host-down-error) + (:network-down . network-down-error) + (:address-not-available . address-not-available-error) + (:network-reset . network-reset-error) + (:connection-reset . connection-reset-error) + (:shutdown . shutdown-error) + (:access-denied . operation-not-permitted-error))) + + +;; we need something which the openmcl implementors 'forgot' to do: +;; wait for more than one socket-or-fd + +(defun input-available-p (sockets &optional ticks-to-wait) + (ccl::rletZ ((tv :timeval)) + (ccl::ticks-to-timeval ticks-to-wait tv) + (ccl::%stack-block ((infds ccl::*fd-set-size*) + (errfds ccl::*fd-set-size*)) + (ccl::fd-zero infds) + (ccl::fd-zero errfds) + (dolist (sock sockets) + (ccl::fd-set (socket-os-fd sock infds)) + (ccl::fd-set (socket-os-fd sock errfds))) + (let* ((res (ccl::syscall syscalls::select + (1+ (apply #'max fds)) + infds (ccl::%null-ptr) errfds + (if ticks-to-wait tv (ccl::%null-ptr))))) + (when (> res 0) + (remove-if #'(lambda (x) + (not (ccl::fd-is-set (socket-os-fd x) infds))) + sockets)))))) + +(defun wait-for-input (sockets &optional ticks-to-wait) + (let ((wait-end (when ticks-to-wait (+ ticks-to-wait (ccl::get-tick-count))))) + (do ((res (input-available-p sockets ticks-to-wait) + (input-available-p sockets ticks-to-wait))) + ((or res (< wait-end (ccl::get-tick-count))) + res)))) + +(defun raise-error-from-id (condition-id socket real-condition) + (let ((usock-err (cdr (assoc condition-id +openmcl-error-map+)))) + (if usock-err + (error usock-err :socket socket) + (error 'unknown-error :socket socket :real-error real-condition)))) + +(defun handle-condition (condition &optional socket) + (typecase condition + (openmcl-socket:socket-error + (raise-error-from-id (openmcl-socket:socket-error-identifier condition) + socket condition)) + (ccl::socket-creation-error #| ugh! |# + (raise-error-from-id (ccl::socket-creationg-error-identifier condition) + socket condition)) + (error (error 'unknown-error :socket socket :real-error condition)) + (condition (signal 'unknown-condition :real-condition condition)))) + +(defun to-format (element-type) + (if (subtypep element-type 'character) + :text + :binary)) + +(defun socket-connect (host port &key (element-type 'character)) + (with-mapped-conditions () + (let ((mcl-sock + (openmcl-socket:make-socket :remote-host (host-to-hostname host) + :remote-port port + :format (to-format element-type)))) + (openmcl-socket:socket-connect mcl-sock) + (make-stream-socket :stream mcl-sock :socket mcl-sock)))) + +(defun socket-listen (host port + &key reuseaddress + (reuse-address nil reuse-address-supplied-p) + (backlog 5) + (element-type 'character)) + (let* ((reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress)) + (sock (with-mapped-conditions () + (apply #'openmcl-socket:make-socket + (append (list :connect :passive + :reuse-address reuseaddress + :local-port port + :backlog backlog + :format (to-format element-type)) + (when (ip/= host *wildcard-host*) + (list :local-host host))))))) + (make-stream-server-socket sock :element-type element-type))) + +(defmethod socket-accept ((usocket stream-server-usocket) &key element-type) + (declare (ignore element-type)) ;; openmcl streams are bi/multivalent + (let ((sock (with-mapped-conditions (usocket) + (openmcl-socket:accept-connection (socket usocket))))) + (make-stream-socket :socket sock :stream sock))) + +;; One close method is sufficient because sockets +;; and their associated objects are represented +;; by the same object. +(defmethod socket-close ((usocket usocket)) + (with-mapped-conditions (usocket) + (close (socket usocket)))) + +(defmethod get-local-address ((usocket usocket)) + (hbo-to-vector-quad (openmcl-socket:local-host (socket usocket)))) + +(defmethod get-peer-address ((usocket stream-usocket)) + (hbo-to-vector-quad (openmcl-socket:remote-host (socket usocket)))) + +(defmethod get-local-port ((usocket usocket)) + (openmcl-socket:local-port (socket usocket))) + +(defmethod get-peer-port ((usocket stream-usocket)) + (openmcl-socket:remote-port (socket usocket))) + +(defmethod get-local-name ((usocket usocket)) + (values (get-local-address usocket) + (get-local-port usocket))) + +(defmethod get-peer-name ((usocket stream-usocket)) + (values (get-peer-address usocket) + (get-peer-port usocket))) + +(defun get-host-by-address (address) + (with-mapped-conditions () + (openmcl-socket:ipaddr-to-hostname (host-to-hbo address)))) + +(defun get-hosts-by-name (name) + (with-mapped-conditions () + (list (hbo-to-vector-quad (openmcl-socket:lookup-hostname + (host-to-hostname name)))))) Added: branches/trunk-reorg/thirdparty/usocket-0.3.5/backend/sbcl.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/usocket-0.3.5/backend/sbcl.lisp Tue Jan 29 07:06:27 2008 @@ -0,0 +1,194 @@ +;;;; $Id: sbcl.lisp 297 2007-09-17 20:25:40Z ehuelsmann $ +;;;; $URL: svn+ssh://ehuelsmann@common-lisp.net/project/usocket/svn/usocket/tags/0.3.5/backend/sbcl.lisp $ + +;;;; See LICENSE for licensing information. + +(in-package :usocket) + +;; There's no way to preload the sockets library other than by requiring it +;; +;; ECL sockets has been forked off sb-bsd-sockets and implements the +;; same interface. We use the same file for now. +#+ecl +(eval-when (:compile-toplevel :load-toplevel :execute) + (require :sockets)) + +#+sbcl +(progn + #-win32 + (defun get-host-name () + (sb-unix:unix-gethostname)) + + ;; we assume winsock has already been loaded, after all, + ;; we already loaded sb-bsd-sockets and sb-alien + #+win32 + (defun get-host-name () + (sb-alien:with-alien ((buf (sb-alien:array sb-alien:char 256))) + (let ((result (sb-alien:alien-funcall + (sb-alien:extern-alien "gethostname" + (sb-alien:function sb-alien:int + (* sb-alien:char) + sb-alien:int)) + (sb-alien:cast buf (* sb-alien:char)) + 256))) + (when (= result 0) + (sb-alien:cast buf sb-alien:c-string)))))) + + +#+ecl +(progn + (ffi:clines + #-:wsock + "#include <sys/socket.h>" + #+:wsock + "#include <winsock2.h>" + + "#include <string.h>" + ) + + (defun get-host-name () + (ffi:c-inline + () () :object + "{ char *buf = GC_malloc(257); + + if (gethostname(buf,256) == 0) + @(return) = make_simple_base_string(strndup(&buf,255)); + else + @(return) = Cnil; + }" :one-liner nil :side-effects nil))) + +(defun map-socket-error (sock-err) + (map-errno-error (sb-bsd-sockets::socket-error-errno sock-err))) + +(defparameter +sbcl-condition-map+ + '((interrupted-error . interrupted-condition))) + +(defparameter +sbcl-error-map+ + `((sb-bsd-sockets:address-in-use-error . address-in-use-error) + (sb-bsd-sockets::no-address-error . address-not-available-error) + (sb-bsd-sockets:bad-file-descriptor-error . bad-file-descriptor-error) + (sb-bsd-sockets:connection-refused-error . connection-refused-error) + (sb-bsd-sockets:invalid-argument-error . invalid-argument-error) + (sb-bsd-sockets:no-buffers-error . no-buffers-error) + (sb-bsd-sockets:operation-not-supported-error + . operation-not-supported-error) + (sb-bsd-sockets:operation-not-permitted-error + . operation-not-permitted-error) + (sb-bsd-sockets:protocol-not-supported-error + . protocol-not-supported-error) + (sb-bsd-sockets:socket-type-not-supported-error + . socket-type-not-supported-error) + (sb-bsd-sockets:network-unreachable-error . network-unreachable-error) + (sb-bsd-sockets:operation-timeout-error . timeout-error) + (sb-bsd-sockets:socket-error . ,#'map-socket-error) + ;; Nameservice errors: mapped to unknown-error +;; (sb-bsd-sockets:no-recovery-error . network-reset-error) +;; (sb-bsd-sockets:try-again-condition ...) +;; (sb-bsd-sockets:host-not-found ...) + )) + +(defun handle-condition (condition &optional (socket nil)) + "Dispatch correct usocket condition." + (typecase condition + (error (let* ((usock-error (cdr (assoc (type-of condition) + +sbcl-error-map+))) + (usock-error (if (functionp usock-error) + (funcall usock-error condition) + usock-error))) + (if usock-error + (error usock-error :socket socket) + (error 'unknown-error + :socket socket + :real-error condition)))) + (condition (let* ((usock-cond (cdr (assoc (type-of condition) + +sbcl-condition-map+))) + (usock-cond (if (functionp usock-cond) + (funcall usock-cond condition) + usock-cond))) + (if usock-cond + (signal usock-cond :socket socket) + (signal 'unknown-condition + :real-condition condition)))))) + + +(defun socket-connect (host port &key (element-type 'character)) + (let* ((socket (make-instance 'sb-bsd-sockets:inet-socket + :type :stream :protocol :tcp)) + (stream (sb-bsd-sockets:socket-make-stream socket + :input t + :output t + :buffering :full + :element-type element-type)) + ;;###FIXME: The above line probably needs an :external-format + (usocket (make-stream-socket :stream stream :socket socket)) + (ip (host-to-vector-quad host))) + (with-mapped-conditions (usocket) + (sb-bsd-sockets:socket-connect socket ip port)) + usocket)) + +(defun socket-listen (host port + &key reuseaddress + (reuse-address nil reuse-address-supplied-p) + (backlog 5) + (element-type 'character)) + (let* ((reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress)) + (ip (host-to-vector-quad host)) + (sock (make-instance 'sb-bsd-sockets:inet-socket + :type :stream :protocol :tcp))) + (with-mapped-conditions () + (setf (sb-bsd-sockets:sockopt-reuse-address sock) reuseaddress) + (sb-bsd-sockets:socket-bind sock ip port) + (sb-bsd-sockets:socket-listen sock backlog) + (make-stream-server-socket sock :element-type element-type)))) + +(defmethod socket-accept ((socket stream-server-usocket) &key element-type) + (with-mapped-conditions (socket) + (let ((sock (sb-bsd-sockets:socket-accept (socket socket)))) + (make-stream-socket + :socket sock + :stream (sb-bsd-sockets:socket-make-stream + sock + :input t :output t :buffering :full + :element-type (or element-type + (element-type socket))))))) + +;; Sockets and their associated streams are modelled as +;; different objects. Be sure to close the stream (which +;; closes the socket too) when closing a stream-socket. +(defmethod socket-close ((usocket usocket)) + (with-mapped-conditions (usocket) + (sb-bsd-sockets:socket-close (socket usocket)))) + +(defmethod socket-close ((usocket stream-usocket)) + (with-mapped-conditions (usocket) + (close (socket-stream usocket)))) + +(defmethod get-local-name ((usocket usocket)) + (sb-bsd-sockets:socket-name (socket usocket))) + +(defmethod get-peer-name ((usocket stream-usocket)) + (sb-bsd-sockets:socket-peername (socket usocket))) + +(defmethod get-local-address ((usocket usocket)) + (nth-value 0 (get-local-name usocket))) + +(defmethod get-peer-address ((usocket stream-usocket)) + (nth-value 0 (get-peer-name usocket))) + +(defmethod get-local-port ((usocket usocket)) + (nth-value 1 (get-local-name usocket))) + +(defmethod get-peer-port ((usocket stream-usocket)) + (nth-value 1 (get-peer-name usocket))) + + +(defun get-host-by-address (address) + (with-mapped-conditions () + (sb-bsd-sockets::host-ent-name + (sb-bsd-sockets:get-host-by-address address)))) + +(defun get-hosts-by-name (name) + (with-mapped-conditions () + (sb-bsd-sockets::host-ent-addresses + (sb-bsd-sockets:get-host-by-name name)))) + Added: branches/trunk-reorg/thirdparty/usocket-0.3.5/backend/scl.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/usocket-0.3.5/backend/scl.lisp Tue Jan 29 07:06:27 2008 @@ -0,0 +1,137 @@ +;;;; $Id: scl.lisp 294 2007-09-17 19:50:34Z ehuelsmann $ +;;;; $URL: svn+ssh://ehuelsmann@common-lisp.net/project/usocket/svn/usocket/tags/0.3.5/backend/scl.lisp $ + +;;;; See LICENSE for licensing information. + +(in-package :usocket) + +(defparameter +scl-error-map+ + (append +unix-errno-condition-map+ + +unix-errno-error-map+)) + +(defun scl-map-socket-error (err &key condition socket) + (let ((usock-err (cdr (assoc err +scl-error-map+ :test #'member)))) + (cond (usock-err + (if (subtypep usock-err 'error) + (error usock-err :socket socket) + (signal usock-err :socket socket))) + (t + (error 'unknown-error + :socket socket + :real-error condition))))) + +(defun handle-condition (condition &optional (socket nil)) + "Dispatch correct usocket condition." + (etypecase condition + (ext::socket-error + (scl-map-socket-error (ext::socket-errno condition) + :socket socket + :condition condition)) + (error + (error 'unknown-error + :real-condition condition + :socket socket)))) + +(defun socket-connect (host port &key (element-type 'character)) + (let* ((socket (with-mapped-conditions () + (ext:connect-to-inet-socket (host-to-hbo host) port + :kind :stream))) + (stream (sys:make-fd-stream socket :input t :output t + :element-type element-type + :buffering :full))) + (make-stream-socket :socket socket :stream stream))) + +(defun socket-listen (host port + &key reuseaddress + (reuse-address nil reuse-address-supplied-p) + (backlog 5) + (element-type 'character)) + (let* ((reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress)) + (host (if (ip= host *wildcard-host*) + 0 + (host-to-hbo host))) + (server-sock + (with-mapped-conditions () + (ext:create-inet-listener port :stream + :host host + :reuse-address reuseaddress + :backlog backlog)))) + (make-stream-server-socket server-sock :element-type element-type))) + +(defmethod socket-accept ((usocket stream-server-usocket) &key element-type) + (with-mapped-conditions (usocket) + (let* ((sock (ext:accept-tcp-connection (socket usocket))) + (stream (sys:make-fd-stream sock :input t :output t + :element-type (or element-type + (element-type usocket)) + :buffering :full))) + (make-stream-socket :socket sock :stream stream)))) + +;; Sockets and their associated streams are modelled as +;; different objects. Be sure to close the socket stream +;; when closing stream-sockets; it makes sure buffers +;; are flushed and the socket is closed correctly afterwards. +(defmethod socket-close ((usocket usocket)) + "Close socket." + (with-mapped-conditions (usocket) + (ext:close-socket (socket usocket)))) + +(defmethod socket-close ((usocket stream-usocket)) + "Close socket." + (with-mapped-conditions (usocket) + (close (socket-stream usocket)))) + +(defmethod get-local-name ((usocket usocket)) + (multiple-value-bind (address port) + (with-mapped-conditions (usocket) + (ext:get-socket-host-and-port (socket usocket))) + (values (hbo-to-vector-quad address) port))) + +(defmethod get-peer-name ((usocket stream-usocket)) + (multiple-value-bind (address port) + (with-mapped-conditions (usocket) + (ext:get-peer-host-and-port (socket usocket))) + (values (hbo-to-vector-quad address) port))) + +(defmethod get-local-address ((usocket usocket)) + (nth-value 0 (get-local-name usocket))) + +(defmethod get-peer-address ((usocket stream-usocket)) + (nth-value 0 (get-peer-name usocket))) + +(defmethod get-local-port ((usocket usocket)) + (nth-value 1 (get-local-name usocket))) + +(defmethod get-peer-port ((usocket stream-usocket)) + (nth-value 1 (get-peer-name usocket))) + + +(defun get-host-by-address (address) + (multiple-value-bind (host errno) + (ext:lookup-host-entry (host-byte-order address)) + (cond (host + (ext:host-entry-name host)) + (t + (let ((condition (cdr (assoc errno +unix-ns-error-map+)))) + (cond (condition + (error condition :host-or-ip address)) + (t + (error 'ns-unknown-error :host-or-ip address + :real-error errno)))))))) + +(defun get-hosts-by-name (name) + (multiple-value-bind (host errno) + (ext:lookup-host-entry name) + (cond (host + (mapcar #'hbo-to-vector-quad + (ext:host-entry-addr-list host))) + (t + (let ((condition (cdr (assoc errno +unix-ns-error-map+)))) + (cond (condition + (error condition :host-or-ip name)) + (t + (error 'ns-unknown-error :host-or-ip name + :real-error errno)))))))) + +(defun get-host-name () + (unix:unix-gethostname)) Added: branches/trunk-reorg/thirdparty/usocket-0.3.5/condition.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/usocket-0.3.5/condition.lisp Tue Jan 29 07:06:27 2008 @@ -0,0 +1,169 @@ +;;;; $Id: condition.lisp 200 2007-02-25 23:09:34Z ehuelsmann $ +;;;; $URL: svn+ssh://ehuelsmann@common-lisp.net/project/usocket/svn/usocket/tags/0.3.5/condition.lisp $ + +;;;; See LICENSE for licensing information. + +(in-package :usocket) + +;; Condition raised by operations with unsupported arguments +;; For trivial-sockets compatibility. + +(define-condition unsupported (error) + ((feature :initarg :feature :reader unsupported-feature))) + + +;; Conditions raised by sockets operations + +(define-condition socket-condition (condition) + ((socket :initarg :socket + :accessor usocket-socket)) + ;;###FIXME: no slots (yet); should at least be the affected usocket... + (:documentation "Parent condition for all socket related conditions.")) + +(define-condition socket-error (socket-condition error) + () ;; no slots (yet) + (:documentation "Parent error for all socket related errors")) + +(define-condition ns-condition (condition) + ((host-or-ip :initarg :host-or-ip + :accessor host-or-ip)) + (:documentation "Parent condition for all name resolution conditions.")) + +(define-condition ns-error (ns-condition error) + () + (:documentation "Parent error for all name resolution errors.")) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun define-usocket-condition-class (class &rest parents) + `(progn + (define-condition ,class ,parents ()) + (export ',class)))) + +(defmacro define-usocket-condition-classes (class-list parents) + `(progn ,@(mapcar #'(lambda (x) + (apply #'define-usocket-condition-class + x parents)) + class-list))) + +;; Mass define and export our conditions +(define-usocket-condition-classes + (interrupted-condition) + (socket-condition)) + +(define-condition unknown-condition (socket-condition) + ((real-condition :initarg :real-condition + :accessor usocket-real-condition)) + (:documentation "Condition raised when there's no other - more applicable - +condition available.")) + + +;; Mass define and export our errors +(define-usocket-condition-classes + (address-in-use-error + address-not-available-error + bad-file-descriptor-error + connection-refused-error + connection-aborted-error + connection-reset-error + invalid-argument-error + no-buffers-error + operation-not-supported-error + operation-not-permitted-error + protocol-not-supported-error + socket-type-not-supported-error + network-unreachable-error + network-down-error + network-reset-error + host-down-error + host-unreachable-error + shutdown-error + timeout-error + invalid-socket-error + invalid-socket-stream-error) + (socket-error)) + +(define-condition unknown-error (socket-error) + ((real-error :initarg :real-error + :accessor usocket-real-error)) + (:documentation "Error raised when there's no other - more applicable - +error available.")) + + +(define-usocket-condition-classes + (ns-try-again) + (ns-condition)) + +(define-condition ns-unknown-condition (ns-condition) + ((real-error :initarg :real-condition + :accessor ns-real-condition)) + (:documentation "Condition raised when there's no other - more applicable - +condition available.")) + +(define-usocket-condition-classes + ;; the no-data error code in the Unix 98 api + ;; isn't really an error: there's just no data to return. + ;; with lisp, we just return NIL (indicating no data) instead of + ;; raising an exception... + (ns-host-not-found-error + ns-no-recovery-error) + (ns-error)) + +(define-condition ns-unknown-error (ns-error) + ((real-error :initarg :real-error + :accessor ns-real-error)) + (:documentation "Error raised when there's no other - more applicable - +error available.")) + +(defmacro with-mapped-conditions ((&optional socket) &body body) + `(handler-case + (progn ,@body) + (condition (condition) (handle-condition condition ,socket)))) + +(defparameter +unix-errno-condition-map+ + `(((11) . retry-condition) ;; EAGAIN + ((35) . retry-condition) ;; EDEADLCK + ((4) . interrupted-condition))) ;; EINTR + +(defparameter +unix-errno-error-map+ + ;;### the first column is for non-(linux or srv4) systems + ;; the second for linux + ;; the third for srv4 + ;;###FIXME: How do I determine on which Unix we're running + ;; (at least in clisp and sbcl; I know about cmucl...) + ;; The table below works under the assumption we'll *only* see + ;; socket associated errors... + `(((48 98) . address-in-use-error) + ((49 99) . address-not-available-error) + ((9) . bad-file-descriptor-error) + ((61 111) . connection-refused-error) + ((64 131) . connection-reset-error) + ((130) . connection-aborted-error) + ((22) . invalid-argument-error) + ((55 105) . no-buffers-error) + ((12) . out-of-memory-error) + ((45 95) . operation-not-supported-error) + ((1) . operation-not-permitted-error) + ((43 92) . protocol-not-supported-error) + ((44 93) . socket-type-not-supported-error) + ((51 101) . network-unreachable-error) + ((50 100) . network-down-error) + ((52 102) . network-reset-error) + ((58 108) . already-shutdown-error) + ((60 110) . connection-timeout-error) + ((64 112) . host-down-error) + ((65 113) . host-unreachable-error))) + + +(defun map-errno-condition (errno) + (cdr (assoc errno +unix-errno-error-map+ :test #'member))) + + +(defun map-errno-error (errno) + (cdr (assoc errno +unix-errno-error-map+ :test #'member))) + + +(defparameter +unix-ns-error-map+ + `((1 . ns-host-not-found-error) + (2 . ns-try-again-condition) + (3 . ns-no-recovery-error))) + Added: branches/trunk-reorg/thirdparty/usocket-0.3.5/doc/backends.txt ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/usocket-0.3.5/doc/backends.txt Tue Jan 29 07:06:27 2008 @@ -0,0 +1,59 @@ + -*- text -*- + +$Id: backends.txt 182 2007-01-19 23:43:12Z ehuelsmann $ + +A document to describe which APIs a backend should implement. + + +Each backend should implement: + +Functions: + + - handle-condition + - socket-connect + - socket-listen + - get-hosts-by-name [ optional ] + - get-host-by-address [ optional ] + + +Methods: + + - socket-close + - socket-accept + - get-local-name + - get-peer-name + + and - for ip sockets - these methods: + + - get-local-address + - get-local-port + - get-peer-address + - get-peer-port + + +An error-handling function, resolving implementation specific errors +to this list of errors: + + - address-in-use-error + - address-not-available-error + - bad-file-descriptor-error + - connection-refused-error + - invalid-argument-error + - no-buffers-error + - operation-not-supported-error + - operation-not-permitted-error + - protocol-not-supported-error + - socket-type-not-supported-error + - network-unreachable-error + - network-down-error + - network-reset-error + - host-down-error + - host-unreachable-error + - shutdown-error + - timeout-error + - unkown-error + +and these conditions: + + - interrupted-condition + - unkown-condition Added: branches/trunk-reorg/thirdparty/usocket-0.3.5/doc/design.txt ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/usocket-0.3.5/doc/design.txt Tue Jan 29 07:06:27 2008 @@ -0,0 +1,136 @@ + + -*- text -*- + +$Id: design.txt 122 2006-10-22 08:42:00Z ehuelsmann $ + + + usocket: Universal sockets library + ================================== + +Contents +======== + + * Motivation + * Design goal + * Functional requirements + * Class structure + + + +Motivation +========== + +There are 2 other portability sockets packages [that I know of] +out there: + + 1) trivial-sockets + 2) acl-compat (which is a *lot* broader, but contains sockets too) + +The first misses some functionality which is fundamental when +the requirements stop being 'trivial', such as finding out the +addresses of either side connected to the tcp/ip stream. + +The second, being a complete compatibility library for Allegro, +contains much more than only sockets. Next to that, as the docs +say, is it mainly directed at providing the functionality required +to port portable-allegroserve - meaning it may be (very) incomplete +on some platforms. + +So, that's why I decided to inherit Erik Enge's project to build +a library with the intention to provide portability code in only +1 area of programming, targeted at 'not so trivial' programming. + +Also, I need this library to extend cl-irc with full DCC functionality. + + + +Design goal +=========== + +To provide a portable TCP/IP socket interface for as many +implementations as possible, while keeping the portability layer +as thin as possible. + + + +Functional requirements +======================= + +The interface provided should allow: + - 'client'/active sockets + - 'server'/listening sockets + - provide the usual stream methods to operate on the connection stream + (not necessarily the socket itself; maybe a socket slot too) + +For now, as long as there are no possibilities to have UDP sockets +to write a DNS client library: (which in the end may work better, +because in this respect all implementations are different...) + - retrieve IP addresses/ports for both sides of the connection + +Several relevant support functionalities will have to be provided too: + - long <-> quad-vector operators + - quad-vector <-> string operators + - hostname <-> quad-vector operators (hostname resolution) + + +Minimally, I'd like to support: + - SBCL + - CMUCL + - ABCL (ArmedBear) + - clisp + - Allegro + - LispWorks + - OpenMCL + + +Comments on the design above +============================ + +I don't think it's a good idea to implement name lookup in the +very first of steps: we'll see if this is required to get the +package accepted; not all implementations support it. + +Name resolution errors ... +Since there is no name resolution library (yet), nor standardized +hooks into the standard C library to do it the same way on +all platforms, name resolution errors can manifest themselves +in a lot of different ways. How to marshall these to the +library users? + +Several solutions come to mind: + +1) Map them to 'unknown-error +2) Give them their own errors and map to those + ... which implies that they are actually supported atm. +3) ... + +Given that the library doesn't now, but may in the future, +include name resolution officially, I tend to think (1) is the +right answer: it leaves it all undecided. + +These errors can be raised by the nameresolution service +(netdb.h) as values for 'int h_errno': + +- HOST_NOT_FOUND (1) +- TRY_AGAIN (2) /* Server fail or non-authoritive Host not found */ +- NO_RECOVERY (3) /* Failed permanently */ +- NO_DATA (4) /* Valid address, no data for requested record */ + +int *__h_errno_location(void) points to thread local h_errno on +threaded glibc2 systems. + + +Class structure +=============== + + usocket + | + +- datagram-usocket + +- stream-usocket + \- stream-server-usocket + +The usocket class will have methods to query local properties, such +as: + + - get-local-name: to query to which interface the socket is bound + - <other socket and protocol options such as SO_REUSEADDRESS> Added: branches/trunk-reorg/thirdparty/usocket-0.3.5/notes/abcl-socket.txt ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/usocket-0.3.5/notes/abcl-socket.txt Tue Jan 29 07:06:27 2008 @@ -0,0 +1,18 @@ + +ABCL provides a callback interface to java objects, next to these calls: + + - ext:make-socket + - ext:socket-close + - ext:make-server-socket + - ext:socket-accept + - ext:get-socket-stream (returning an io-stream) + +abcl-swank (see SLIME) shows how to call directly into java. + + +See for the sockets implementation: + + - src/org/armedbear/lisp + * socket.lisp + * socket_stream.java + * SocketStream.java Added: branches/trunk-reorg/thirdparty/usocket-0.3.5/notes/active-sockets-apis.txt ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/usocket-0.3.5/notes/active-sockets-apis.txt Tue Jan 29 07:06:27 2008 @@ -0,0 +1,75 @@ + -*- text -*- + +A document to summarizing which API's of the different implementations +are associated with 'Step 1'. + +Interface to be implemented in step 1: + + - socket-connect + - socket-close + - get-host-by-address + - get-hosts-by-name + +(and something to do with errors; maybe move this to step 1a?) + +SBCL +==== + + sockets: + - socket-bind + - make-instance 'inet-socket + - socket-make-stream + - socket-connect (ip vector-quad) port + - socket-close + + DNS name resolution: + - get-host-by-name + - get-host-by-address + - ::host-ent-addresses + - host-ent-name + + +CMUCL +===== + + sockets: + - ext:connect-to-inet-socket (ip integer) port + - sys:make-fd-stream + - ext:close-socket + + DNS name resolution: + - ext:host-entry-name + - ext::lookup-host-entry + - ext:host-entry-addr-list + - ext:lookup-host-entry + + +ABCL +==== + + sockets + - ext:socket-connect (hostname string) port + - ext:get-socket-stream + - ext:socket-close + + +clisp +===== + + sockets + - socket-connect port (hostname string) + - close (socket) + + +Allegro +======= + + sockets + - make-socket + - socket-connect + - close + + DNS resolution + - lookup-hostname + - ipaddr-to-hostname + Added: branches/trunk-reorg/thirdparty/usocket-0.3.5/notes/address-apis.txt ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/usocket-0.3.5/notes/address-apis.txt Tue Jan 29 07:06:27 2008 @@ -0,0 +1,73 @@ + + -*- text -*- + +Step 2 of the master plan: Implementing (get-local-address sock) and +(get-peer-address sock). + + +Step 2 is about implementing: + + (get-local-address sock) -> ip + (get-peer-address sock) -> ip + (get-local-port sock) -> port + (get-peer-port sock) -> port + (get-local-name sock) -> ip, port + (get-peer-name sock) -> ip, port + + +ABCL +==== + + FFI / J-calls to "getLocalAddress"+"getAddress", "getLocalPort" (local) + FFI / J-calls to "getInetAddress"+"getAddress", "getPort" (peer) + + (see SLIME / swank-abcl.lisp for an example on how to do that) + + +Allegro +======= + + (values (socket:remote-host sock) + (socket:remote-port)) -> 32bit ip, port + + (values (socket:local-host sock) + (socket:local-port sock)) -> 32bit ip, port + +CLISP +===== + + (socket:socket-stream-local sock nil) -> address (as dotted quad), port + (socket:socket-stream-peer sock nil) -> address (as dotted quad), port + + +CMUCL +===== + + (ext:get-peer-host-and-port sock-fd) -> 32-bit-addr, port (peer) + (ext:get-socket-host-and-port sock-fd) -> 32-bit-addr, port (local) + + +LispWorks +========= + + (comm:socket-stream-address sock-stream) -> 32-bit-addr, port + or: (comm:get-socket-address sock) -> 32-bit-addr, port + + (comm:socket-stream-peer-address sock-stream) -> 32-bit-addr, port + or: (comm:get-socket-peer-address sock) -> 32-bit-addr, port + + +OpenMCL +======= + + (values (ccl:local-host sock) (ccl:local-port sock)) -> 32-bit ip, port + (values (ccl:remote-host sock) (ccl:remote-port sock)) -> 32-bit ip, port + + +SBCL +==== + + (sb-bsd-sockets:socket-name sock) -> vector-quad, port + (sb-bsd-sockets:socket-peer-name sock) -> vector-quad, port + + Added: branches/trunk-reorg/thirdparty/usocket-0.3.5/notes/allegro-socket.txt ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/usocket-0.3.5/notes/allegro-socket.txt Tue Jan 29 07:06:27 2008 @@ -0,0 +1,46 @@ + + +(require :sock) + +accept-connection (sock passive-socket) &key wait Generic function. +dotted-to-ipaddr dotted &key errorp Function. +ipaddr-to-dotted ipaddr &key values Function. +ipaddr-to-hostname ipaddr Function. +lookup-hostname hostname +lookup-port portname protocol Function. +make-socket &key type format address-family connect &allow-other-keys Function. +with-pending-connect &body body Macro. +receive-from (sock datagram-socket) size &key buffer extract Generic function. +send-to sock &key +shutdown sock &key direction +socket-control stream &key output-chunking output-chunking-eof input-chunking +socket-os-fd sock Generic function. + +remote-host socket Generic function. +local-host socket Generic function. +local-port socket + +remote-filename socket +local-filename socket +remote-port socket +socket-address-family socket +socket-connect socket +socket-format socket +socket-type socket + +errors + +:address-in-use Local socket address already in use +:address-not-available Local socket address not available +:network-down Network is down +:network-reset Network has been reset +:connection-aborted Connection aborted +:connection-reset Connection reset by peer +:no-buffer-space No buffer space +:shutdown Connection shut down +:connection-timed-out Connection timed out +:connection-refused Connection refused +:host-down Host is down +:host-unreachable Host is unreachable +:unknown Unknown error + Added: branches/trunk-reorg/thirdparty/usocket-0.3.5/notes/clisp-sockets.txt ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/usocket-0.3.5/notes/clisp-sockets.txt Tue Jan 29 07:06:27 2008 @@ -0,0 +1,38 @@ +http://clisp.cons.org/impnotes.html#socket + +(SOCKET:SOCKET-SERVER &OPTIONAL [port-or-socket]) +(SOCKET:SOCKET-SERVER-HOST socket-server) +(SOCKET:SOCKET-SERVER-PORT socket-server) +(SOCKET:SOCKET-WAIT socket-server &OPTIONAL [seconds [microseconds]]) +(SOCKET:SOCKET-ACCEPT socket-server &KEY :ELEMENT-TYPE :EXTERNAL-FORMAT :BUFFERED :TIMEOUT) +(SOCKET:SOCKET-CONNECT port &OPTIONAL [host] &KEY :ELEMENT-TYPE :EXTERNAL-FORMAT :BUFFERED :TIMEOUT) +(SOCKET:SOCKET-STATUS socket-stream-or-list &OPTIONAL [seconds [microseconds]]) +(SOCKET:SOCKET-STREAM-HOST socket-stream) +(SOCKET:SOCKET-STREAM-PORT socket-stream) +(SOCKET:SOCKET-SERVICE-PORT &OPTIONAL service-name (protocol "tcp")) +(SOCKET:SOCKET-STREAM-PEER socket-stream [do-not-resolve-p]) +(SOCKET:SOCKET-STREAM-LOCAL socket-stream [do-not-resolve-p]) +(SOCKET:SOCKET-STREAM-SHUTDOWN socket-stream direction) +(SOCKET:SOCKET-OPTIONS socket-server &REST {option}*) + + +(posix:resolve-host-ipaddr &optional host) + +with the host-ent structure: + + name - host name + aliases - LIST of aliases + addr-list - LIST of IPs as dotted quads (IPv4) or coloned octets (IPv6) + addrtype - INTEGER address type IPv4 or IPv6 + + +Errors are of type + +SYSTEM::SIMPLE-OS-ERROR + with a 1 element (integer) SYSTEM::$FORMAT-ARGUMENTS list + +This integer stores the OS error reported; meaning WSA* codes on Win32 +and E* codes on *nix, only: unix.lisp in CMUCL shows +BSD, Linux and SRV4 have different number assignments for the same +E* constant names :-( + Added: branches/trunk-reorg/thirdparty/usocket-0.3.5/notes/cmucl-sockets.txt ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/usocket-0.3.5/notes/cmucl-sockets.txt Tue Jan 29 07:06:27 2008 @@ -0,0 +1,69 @@ +http://cvs2.cons.org/ftp-area/cmucl/doc/cmu-user/internet.html + +$Id: cmucl-sockets.txt 91 2006-02-13 08:01:51Z ehuelsmann $ + +extensions:lookup-host-entry host + +[structure] +host-entry + + name aliases addr-type addr-list + +[Function] +extensions:create-inet-listener port &optional kind &key :reuse-address :backlog :interface + => socket fd + +[Function] +extensions:accept-tcp-connection unconnected + => socket fd, address + +[Function] +extensions:connect-to-inet-socket host port &optional kind + => socket fd + +[Function] +extensions:close-socket socket + + + +[Private function] +extensions::get-peer-host-and-port socket-fd + +[Private function] +extentsions::get-socket-host-and-port socket-fd + + + +There's currently only 1 condition to be raised: + + SOCKET-ERROR (derived from SIMPLE-ERROR) + which has a SOCKET-ERRNO slot containing the unix error number. + + + + +[Function] +extensions:add-oob-handler fd char handler + +[Function] +extensions:remove-oob-handler fd char + +[Function] +extensions:remove-all-oob-handlers fd + +[Function] +extensions:send-character-out-of-band fd char + +[Function] +extensions:create-inet-socket &optional type + => socket fd + +[Function] +extensions:get-socket-option socket level optname + +[Function] +extensions:set-socket-option socket level optname optval + +[Function] +extensions:ip-string addr + Added: branches/trunk-reorg/thirdparty/usocket-0.3.5/notes/errors.txt ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/usocket-0.3.5/notes/errors.txt Tue Jan 29 07:06:27 2008 @@ -0,0 +1,20 @@ +EADDRINUSE 48 address-in-use-error +EADDRNOTAVAIL 49 address-not-available-error +EAGAIN interrupted-error ;; not 1 error code: bsd == 11; non-bsd == 35 +EBADF 9 bad-file-descriptor-error +ECONNREFUSED 61 connection-refused-error +EINTR 4 interrupted-error +EINVAL 22 invalid-argument-error +ENOBUFS 55 no-buffers-error +ENOMEM 12 out-of-memory-error +EOPNOTSUPP 45 operation-not-supported-error +EPERM 1 operation-not-permitted-error +EPROTONOSUPPORT 43 protocol-not-supported-error +ESOCKTNOSUPPORT 44 socket-type-not-supported-error +ENETUNREACH 51 network-unreachable-error +ENETDOWN 50 network-down-error +ENETRESET 52 network-reset-error +ESHUTDOWN 58 already-shutdown-error +ETIMEDOUT 60 connection-timeout-error +EHOSTDOWN 64 host-down-error +EHOSTUNREACH 65 host-unreachable-error Added: branches/trunk-reorg/thirdparty/usocket-0.3.5/notes/lw-sockets.txt ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/usocket-0.3.5/notes/lw-sockets.txt Tue Jan 29 07:06:27 2008 @@ -0,0 +1,41 @@ + +$Id: lw-sockets.txt 91 2006-02-13 08:01:51Z ehuelsmann $ + +http://www.lispworks.com/reference/lwu41/lwref/LWRM_37.HTM + +Package: COMM + +ip-address-string +socket-stream-address +socket-stream-peer-address +start-up-server +start-up-server-and-mp +string-ip-address +with-noticed-socket-stream + +Needed components for usocket: + +comm::get-fd-from-socket socket-fd + => socket-fd + +comm::accept-connection-to-socket socket-fd + => socket-fd + +comm::close-socket +comm::create-tcp-socket-for-service + => socket-fd + +open-tcp-stream peer-host peer-port &key direction element-type + => socket-stream + +get-host-entry (see http://www.lispworks.com/documentation/lw445/LWRM/html/lwref-30.htm#pgfId-89...) +get-socket-address + +get-socket-peer-address + => address, port + +socket-stream socket-fd + => stream + +socket socket-stream (guessed from http://www.lispworks.com/documentation/lw445/LWRM/html/lwref-43.htm) + => socket-fd Added: branches/trunk-reorg/thirdparty/usocket-0.3.5/notes/openmcl-sockets.txt ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/usocket-0.3.5/notes/openmcl-sockets.txt Tue Jan 29 07:06:27 2008 @@ -0,0 +1,27 @@ +http://openmcl.clozure.com/Doc/sockets.html + + make-socket [Function] + accept-connection [Function] + dotted-to-ipaddr [Function] + ipaddr-to-dotted [Function] + ipaddr-to-hostname [Function] + lookup-hostname [Function] + lookup-port [Function] + receive-from [Function] + send-to [Function] + shutdown [Function] + socket-os-fd [Function] + remote-port [Function] + local-host [Function] + local-port [Function] + + socket-address-family [Function] + + socket-connect [Function] + socket-format [Function] + socket-type [Function] + socket-error [Class] + socket-error-code [Function] + socket-error-identifier [Function] + socket-error-situation [Function] + close [method] Added: branches/trunk-reorg/thirdparty/usocket-0.3.5/notes/sb-bsd-sockets.txt ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/usocket-0.3.5/notes/sb-bsd-sockets.txt Tue Jan 29 07:06:27 2008 @@ -0,0 +1,114 @@ +http://www.xach.com/sbcl/sb-bsd-sockets.html + +$Id: sb-bsd-sockets.txt 91 2006-02-13 08:01:51Z ehuelsmann $ + +package: sb-bsd-sockets + +class: socket + +slots: + + * file-descriptor : + * family : + * protocol : + * type : + * stream : + +operators: + + (socket-bind (s socket) &rest address) Generic Function + (socket-accept (socket socket)) Method + (socket-connect (s socket) &rest address) Generic Function + (socket-peername (socket socket)) Method + (socket-name (socket socket)) Method + (socket-receive (socket socket) buffer length &key oob peek waitall (element-type 'character)) Method + (socket-listen (socket socket) backlog) Method + (socket-close (socket socket)) Method + (socket-make-stream (socket socket) &rest args) Method + + (sockopt-reuse-address (socket socket) argument) Accessor + (sockopt-keep-alive (socket socket) argument) Accessor + (sockopt-oob-inline (socket socket) argument) Accessor + (sockopt-bsd-compatible (socket socket) argument) Accessor + (sockopt-pass-credentials (socket socket) argument) Accessor + (sockopt-debug (socket socket) argument) Accessor + (sockopt-dont-route (socket socket) argument) Accessor + (sockopt-broadcast (socket socket) argument) Accessor + (sockopt-tcp-nodelay (socket socket) argument) Accessor + +inet-domain sockets + +class: inet-socket + +slots: + + * family : + +operators: + + (make-inet-address dotted-quads) Function + (get-protocol-by-name name) Function + (make-inet-socket type protocol) Function + +file-domain sockets + +class: unix-socket + +slots: + + * family : + +class: host-ent + +Slots: + + * name : + * aliases : + * address-type : + * addresses : + + (host-ent-address (host-ent host-ent)) Method + (get-host-by-name host-name) Function + (get-host-by-address address) Function + (name-service-error where) Function + (non-blocking-mode (socket socket)) Method + +(define-socket-condition sockint::EADDRINUSE address-in-use-error) +(define-socket-condition sockint::EAGAIN interrupted-error) +(define-socket-condition sockint::EBADF bad-file-descriptor-error) +(define-socket-condition sockint::ECONNREFUSED connection-refused-error) +(define-socket-condition sockint::EINTR interrupted-error) +(define-socket-condition sockint::EINVAL invalid-argument-error) +(define-socket-condition sockint::ENOBUFS no-buffers-error) +(define-socket-condition sockint::ENOMEM out-of-memory-error) +(define-socket-condition sockint::EOPNOTSUPP operation-not-supported-error) +(define-socket-condition sockint::EPERM operation-not-permitted-error) +(define-socket-condition sockint::EPROTONOSUPPORT protocol-not-supported-error) +(define-socket-condition sockint::ESOCKTNOSUPPORT socket-type-not-supported-error) +(define-socket-condition sockint::ENETUNREACH network-unreachable-error) + +Exported errors: +* (apropos "ERROR" :sb-bsd-sockets) + +SB-BSD-SOCKETS:INTERRUPTED-ERROR +SB-BSD-SOCKETS:TRY-AGAIN-ERROR +* SB-BSD-SOCKETS:NO-RECOVERY-ERROR (EFAIL?) +SB-BSD-SOCKETS:CONNECTION-REFUSED-ERROR +SB-BSD-SOCKETS:INVALID-ARGUMENT-ERROR +* SB-BSD-SOCKETS:HOST-NOT-FOUND-ERROR +SB-BSD-SOCKETS:OPERATION-NOT-PERMITTED-ERROR +SB-BSD-SOCKETS:OPERATION-NOT-SUPPORTED-ERROR +SB-BSD-SOCKETS:PROTOCOL-NOT-SUPPORTED-ERROR +SB-BSD-SOCKETS:OPERATION-TIMEOUT-ERROR +SB-BSD-SOCKETS:SOCKET-TYPE-NOT-SUPPORTED-ERROR +SB-BSD-SOCKETS:NO-BUFFERS-ERROR +SB-BSD-SOCKETS:NETWORK-UNREACHABLE-ERROR +SB-BSD-SOCKETS:BAD-FILE-DESCRIPTOR-ERROR +SB-BSD-SOCKETS:ADDRESS-IN-USE-ERROR +SB-BSD-SOCKETS:OUT-OF-MEMORY-ERROR + +And 1 non-exported error: + +SB-BSD-SOCKETS::NO-ADDRESS-ERROR + +*-ed errors aren't yet addressed in the errorlist supported by usocket Added: branches/trunk-reorg/thirdparty/usocket-0.3.5/notes/usock-sockets.txt ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/usocket-0.3.5/notes/usock-sockets.txt Tue Jan 29 07:06:27 2008 @@ -0,0 +1,28 @@ +Package: + + clisp : socket + cmucl : extensions + sbcl : sb-bsd-sockets + lw : comm + openmcl: openmcl-socket + allegro: sock + +Connecting (TCP/inet only) + + clisp : socket-connect port &optional [host] &key :element-type :external-format :buffered :timeout = > socket-stream + cmucl : connect-to-inet-socket host port &optional kind => file descriptor + sbcl : sb-socket-connect socket &rest address => socket + lw : open-tcp-stream hostname service &key direction element-type buffered => stream-object + openmcl: socket-connect socket => :active, :passive or nil + allegro: make-socket (&rest args &key type format connect address-family eol) => socket + +Closing + + clisp : close socket + cmucl : close-socket socket + sbcl : socket-close socket + lw : close socket + openmcl: close socket + allegro: close socket + +Errors \ No newline at end of file Added: branches/trunk-reorg/thirdparty/usocket-0.3.5/package.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/usocket-0.3.5/package.lisp Tue Jan 29 07:06:27 2008 @@ -0,0 +1,47 @@ +;;;; $Id: package.lisp 203 2007-02-28 19:29:04Z ehuelsmann $ +;;;; $URL: svn+ssh://ehuelsmann@common-lisp.net/project/usocket/svn/usocket/tags/0.3.5/package.lisp $ + +;;;; See the LICENSE file for licensing information. + +(in-package :cl-user) + +#+lispworks (require "comm") + +(eval-when (:execute :load-toplevel :compile-toplevel) + (defpackage :usocket + (:use :cl) + (:export #:socket-connect ; socket constructors and methods + #:socket-listen + #:socket-accept + #:socket-close + #:get-local-address + #:get-peer-address + #:get-local-port + #:get-peer-port + #:get-local-name + #:get-peer-name + + #:with-connected-socket ; convenience macros + #:with-server-socket + #:with-client-socket + #:with-socket-listener + + #:usocket ; socket object and accessors + #:stream-usocket + #:stream-server-usocket + #:socket + #:socket-stream + + #:host-byte-order ; IP(v4) utility functions + #:hbo-to-dotted-quad + #:hbo-to-vector-quad + #:vector-quad-to-dotted-quad + #:dotted-quad-to-vector-quad + #:ip= + #:ip/= + + #:socket-condition ; conditions + #:socket-error ; errors + #:unknown-condition + #:unknown-error))) + Added: branches/trunk-reorg/thirdparty/usocket-0.3.5/run-usocket-tests.sh ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/usocket-0.3.5/run-usocket-tests.sh Tue Jan 29 07:06:27 2008 @@ -0,0 +1,57 @@ +#!/bin/sh + +# Test script to be run from the usocket source root +# +# Unfortunately, it currently works only with SBCL +# in my setup... +# +# I need to figure out how to setup ASDF with the other lisps +# I have installed: cmucl, ABCL, clisp, allegro and lispworks + +cd `dirname $0`/test +rm tests.log + +if test -z "$1" ; then + lisps=*.conf +else + lisps=$1 +fi + +for my_lisp_conf in $lisps ; do + + +args= +lisp_bin= +lisp_name= +lisp_exit="(quit result)" + +. $my_lisp_conf + +if test -z "$lisp_bin" ; then + echo "YOU NEED TO SET A LISP BINARY IN YOUR CONF FILE" + exit 1 +fi + +if test -z "$lisp_name" ; then + lisp_name="`basename \"$lisp_bin\"`" +fi + +echo " +#-sbcl (load \"asdf.lisp\") + +(asdf:operate #-sbcl 'asdf:load-source-op + #+sbcl 'asdf:load-op :usocket-test) + +(let ((result (if (usocket-test:do-tests) 1 0))) + $lisp_exit) +" | $lisp_bin $args + +if test $? -eq 1 ; then + echo "PASS: $lisp_name" >> tests.log +else + echo "FAIL: $lisp_name" >> tests.log +fi + +echo "Above the test results gathered for $lisp_name." + +done Added: branches/trunk-reorg/thirdparty/usocket-0.3.5/test/abcl.conf.in ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/usocket-0.3.5/test/abcl.conf.in Tue Jan 29 07:06:27 2008 @@ -0,0 +1,10 @@ +# lisp binary test setup file + +args= + +# lisp_bin is required! +lisp_bin=~/src/abcl-0.0.9/abcl +lisp_name=ArmedBear + +# lisp_exit is required! +lisp_exit="(quit :status result)" Added: branches/trunk-reorg/thirdparty/usocket-0.3.5/test/allegro.conf.in ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/usocket-0.3.5/test/allegro.conf.in Tue Jan 29 07:06:27 2008 @@ -0,0 +1,10 @@ +# lisp binary test setup file + +args="-batch" + +# lisp_bin is required! +lisp_bin="~/src/acl/acl70_trial/alisp" +lisp_name=Allegro + +# lisp_exit is required! +lisp_exit="(exit result :no-unwind t)" Added: branches/trunk-reorg/thirdparty/usocket-0.3.5/test/clisp.conf.in ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/usocket-0.3.5/test/clisp.conf.in Tue Jan 29 07:06:27 2008 @@ -0,0 +1,10 @@ +# lisp binary test setup file + +args= + +# lisp_bin is required! +lisp_bin=clisp +lisp_name=clisp + +# lisp_exit is required! +lisp_exit="(quit result)" Added: branches/trunk-reorg/thirdparty/usocket-0.3.5/test/cmucl.conf.in ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/usocket-0.3.5/test/cmucl.conf.in Tue Jan 29 07:06:27 2008 @@ -0,0 +1,10 @@ +# lisp binary test setup file + +args= + +# lisp_bin is required! +lisp_bin="~/src/bin/lisp" +lisp_name=CMUCL + +# lisp_exit is required! +lisp_exit="(unix:unix-exit result)" Added: branches/trunk-reorg/thirdparty/usocket-0.3.5/test/package.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/usocket-0.3.5/test/package.lisp Tue Jan 29 07:06:27 2008 @@ -0,0 +1,13 @@ +;;;; $Id: package.lisp 57 2006-02-07 19:39:46Z ehuelsmann $ +;;;; $URL: svn+ssh://ehuelsmann@common-lisp.net/project/usocket/svn/usocket/tags/0.3.5/test/package.lisp $ + +;;;; See the LICENSE file for licensing information. + +(in-package :cl-user) + +(eval-when (:execute :load-toplevel :compile-toplevel) + (defpackage :usocket-test + (:use :cl :regression-test) + (:nicknames :usoct) + (:export :do-tests :run-usocket-tests))) + Added: branches/trunk-reorg/thirdparty/usocket-0.3.5/test/sbcl.conf.in ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/usocket-0.3.5/test/sbcl.conf.in Tue Jan 29 07:06:27 2008 @@ -0,0 +1,10 @@ +# lisp binary test setup file + +args= + +# lisp_bin is required! +lisp_bin=sbcl +lisp_name=SBCL + +# lisp_exit is required! +lisp_exit="(quit status :recklessly-p t)" Added: branches/trunk-reorg/thirdparty/usocket-0.3.5/test/test-usocket.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/usocket-0.3.5/test/test-usocket.lisp Tue Jan 29 07:06:27 2008 @@ -0,0 +1,159 @@ +;;;; $Id: test-usocket.lisp 173 2007-01-18 21:24:25Z ehuelsmann $ +;;;; $URL: svn+ssh://ehuelsmann@common-lisp.net/project/usocket/svn/usocket/tags/0.3.5/test/test-usocket.lisp $ + +;;;; See LICENSE for licensing information. + +(in-package :usocket-test) + +(defmacro with-caught-conditions ((expect throw) &body body) + `(catch 'caught-error + (handler-case + (progn ,@body) + (usocket:unknown-error (c) (if (typep c ,expect) + (throw 'caught-error ,throw) + (progn + (describe c) + (describe + (usocket::usocket-real-error c)) + c))) + (error (c) (if (typep c ,expect) + (throw 'caught-error ,throw) + (progn + (describe c) + c))) + (usocket:unknown-condition (c) (if (typep c ,expect) + (throw 'caught-error ,throw) + (progn + (describe c) + (describe + (usocket::usocket-real-condition c)) + c))) + (condition (c) (if (typep c ,expect) + (throw 'caught-error ,throw) + (progn + (describe c) + c)))))) + +(defparameter +non-existing-host+ "192.168.1.1") +(defparameter +unused-local-port+ 15213) +(defparameter *soc1* (usocket::make-stream-socket :socket :my-socket + :stream :my-stream)) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defparameter +common-lisp-net+ #(80 68 86 115))) ;; common-lisp.net IP + +(deftest make-socket.1 (usocket:socket *soc1*) :my-socket) +(deftest make-socket.2 (usocket:socket-stream *soc1*) :my-stream) + +(deftest socket-no-connect.1 + (with-caught-conditions ('usocket:socket-error nil) + (usocket:socket-connect "127.0.0.0" +unused-local-port+) + t) + nil) +(deftest socket-no-connect.2 + (with-caught-conditions ('usocket:socket-error nil) + (usocket:socket-connect #(127 0 0 0) +unused-local-port+) + t) + nil) +(deftest socket-no-connect.3 + (with-caught-conditions ('usocket:socket-error nil) + (usocket:socket-connect 2130706432 +unused-local-port+) ;; == #(127 0 0 0) + t) + nil) + +(deftest socket-failure.1 + (with-caught-conditions (#-(or cmu lispworks armedbear openmcl) + 'usocket:network-unreachable-error + #+(or cmu lispworks armedbear) + 'usocket:unknown-error + #+openmcl + 'usocket:timeout-error + nil) + (usocket:socket-connect 2130706432 +unused-local-port+) ;; == #(127 0 0 0) + :unreach) + nil) +(deftest socket-failure.2 + (with-caught-conditions (#+(or lispworks armedbear) + 'usocket:unknown-error + #+cmu + 'usocket:network-unreachable-error + #+openmcl + 'usocket:timeout-error + #-(or lispworks armedbear cmu openmcl) + 'usocket:host-unreachable-error + nil) + (usocket:socket-connect +non-existing-host+ 80) ;; 80 = just a port + :unreach) + nil) + + +;; let's hope c-l.net doesn't move soon, or that people start to +;; test usocket like crazy.. +(deftest socket-connect.1 + (with-caught-conditions (nil nil) + (let ((sock (usocket:socket-connect "common-lisp.net" 80))) + (unwind-protect + (typep sock 'usocket:usocket) + (usocket:socket-close sock)))) + t) +(deftest socket-connect.2 + (with-caught-conditions (nil nil) + (let ((sock (usocket:socket-connect +common-lisp-net+ 80))) + (unwind-protect + (typep sock 'usocket:usocket) + (usocket:socket-close sock)))) + t) +(deftest socket-connect.3 + (with-caught-conditions (nil nil) + (let ((sock (usocket:socket-connect (usocket::host-byte-order +common-lisp-net+) 80))) + (unwind-protect + (typep sock 'usocket:usocket) + (usocket:socket-close sock)))) + t) + +;; let's hope c-l.net doesn't change its software any time soon +(deftest socket-stream.1 + (with-caught-conditions (nil nil) + (let ((sock (usocket:socket-connect "common-lisp.net" 80))) + (unwind-protect + (progn + (format (usocket:socket-stream sock) + "GET / HTTP/1.0~A~A~A~A" + #\Return #\Newline #\Return #\Newline) + (force-output (usocket:socket-stream sock)) + (read-line (usocket:socket-stream sock))) + (usocket:socket-close sock)))) + #+clisp "HTTP/1.1 200 OK" + #-clisp #.(format nil "HTTP/1.1 200 OK~A" #\Return) nil) + +(deftest socket-name.1 + (with-caught-conditions (nil nil) + (let ((sock (usocket:socket-connect +common-lisp-net+ 80))) + (unwind-protect + (usocket::get-peer-address sock) + (usocket:socket-close sock)))) + #.+common-lisp-net+) +(deftest socket-name.2 + (with-caught-conditions (nil nil) + (let ((sock (usocket:socket-connect +common-lisp-net+ 80))) + (unwind-protect + (usocket::get-peer-port sock) + (usocket:socket-close sock)))) + 80) +(deftest socket-name.3 + (with-caught-conditions (nil nil) + (let ((sock (usocket:socket-connect +common-lisp-net+ 80))) + (unwind-protect + (usocket::get-peer-name sock) + (usocket:socket-close sock)))) + #.+common-lisp-net+ 80) +(deftest socket-name.4 + (with-caught-conditions (nil nil) + (let ((sock (usocket:socket-connect +common-lisp-net+ 80))) + (unwind-protect + (usocket::get-local-address sock) + (usocket:socket-close sock)))) + #(192 168 1 65)) + + +(defun run-usocket-tests () + (do-tests)) Added: branches/trunk-reorg/thirdparty/usocket-0.3.5/test/usocket-test.asd ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/usocket-0.3.5/test/usocket-test.asd Tue Jan 29 07:06:27 2008 @@ -0,0 +1,22 @@ +;;;; $Id: usocket-test.asd 46 2006-02-06 20:50:07Z ehuelsmann $ +;;;; $URL: svn+ssh://ehuelsmann@common-lisp.net/project/usocket/svn/usocket/tags/0.3.5/test/usocket-test.asd $ + +;;;; See the LICENSE file for licensing information. + +(in-package #:cl-user) + +(defpackage #:usocket-test-system + (:use #:cl #:asdf)) + +(in-package #:usocket-test-system) + +(defsystem usocket-test + :name "usocket-test" + :author "Erik Enge" + :version "0.1.0" + :licence "MIT" + :description "Tests for usocket" + :depends-on (:usocket :rt) + :components ((:file "package") + (:file "test-usocket" + :depends-on ("package")))) Added: branches/trunk-reorg/thirdparty/usocket-0.3.5/test/usocket.asd ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/usocket-0.3.5/test/usocket.asd Tue Jan 29 07:06:27 2008 @@ -0,0 +1 @@ +link ../usocket.asd \ No newline at end of file Added: branches/trunk-reorg/thirdparty/usocket-0.3.5/test/your-lisp.conf.in ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/usocket-0.3.5/test/your-lisp.conf.in Tue Jan 29 07:06:27 2008 @@ -0,0 +1,10 @@ +# lisp binary test setup file + +args= + +# lisp_bin is required! +lisp_bin=<path-to-your-lisp-binary-here> +lisp_name= + +# lisp_exit is required! +lisp_exit= Added: branches/trunk-reorg/thirdparty/usocket-0.3.5/usocket.asd ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/usocket-0.3.5/usocket.asd Tue Jan 29 07:06:27 2008 @@ -0,0 +1,43 @@ + +;;;; $Id: usocket.asd 298 2007-09-17 22:08:26Z ehuelsmann $ +;;;; $URL: svn+ssh://ehuelsmann@common-lisp.net/project/usocket/svn/usocket/tags/0.3.5/usocket.asd $ + +;;;; See the LICENSE file for licensing information. + +(in-package #:cl-user) + +(defpackage #:usocket-system + (:use #:cl #:asdf)) + +(in-package #:usocket-system) + +(defsystem usocket + :name "usocket" + :author "Erik Enge & Erik Huelsmann" + :version "0.3.5" + :licence "MIT" + :description "Universal socket library for Common Lisp" + :depends-on (:split-sequence + #+sbcl :sb-bsd-sockets) + :components ((:file "package") + (:file "usocket" + :depends-on ("package")) + (:file "condition" + :depends-on ("usocket")) + #+clisp (:file "clisp" :pathname "backend/clisp" + :depends-on ("condition")) + #+cmu (:file "cmucl" :pathname "backend/cmucl" + :depends-on ("condition")) + #+scl (:file "scl" :pathname "backend/scl" + :depends-on ("condition")) + #+(or sbcl ecl) (:file "sbcl" :pathname "backend/sbcl" + :depends-on ("condition")) + #+lispworks (:file "lispworks" :pathname "backend/lispworks" + :depends-on ("condition")) + #+openmcl (:file "openmcl" :pathname "backend/openmcl" + :depends-on ("condition")) + #+allegro (:file "allegro" :pathname "backend/allegro" + :depends-on ("condition")) + #+armedbear (:file "armedbear" :pathname "backend/armedbear" + :depends-on ("condition")) + )) Added: branches/trunk-reorg/thirdparty/usocket-0.3.5/usocket.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/usocket-0.3.5/usocket.lisp Tue Jan 29 07:06:27 2008 @@ -0,0 +1,322 @@ +;;;; $Id: usocket.lisp 260 2007-06-05 15:23:20Z ehuelsmann $ +;;;; $URL: svn+ssh://ehuelsmann@common-lisp.net/project/usocket/svn/usocket/tags/0.3.5/usocket.lisp $ + +;;;; See LICENSE for licensing information. + +(in-package :usocket) + +(defparameter *wildcard-host* #(0 0 0 0) + "Hostname to pass when all interfaces in the current system are to be bound.") + +(defparameter *auto-port* 0 + "Port number to pass when an auto-assigned port number is wanted.") + +(defclass usocket () + ((socket + :initarg :socket + :accessor socket + :documentation "Implementation specific socket object instance.")) + (:documentation +"The main socket class. + +Sockets should be closed using the `socket-close' method.")) + +(defclass stream-usocket (usocket) + ((stream + :initarg :stream + :accessor socket-stream + :documentation "Stream instance associated with the socket." +;; +;;Iff an external-format was passed to `socket-connect' or `socket-listen' +;;the stream is a flexi-stream. Otherwise the stream is implementation +;;specific." +)) + (:documentation +"Stream socket class. + +Contrary to other sockets, these sockets may be closed either +with the `socket-close' method or by closing the associated stream +(which can be retrieved with the `socket-stream' accessor).")) + +(defclass stream-server-usocket (usocket) + ((element-type + :initarg :element-type + :initform #-lispworks 'character + #+lispworks 'base-char + :reader element-type + :documentation "Default element type for streams created by +`socket-accept'.")) + (:documentation "Socket which listens for stream connections to +be initiated from remote sockets.")) + +;;Not in use yet: +;;(defclass datagram-usocket (usocket) +;; () +;; (:documentation "")) + +(defun make-socket (&key socket) + "Create a usocket socket type from implementation specific socket." + (unless socket + (error 'invalid-socket)) + (make-stream-socket :socket socket)) + +(defun make-stream-socket (&key socket stream) + "Create a usocket socket type from implementation specific socket +and stream objects. + +Sockets returned should be closed using the `socket-close' method or +by closing the stream associated with the socket. +" + (unless socket + (error 'invalid-socket-error)) + (unless stream + (error 'invalid-socket-stream-error)) + (make-instance 'stream-usocket + :socket socket + :stream stream)) + +(defun make-stream-server-socket (socket &key (element-type + #-lispworks 'character + #+lispworks 'base-char)) + "Create a usocket-server socket type from an +implementation-specific socket object. + +The returned value is a subtype of `stream-server-usocket'. +" + (unless socket + (error 'invalid-socket-error)) + (make-instance 'stream-server-usocket + :socket socket + :element-type element-type)) + +(defgeneric socket-close (usocket) + (:documentation "Close a previously opened `usocket'.")) + +(defgeneric get-local-address (socket) + (:documentation "Returns the IP address of the socket.")) + +(defgeneric get-peer-address (socket) + (:documentation + "Returns the IP address of the peer the socket is connected to.")) + +(defgeneric get-local-port (socket) + (:documentation "Returns the IP port of the socket. + +This function applies to both `stream-usocket' and `server-stream-usocket' +type objects.")) + +(defgeneric get-peer-port (socket) + (:documentation "Returns the IP port of the peer the socket to.")) + +(defgeneric get-local-name (socket) + (:documentation "Returns the IP address and port of the socket as values. + +This function applies to both `stream-usocket' and `server-stream-usocket' +type objects.")) + +(defgeneric get-peer-name (socket) + (:documentation + "Returns the IP address and port of the peer +the socket is connected to as values.")) + +(defmacro with-connected-socket ((var socket) &body body) + "Bind `socket' to `var', ensuring socket destruction on exit. + +`body' is only evaluated when `var' is bound to a non-null value. + +The `body' is an implied progn form." + `(let ((,var ,socket)) + (unwind-protect + (when ,var + ,@body) + (when ,var + (socket-close ,var))))) + +(defmacro with-client-socket ((socket-var stream-var &rest socket-connect-args) + &body body) + "Bind the socket resulting from a call to `socket-connect' with +the arguments `socket-connect-args' to `socket-var' and if `stream-var' is +non-nil, bind the associated socket stream to it." + `(with-connected-socket (,socket-var (socket-connect ,@socket-connect-args)) + ,(if (null stream-var) + `(progn ,@body) + `(let ((,stream-var (socket-stream ,socket-var))) + ,@body)))) + +(defmacro with-server-socket ((var server-socket) &body body) + "Bind `server-socket' to `var', ensuring socket destruction on exit. + +`body' is only evaluated when `var' is bound to a non-null value. + +The `body' is an implied progn form." + `(with-connected-socket (,var ,server-socket) + ,@body)) + +(defmacro with-socket-listener ((socket-var &rest socket-listen-args) + &body body) + "Bind the socket resulting from a call to `socket-listen' with arguments +`socket-listen-args' to `socket-var'." + `(with-server-socket (,socket-var (socket-listen ,@socket-listen-args)) + ,@body)) + + +;; +;; IP(v4) utility functions +;; + +(defun list-of-strings-to-integers (list) + "Take a list of strings and return a new list of integers (from +parse-integer) on each of the string elements." + (let ((new-list nil)) + (dolist (element (reverse list)) + (push (parse-integer element) new-list)) + new-list)) + +(defun hbo-to-dotted-quad (integer) + "Host-byte-order integer to dotted-quad string conversion utility." + (let ((first (ldb (byte 8 24) integer)) + (second (ldb (byte 8 16) integer)) + (third (ldb (byte 8 8) integer)) + (fourth (ldb (byte 8 0) integer))) + (format nil "~A.~A.~A.~A" first second third fourth))) + +(defun hbo-to-vector-quad (integer) + "Host-byte-order integer to dotted-quad string conversion utility." + (let ((first (ldb (byte 8 24) integer)) + (second (ldb (byte 8 16) integer)) + (third (ldb (byte 8 8) integer)) + (fourth (ldb (byte 8 0) integer))) + (vector first second third fourth))) + +(defun vector-quad-to-dotted-quad (vector) + (format nil "~A.~A.~A.~A" + (aref vector 0) + (aref vector 1) + (aref vector 2) + (aref vector 3))) + +(defun dotted-quad-to-vector-quad (string) + (let ((list (list-of-strings-to-integers (split-sequence:split-sequence #\. string)))) + (vector (first list) (second list) (third list) (fourth list)))) + +(defgeneric host-byte-order (address)) +(defmethod host-byte-order ((string string)) + "Convert a string, such as 192.168.1.1, to host-byte-order, +such as 3232235777." + (let ((list (list-of-strings-to-integers (split-sequence:split-sequence #\. string)))) + (+ (* (first list) 256 256 256) (* (second list) 256 256) + (* (third list) 256) (fourth list)))) + +(defmethod host-byte-order ((vector vector)) + "Convert a vector, such as #(192 168 1 1), to host-byte-order, such as +3232235777." + (+ (* (aref vector 0) 256 256 256) (* (aref vector 1) 256 256) + (* (aref vector 2) 256) (aref vector 3))) + +(defmethod host-byte-order ((int integer)) + int) + +(defun host-to-hostname (host) + "Translate a string or vector quad to a stringified hostname." + (etypecase host + (string host) + ((vector t 4) (vector-quad-to-dotted-quad host)) + (integer (hbo-to-dotted-quad host)))) + +(defun ip= (ip1 ip2) + (etypecase ip1 + (string (string= ip1 (host-to-hostname ip2))) + ((vector t 4) (or (eq ip1 ip2) + (and (= (aref ip1 0) (aref ip2 0)) + (= (aref ip1 1) (aref ip2 1)) + (= (aref ip1 2) (aref ip2 2)) + (= (aref ip1 3) (aref ip2 3))))) + (integer (= ip1 (host-byte-order ip2))))) + +(defun ip/= (ip1 ip2) + (not (ip= ip1 ip2))) + +;; +;; DNS helper functions +;; + +#-(or clisp armedbear) +(progn + (defun get-host-by-name (name) + (let ((hosts (get-hosts-by-name name))) + (car hosts))) + + (defun get-random-host-by-name (name) + (let ((hosts (get-hosts-by-name name))) + (when hosts + (elt hosts (random (length hosts)))))) + + (defun host-to-vector-quad (host) + "Translate a host specification (vector quad, dotted quad or domain name) +to a vector quad." + (etypecase host + (string (let* ((ip (ignore-errors + (dotted-quad-to-vector-quad host)))) + (if (and ip (= 4 (length ip))) + ;; valid IP dotted quad? + ip + (get-random-host-by-name host)))) + ((vector t 4) host) + (integer (hbo-to-vector-quad host)))) + + (defun host-to-hbo (host) + (etypecase host + (string (let ((ip (ignore-errors + (dotted-quad-to-vector-quad host)))) + (if (and ip (= 4 (length ip))) + (host-byte-order ip) + (host-to-hbo (get-host-by-name host))))) + ((vector t 4) (host-byte-order host)) + (integer host)))) + +;; +;; Setting of documentation for backend defined functions +;; + +;; Documentation for the function +;; +;; (defun SOCKET-CONNECT (host port) ..) +;; + +(setf (documentation 'socket-connect 'function) + "Connect to `host' on `port'. `host' is assumed to be a string or +an IP address represented in vector notation, such as #(192 168 1 1). +`port' is assumed to be an integer. + +Returns a usocket object.") + +;; Documentation for the function +;; +;; (defun SOCKET-LISTEN (host port &key reuseaddress backlog element-type) ..) +;;###FIXME: extend with default-element-type +(setf (documentation 'socket-listen 'function) + "Bind to interface `host' on `port'. `host' should be the +representation of an interface address. The implementation is not +required to do an address lookup, making no guarantees that hostnames +will be correctly resolved. If `*wildcard-host*' is passed for `host', +the socket will be bound to all available interfaces for the IPv4 +protocol in the system. `port' can be selected by the IP stack by +passing `*auto-port*'. + +Returns an object of type `stream-server-usocket'. + +`reuse-address' and `backlog' are advisory parameters for setting socket +options at creation time. `element-type' is the element type of the +streams to be created by `socket-accept'. `reuseaddress' is supported for +backward compatibility (but deprecated); when both `reuseaddress' and +`reuse-address' have been specified, the latter takes precedence. +") + +;; Documentation for the function +;; +;; (defun SOCKET-ACCEPT (socket &key element-type) +(setf (documentation 'socket-accept 'function) + "Accepts a connection from `socket', returning a `stream-socket'. + +The stream associated with the socket returned has `element-type' when +explicitly specified, or the element-type passed to `socket-listen' otherwise.")