Author: hhubner Date: 2007-10-04 15:13:23 -0400 (Thu, 04 Oct 2007) New Revision: 2205

Added: branches/trunk-reorg/thirdparty/puri-1.5.1/ branches/trunk-reorg/thirdparty/puri-1.5.1/LICENSE branches/trunk-reorg/thirdparty/puri-1.5.1/README branches/trunk-reorg/thirdparty/puri-1.5.1/puri.asd branches/trunk-reorg/thirdparty/puri-1.5.1/src.lisp branches/trunk-reorg/thirdparty/puri-1.5.1/tests.lisp branches/trunk-reorg/thirdparty/puri-1.5.1/uri.html branches/trunk-reorg/thirdparty/trivial-gray-streams-2006-09-16/ branches/trunk-reorg/thirdparty/trivial-gray-streams-2006-09-16/COPYING branches/trunk-reorg/thirdparty/trivial-gray-streams-2006-09-16/CVS/ branches/trunk-reorg/thirdparty/trivial-gray-streams-2006-09-16/CVS/Entries branches/trunk-reorg/thirdparty/trivial-gray-streams-2006-09-16/CVS/Repository branches/trunk-reorg/thirdparty/trivial-gray-streams-2006-09-16/CVS/Root branches/trunk-reorg/thirdparty/trivial-gray-streams-2006-09-16/Makefile branches/trunk-reorg/thirdparty/trivial-gray-streams-2006-09-16/README branches/trunk-reorg/thirdparty/trivial-gray-streams-2006-09-16/mixin.lisp branches/trunk-reorg/thirdparty/trivial-gray-streams-2006-09-16/package.lisp branches/trunk-reorg/thirdparty/trivial-gray-streams-2006-09-16/trivial-gray-streams.asd Log: updating

Added: branches/trunk-reorg/thirdparty/puri-1.5.1/LICENSE =================================================================== --- branches/trunk-reorg/thirdparty/puri-1.5.1/LICENSE 2007-10-04 19:10:49 UTC (rev 2204) +++ branches/trunk-reorg/thirdparty/puri-1.5.1/LICENSE 2007-10-04 19:13:23 UTC (rev 2205) @@ -0,0 +1,574 @@ +Copyright (c) 1999-2001 Franz, Inc. +Copyright (c) 2003 Kevin Rosenberg +All rights reserved. + +PURI is licensed under the terms of the Lisp Lesser GNU Public +License, known as the LLGPL. The LLGPL consists of a preamble (see +below) and the Lessor GNU Public License 2.1 (LGPL-2.1). Where these +conflict, the preamble takes precedence. PURI is referenced in the +preamble as the "LIBRARY." + +PURI 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. + + + +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. + + + + 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. +^L + 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. +^L + 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. +^L + 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. +^L + 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. +^L + 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. +^L + 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. +^L + 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 +^L + 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 +

Added: branches/trunk-reorg/thirdparty/puri-1.5.1/README =================================================================== --- branches/trunk-reorg/thirdparty/puri-1.5.1/README 2007-10-04 19:10:49 UTC (rev 2204) +++ branches/trunk-reorg/thirdparty/puri-1.5.1/README 2007-10-04 19:13:23 UTC (rev 2205) @@ -0,0 +1,46 @@ +PURI - Portable URI Library +=========================== + +AUTHORS +------- +Franz, Inc http://www.franz.com +Kevin Rosenberg kevin@rosenberg.net + + +DOWNLOAD +-------- +Puri home: http://files.b9.com/puri/ +Portable tester home: http://files.b9.com/tester/ + + +SUPPORTED PLATFORMS +------------------- + AllegroCL, CLISP, CMUCL, Lispworks, OpenMCL, SBCL + + +OVERVIEW +-------- +This is portable Universal Resource Identifier library for Common Lisp +programs. It parses URI according to the RFC 2396 specification. It's +is based on Franz, Inc's opensource URI package and has been ported to +work other CL implementations. It is licensed under the LLGPL which +is included in this distribution. + +A regression suite is included which uses Franz's open-source tester +library. I've ported that library for use on other CL +implementations. Puri completes 126/126 regression tests successfully. + +Franz's unmodified documentation file is included in the file +uri.html. + + +DIFFERENCES BETWEEN PURI and NET.URI +------------------------------------ + +* Puri uses the package 'puri while NET.URI uses the package 'net.uri + +* To signal an error parsing a URI, Puri uses the condition + :uri-parse-error while NET.URI uses the condition :parse-error. This + divergence occurs because Franz's parse-error condition uses + :format-control and :format-arguments slots which are not in the ANSI + specification for the parse-error condition.

Added: branches/trunk-reorg/thirdparty/puri-1.5.1/puri.asd =================================================================== --- branches/trunk-reorg/thirdparty/puri-1.5.1/puri.asd 2007-10-04 19:10:49 UTC (rev 2204) +++ branches/trunk-reorg/thirdparty/puri-1.5.1/puri.asd 2007-10-04 19:13:23 UTC (rev 2205) @@ -0,0 +1,33 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; Programmer: Kevin Rosenberg + + +(in-package #:cl-user) +(defpackage #:puri-system (:use #:cl #:asdf)) +(in-package #:puri-system) + + +(defsystem puri + :name "cl-puri" + :maintainer "Kevin M. Rosenberg kmr@debian.org" + :licence "GNU Lesser General Public License" + :description "Portable Universal Resource Indentifier Library" + :components + ((:file "src"))) + +(defmethod perform ((o test-op) (c (eql (find-system 'puri)))) + (oos 'load-op 'puri-tests) + (oos 'test-op 'puri-tests)) + +(defsystem puri-tests + :depends-on (:puri :ptester) + :components + ((:file "tests"))) + +(defmethod perform ((o test-op) (c (eql (find-system 'puri-tests)))) + (or (funcall (intern (symbol-name '#:do-tests) + (find-package :puri-tests))) + (error "test-op failed"))) + +(defmethod operation-done-p ((o test-op) (c (eql (find-system 'puri-tests)))) + (values nil))

Added: branches/trunk-reorg/thirdparty/puri-1.5.1/src.lisp =================================================================== --- branches/trunk-reorg/thirdparty/puri-1.5.1/src.lisp 2007-10-04 19:10:49 UTC (rev 2204) +++ branches/trunk-reorg/thirdparty/puri-1.5.1/src.lisp 2007-10-04 19:13:23 UTC (rev 2205) @@ -0,0 +1,1419 @@ +;; -*- mode: common-lisp; package: puri -*- +;; Support for URIs +;; For general URI information see RFC2396. +;; +;; copyright (c) 1999-2002 Franz Inc, Berkeley, CA - All rights reserved. +;; copyright (c) 2002-2005 Franz Inc, Oakland, CA - All rights reserved. +;; copyright (c) 2003-2006 Kevin Rosenberg (porting changes) +;; +;; This code is free software; you can redistribute it and/or +;; modify it under the terms of the version 2.1 of +;; the GNU Lesser General Public License as published by +;; the Free Software Foundation, as clarified by the +;; preamble found here: +;; http://opensource.franz.com/preamble.html +;; +;; Versions ported from Franz's opensource release +;; uri.cl,v 2.3.6.4.2.1 2001/08/09 17:42:39 layer +;; uri.cl,v 2.9.84.1 2005/08/11 18:38:52 layer + +;; This code 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. +;; +;; $Id: src.lisp 11328 2006-12-02 15:43:07Z kevin $ + +(defpackage #:puri + (:use #:cl) + #-allegro (:nicknames #:net.uri) + (:export + #:uri ; the type and a function + #:uri-p + #:copy-uri + + #:uri-scheme ; and slots + #:uri-host #:uri-port + #:uri-path + #:uri-query + #:uri-fragment + #:uri-plist + #:uri-authority ; pseudo-slot accessor + + #:urn ; class + #:urn-nid ; pseudo-slot accessor + #:urn-nss ; pseudo-slot accessor + + #:*strict-parse* + #:parse-uri + #:merge-uris + #:enough-uri + #:uri-parsed-path + #:render-uri + + #:make-uri-space ; interning... + #:uri-space + #:uri= + #:intern-uri + #:unintern-uri + #:do-all-uris + + #:uri-parse-error ;; Added by KMR + )) + +(in-package #:puri) + +(eval-when (:compile-toplevel) (declaim (optimize (speed 3)))) + + +#-allegro +(defun parse-body (forms &optional env) + "Parses a body, returns (VALUES docstring declarations forms)" + (declare (ignore env)) + ;; fixme -- need to add parsing of multiple declarations + (let (docstring declarations) + (when (stringp (car forms)) + (setq docstring (car forms)) + (setq forms (cdr forms))) + (when (and (listp (car forms)) + (symbolp (caar forms)) + (string-equal (symbol-name '#:declare) + (symbol-name (caar forms)))) + (setq declarations (car forms)) + (setq forms (cdr forms))) + (values docstring declarations forms))) + + +(defun shrink-vector (str size) + #+allegro + (excl::.primcall 'sys::shrink-svector str size) + #+sbcl + (setq str (sb-kernel:shrink-vector str size)) + #+cmu + (lisp::shrink-vector str size) + #+lispworks + (system::shrink-vector$vector str size) + #+scl + (common-lisp::shrink-vector str size) + #-(or allegro cmu lispworks sbcl scl) + (setq str (subseq str 0 size)) + str) + + +;; KMR: Added new condition to handle cross-implementation variances +;; in the parse-error condition many implementations define + +(define-condition uri-parse-error (parse-error) + ((fmt-control :initarg :fmt-control :accessor fmt-control) + (fmt-arguments :initarg :fmt-arguments :accessor fmt-arguments )) + (:report (lambda (c stream) + (format stream "Parse error:") + (apply #'format stream (fmt-control c) (fmt-arguments c))))) + +(defun .parse-error (fmt &rest args) + (error 'uri-parse-error :fmt-control fmt :fmt-arguments args)) + +#-allegro +(defun internal-reader-error (stream fmt &rest args) + (apply #'format stream fmt args)) + +#-allegro (defvar *current-case-mode* :case-insensitive-upper) +#+allegro (eval-when (:compile-toplevel :load-toplevel :execute) + (import '(excl:*current-case-mode* + excl:delimited-string-to-list + excl::parse-body + excl::internal-reader-error + excl:if*))) + +#-allegro +(defmethod position-char (char (string string) start max) + (declare (optimize (speed 3) (safety 0) (space 0)) + (fixnum start max) (string string)) + (do* ((i start (1+ i))) + ((= i max) nil) + (declare (fixnum i)) + (when (char= char (char string i)) (return i)))) + +#-allegro +(defun delimited-string-to-list (string &optional (separator #\space) + skip-terminal) + (declare (optimize (speed 3) (safety 0) (space 0) + (compilation-speed 0)) + (type string string) + (type character separator)) + (do* ((len (length string)) + (output '()) + (pos 0) + (end (position-char separator string pos len) + (position-char separator string pos len))) + ((null end) + (if (< pos len) + (push (subseq string pos) output) + (when (and (plusp len) (not skip-terminal)) + (push "" output))) + (nreverse output)) + (declare (type fixnum pos len) + (type (or null fixnum) end)) + (push (subseq string pos end) output) + (setq pos (1+ end)))) + +#-allegro +(eval-when (:compile-toplevel :load-toplevel :execute) + (defvar if*-keyword-list '("then" "thenret" "else" "elseif")) + + (defmacro if* (&rest args) + (do ((xx (reverse args) (cdr xx)) + (state :init) + (elseseen nil) + (totalcol nil) + (lookat nil nil) + (col nil)) + ((null xx) + (cond ((eq state :compl) + `(cond ,@totalcol)) + (t (error "if*: illegal form ~s" args)))) + (cond ((and (symbolp (car xx)) + (member (symbol-name (car xx)) + if*-keyword-list + :test #'string-equal)) + (setq lookat (symbol-name (car xx))))) + + (cond ((eq state :init) + (cond (lookat (cond ((string-equal lookat "thenret") + (setq col nil + state :then)) + (t (error + "if*: bad keyword ~a" lookat)))) + (t (setq state :col + col nil) + (push (car xx) col)))) + ((eq state :col) + (cond (lookat + (cond ((string-equal lookat "else") + (cond (elseseen + (error + "if*: multiples elses"))) + (setq elseseen t) + (setq state :init) + (push `(t ,@col) totalcol)) + ((string-equal lookat "then") + (setq state :then)) + (t (error "if*: bad keyword ~s" + lookat)))) + (t (push (car xx) col)))) + ((eq state :then) + (cond (lookat + (error + "if*: keyword ~s at the wrong place " (car xx))) + (t (setq state :compl) + (push `(,(car xx) ,@col) totalcol)))) + ((eq state :compl) + (cond ((not (string-equal lookat "elseif")) + (error "if*: missing elseif clause "))) + (setq state :init)))))) + + +(defclass uri () + ( +;;;; external: + (scheme :initarg :scheme :initform nil :accessor uri-scheme) + (host :initarg :host :initform nil :accessor uri-host) + (port :initarg :port :initform nil :accessor uri-port) + (path :initarg :path :initform nil :accessor uri-path) + (query :initarg :query :initform nil :accessor uri-query) + (fragment :initarg :fragment :initform nil :accessor uri-fragment) + (plist :initarg :plist :initform nil :accessor uri-plist) + +;;;; internal: + (escaped + ;; used to prevent unnessary work, looking for chars to escape and + ;; unescape. + :initarg :escaped :initform nil :accessor uri-escaped) + (string + ;; the cached printable representation of the URI. It *might* be + ;; different than the original string, though, because the user might + ;; have escaped non-reserved chars--they won't be escaped when the URI + ;; is printed. + :initarg :string :initform nil :accessor uri-string) + (parsed-path + ;; the cached parsed representation of the URI path. + :initarg :parsed-path + :initform nil + :accessor .uri-parsed-path) + (hashcode + ;; cached sxhash, so we don't have to compute it more than once. + :initarg :hashcode :initform nil :accessor uri-hashcode))) + +(defclass urn (uri) + ((nid :initarg :nid :initform nil :accessor urn-nid) + (nss :initarg :nss :initform nil :accessor urn-nss))) + +(eval-when (:compile-toplevel :execute) + (defmacro clear-caching-on-slot-change (name) + `(defmethod (setf ,name) :around (new-value (self uri)) + (declare (ignore new-value)) + (prog1 (call-next-method) + (setf (uri-string self) nil) + ,@(when (eq name 'uri-path) `((setf (.uri-parsed-path self) nil))) + (setf (uri-hashcode self) nil)))) + ) + +(clear-caching-on-slot-change uri-scheme) +(clear-caching-on-slot-change uri-host) +(clear-caching-on-slot-change uri-port) +(clear-caching-on-slot-change uri-path) +(clear-caching-on-slot-change uri-query) +(clear-caching-on-slot-change uri-fragment) + + +(defmethod make-load-form ((self uri) &optional env) + (declare (ignore env)) + `(make-instance ',(class-name (class-of self)) + :scheme ,(uri-scheme self) + :host ,(uri-host self) + :port ,(uri-port self) + :path ',(uri-path self) + :query ,(uri-query self) + :fragment ,(uri-fragment self) + :plist ',(uri-plist self) + :string ,(uri-string self) + :parsed-path ',(.uri-parsed-path self))) + +(defmethod uri-p ((thing uri)) t) +(defmethod uri-p ((thing t)) nil) + +(defun copy-uri (uri + &key place + (scheme (when uri (uri-scheme uri))) + (host (when uri (uri-host uri))) + (port (when uri (uri-port uri))) + (path (when uri (uri-path uri))) + (parsed-path + (when uri (copy-list (.uri-parsed-path uri)))) + (query (when uri (uri-query uri))) + (fragment (when uri (uri-fragment uri))) + (plist (when uri (copy-list (uri-plist uri)))) + (class (when uri (class-of uri))) + &aux (escaped (when uri (uri-escaped uri)))) + (if* place + then (setf (uri-scheme place) scheme) + (setf (uri-host place) host) + (setf (uri-port place) port) + (setf (uri-path place) path) + (setf (.uri-parsed-path place) parsed-path) + (setf (uri-query place) query) + (setf (uri-fragment place) fragment) + (setf (uri-plist place) plist) + (setf (uri-escaped place) escaped) + (setf (uri-string place) nil) + (setf (uri-hashcode place) nil) + place + elseif (eq 'uri class) + then ;; allow the compiler to optimize the call to make-instance: + (make-instance 'uri + :scheme scheme :host host :port port :path path + :parsed-path parsed-path + :query query :fragment fragment :plist plist + :escaped escaped :string nil :hashcode nil) + else (make-instance class + :scheme scheme :host host :port port :path path + :parsed-path parsed-path + :query query :fragment fragment :plist plist + :escaped escaped :string nil :hashcode nil))) + +(defmethod uri-parsed-path ((uri uri)) + (when (uri-path uri) + (when (null (.uri-parsed-path uri)) + (setf (.uri-parsed-path uri) + (parse-path (uri-path uri) (uri-escaped uri)))) + (.uri-parsed-path uri))) + +(defmethod (setf uri-parsed-path) (path-list (uri uri)) + (assert (and (consp path-list) + (or (member (car path-list) '(:absolute :relative) + :test #'eq)))) + (setf (uri-path uri) (render-parsed-path path-list t)) + (setf (.uri-parsed-path uri) path-list) + path-list) + +(defun uri-authority (uri) + (when (uri-host uri) + (let ((*print-pretty* nil)) + (format nil "~a~@[:~a~]" (uri-host uri) (uri-port uri))))) + +(defun uri-nid (uri) + (if* (equalp "urn" (uri-scheme uri)) + then (uri-host uri) + else (error "URI is not a URN: ~s." uri))) + +(defun uri-nss (uri) + (if* (equalp "urn" (uri-scheme uri)) + then (uri-path uri) + else (error "URI is not a URN: ~s." uri))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Parsing + +(defparameter *excluded-characters* + '(;; `delims' (except #%, because it's handled specially): + #< #> #" #\space ## + ;; `unwise': + #{ #} #| #\ #^ #[ #] #`)) + +(defun reserved-char-vector (chars &key except) + (do* ((a (make-array 127 :element-type 'bit :initial-element 0)) + (chars chars (cdr chars)) + (c (car chars) (car chars))) + ((null chars) a) + (if* (and except (member c except :test #'char=)) + thenret + else (setf (sbit a (char-int c)) 1)))) + +(defparameter *reserved-characters* + (reserved-char-vector + (append *excluded-characters* + '(#; #/ #? #: #@ #& #= #+ #$ #, #%)))) +(defparameter *reserved-authority-characters* + (reserved-char-vector + (append *excluded-characters* '(#; #/ #? #: #@)))) +(defparameter *reserved-path-characters* + (reserved-char-vector + (append *excluded-characters* + '(#; +;;;;The rfc says this should be here, but it doesn't make sense. + ;; #= + #/ #?)))) + +(defparameter *reserved-fragment-characters* + (reserved-char-vector (remove ## *excluded-characters*))) + +(eval-when (:compile-toplevel :execute) +(defun gen-char-range-list (start end) + (do* ((res '()) + (endcode (1+ (char-int end))) + (chcode (char-int start) + (1+ chcode)) + (hyphen nil)) + ((= chcode endcode) + ;; - has to be first, otherwise it signifies a range! + (if* hyphen + then (setq res (nreverse res)) + (push #- res) + res + else (nreverse res))) + (if* (= #.(char-int #-) chcode) + then (setq hyphen t) + else (push (code-char chcode) res)))) +) + +(defparameter *valid-nid-characters* + (reserved-char-vector + '#.(nconc (gen-char-range-list #\a #\z) + (gen-char-range-list #\A #\Z) + (gen-char-range-list #\0 #\9) + '(#- #. #+)))) +(defparameter *reserved-nss-characters* + (reserved-char-vector + (append *excluded-characters* '(#& #~ #/ #?)))) + +(defparameter *illegal-characters* + (reserved-char-vector (remove ## *excluded-characters*))) +(defparameter *strict-illegal-query-characters* + (reserved-char-vector (append '(#?) (remove ## *excluded-characters*)))) +(defparameter *illegal-query-characters* + (reserved-char-vector + *excluded-characters* :except '(#^ #| ##))) + + +(defun parse-uri (thing &key (class 'uri) &aux escape) + (when (uri-p thing) (return-from parse-uri thing)) + + (setq escape (escape-p thing)) + (multiple-value-bind (scheme host port path query fragment) + (parse-uri-string thing) + (when scheme + (setq scheme + (intern (funcall + (case *current-case-mode* + ((:case-insensitive-upper :case-sensitive-upper) + #'string-upcase) + ((:case-insensitive-lower :case-sensitive-lower) + #'string-downcase)) + (decode-escaped-encoding scheme escape)) + (find-package :keyword)))) + + (when (and scheme (eq :urn scheme)) + (return-from parse-uri + (make-instance 'urn :scheme scheme :nid host :nss path))) + + (when host (setq host (decode-escaped-encoding host escape))) + (when port + (setq port (read-from-string port)) + (when (not (numberp port)) (error "port is not a number: ~s." port)) + (when (not (plusp port)) + (error "port is not a positive integer: ~d." port)) + (when (eql port (case scheme + (:http 80) + (:https 443) + (:ftp 21) + (:telnet 23))) + (setq port nil))) + (when (or (string= "" path) + (and ;; we canonicalize away a reference to just /: + scheme + (member scheme '(:http :https :ftp) :test #'eq) + (string= "/" path))) + (setq path nil)) + (when path + (setq path + (decode-escaped-encoding path escape *reserved-path-characters*))) + (when query (setq query (decode-escaped-encoding query escape))) + (when fragment + (setq fragment + (decode-escaped-encoding fragment escape + *reserved-fragment-characters*))) + (if* (eq 'uri class) + then ;; allow the compiler to optimize the make-instance call: + (make-instance 'uri + :scheme scheme + :host host + :port port + :path path + :query query + :fragment fragment + :escaped escape) + else ;; do it the slow way: + (make-instance class + :scheme scheme + :host host + :port port + :path path + :query query + :fragment fragment + :escaped escape)))) + +(defmethod uri ((thing uri)) + thing) + +(defmethod uri ((thing string)) + (parse-uri thing)) + +(defmethod uri ((thing t)) + (error "Cannot coerce ~s to a uri." thing)) + +(defvar *strict-parse* t) + +(defun parse-uri-string (string &aux (illegal-chars *illegal-characters*)) + (declare (optimize (speed 3))) + ;; Speed is important, so use a specialized state machine instead of + ;; regular expressions for parsing the URI string. The regexp we are + ;; simulating: + ;; ^(([^:/?#]+):)? + ;; (//([^/?#]*))? + ;; ([^?#]*) + ;; (?([^#]*))? + ;; (#(.*))? + (let* ((state 0) + (start 0) + (end (length string)) + (tokval nil) + (scheme nil) + (host nil) + (port nil) + (path-components '()) + (query nil) + (fragment nil) + ;; namespace identifier, for urn parsing only: + (nid nil)) + (declare (fixnum state start end)) + (flet ((read-token (kind &optional legal-chars) + (setq tokval nil) + (if* (>= start end) + then :end + else (let ((sindex start) + (res nil) + c) + (declare (fixnum sindex)) + (setq res + (loop + (when (>= start end) (return nil)) + (setq c (char string start)) + (let ((ci (char-int c))) + (if* legal-chars + then (if* (and (eq :colon kind) (eq c #:)) + then (return :colon) + elseif (= 0 (sbit legal-chars ci)) + then (.parse-error + "~ +URI ~s contains illegal character ~s at position ~d." + string c start)) + elseif (and (< ci 128) + *strict-parse* + (= 1 (sbit illegal-chars ci))) + then (.parse-error "~ +URI ~s contains illegal character ~s at position ~d." + string c start))) + (case kind + (:path (case c + (#? (return :question)) + (## (return :hash)))) + (:query (case c (## (return :hash)))) + (:rest) + (t (case c + (#: (return :colon)) + (#? (return :question)) + (## (return :hash)) + (#/ (return :slash))))) + (incf start))) + (if* (> start sindex) + then ;; we found some chars + ;; before we stopped the parse + (setq tokval (subseq string sindex start)) + :string + else ;; immediately stopped at a special char + (incf start) + res)))) + (failure (&optional why) + (.parse-error "illegal URI: ~s [~d]~@[: ~a~]" + string state why)) + (impossible () + (.parse-error "impossible state: ~d [~s]" state string))) + (loop + (case state + (0 ;; starting to parse + (ecase (read-token t) + (:colon (failure)) + (:question (setq state 7)) + (:hash (setq state 8)) + (:slash (setq state 3)) + (:string (setq state 1)) + (:end (setq state 9)))) + (1 ;; seen <token><special char> + (let ((token tokval)) + (ecase (read-token t) + (:colon (setq scheme token) + (if* (equalp "urn" scheme) + then (setq state 15) + else (setq state 2))) + (:question (push token path-components) + (setq state 7)) + (:hash (push token path-components) + (setq state 8)) + (:slash (push token path-components) + (push "/" path-components) + (setq state 6)) + (:string (failure)) + (:end (push token path-components) + (setq state 9))))) + (2 ;; seen <scheme>: + (ecase (read-token t) + (:colon (failure)) + (:question (setq state 7)) + (:hash (setq state 8)) + (:slash (setq state 3)) + (:string (setq state 10)) + (:end (setq state 9)))) + (10 ;; seen <scheme>:<token> + (let ((token tokval)) + (ecase (read-token t) + (:colon (failure)) + (:question (push token path-components) + (setq state 7)) + (:hash (push token path-components) + (setq state 8)) + (:slash (push token path-components) + (setq state 6)) + (:string (failure)) + (:end (push token path-components) + (setq state 9))))) + (3 ;; seen / or <scheme>:/ + (ecase (read-token t) + (:colon (failure)) + (:question (push "/" path-components) + (setq state 7)) + (:hash (push "/" path-components) + (setq state 8)) + (:slash (setq state 4)) + (:string (push "/" path-components) + (push tokval path-components) + (setq state 6)) + (:end (push "/" path-components) + (setq state 9)))) + (4 ;; seen [<scheme>:]// + (ecase (read-token t) + (:colon (failure)) + (:question (failure)) + (:hash (failure)) + (:slash + (if* (and (equalp "file" scheme) + (null host)) + then ;; file:///... + (push "/" path-components) + (setq state 6) + else (failure))) + (:string (setq host tokval) + (setq state 11)) + (:end (failure)))) + (11 ;; seen [<scheme>:]//<host> + (ecase (read-token t) + (:colon (setq state 5)) + (:question (setq state 7)) + (:hash (setq state 8)) + (:slash (push "/" path-components) + (setq state 6)) + (:string (impossible)) + (:end (setq state 9)))) + (5 ;; seen [<scheme>:]//<host>: + (ecase (read-token t) + (:colon (failure)) + (:question (failure)) + (:hash (failure)) + (:slash (push "/" path-components) + (setq state 6)) + (:string (setq port tokval) + (setq state 12)) + (:end (failure)))) + (12 ;; seen [<scheme>:]//<host>:[<port>] + (ecase (read-token t) + (:colon (failure)) + (:question (setq state 7)) + (:hash (setq state 8)) + (:slash (push "/" path-components) + (setq state 6)) + (:string (impossible)) + (:end (setq state 9)))) + (6 ;; seen / + (ecase (read-token :path) + (:question (setq state 7)) + (:hash (setq state 8)) + (:string (push tokval path-components) + (setq state 13)) + (:end (setq state 9)))) + (13 ;; seen path + (ecase (read-token :path) + (:question (setq state 7)) + (:hash (setq state 8)) + (:string (impossible)) + (:end (setq state 9)))) + (7 ;; seen ? + (setq illegal-chars + (if* *strict-parse* + then *strict-illegal-query-characters* + else *illegal-query-characters*)) + (ecase (prog1 (read-token :query) + (setq illegal-chars *illegal-characters*)) + (:hash (setq state 8)) + (:string (setq query tokval) + (setq state 14)) + (:end (setq state 9)))) + (14 ;; query + (ecase (read-token :query) + (:hash (setq state 8)) + (:string (impossible)) + (:end (setq state 9)))) + (8 ;; seen # + (ecase (read-token :rest) + (:string (setq fragment tokval) + (setq state 9)) + (:end (setq state 9)))) + (9 ;; done + (return + (values + scheme host port + (apply #'concatenate 'string (nreverse path-components)) + query fragment))) + ;; URN parsing: + (15 ;; seen urn:, read nid now + (case (read-token :colon *valid-nid-characters*) + (:string (setq nid tokval) + (setq state 16)) + (t (failure "missing namespace identifier")))) + (16 ;; seen urn:<nid> + (case (read-token t) + (:colon (setq state 17)) + (t (failure "missing namespace specific string")))) + (17 ;; seen urn:<nid>:, rest is nss + (return (values scheme + nid + nil + (progn + (setq illegal-chars *reserved-nss-characters*) + (read-token :rest) + tokval)))) + (t (.parse-error + "internal error in parse engine, wrong state: ~s." state))))))) + +(defun escape-p (string) + (declare (optimize (speed 3))) + (do* ((i 0 (1+ i)) + (max (the fixnum (length string)))) + ((= i max) nil) + (declare (fixnum i max)) + (when (char= #% (char string i)) + (return t)))) + +(defun parse-path (path-string escape) + (do* ((xpath-list (delimited-string-to-list path-string #/)) + (path-list + (progn + (if* (string= "" (car xpath-list)) + then (setf (car xpath-list) :absolute) + else (push :relative xpath-list)) + xpath-list)) + (pl (cdr path-list) (cdr pl)) + segments) + ((null pl) path-list) + + (if* (cdr (setq segments + (if* (string= "" (car pl)) + then '("") + else (delimited-string-to-list (car pl) #;)))) + then ;; there is a param + (setf (car pl) + (mapcar #'(lambda (s) + (decode-escaped-encoding s escape + ;; decode all %xx: + nil)) + segments)) + else ;; no param + (setf (car pl) + (decode-escaped-encoding (car segments) escape + ;; decode all %xx: + nil))))) + +(defun decode-escaped-encoding (string escape + &optional (reserved-chars + *reserved-characters*)) + ;; Return a string with the real characters. + (when (null escape) (return-from decode-escaped-encoding string)) + (do* ((i 0 (1+ i)) + (max (length string)) + (new-string (copy-seq string)) + (new-i 0 (1+ new-i)) + ch ch2 chc chc2) + ((= i max) + (shrink-vector new-string new-i)) + (if* (char= #% (setq ch (char string i))) + then (when (> (+ i 3) max) + (.parse-error + "Unsyntactic escaped encoding in ~s." string)) + (setq ch (char string (incf i))) + (setq ch2 (char string (incf i))) + (when (not (and (setq chc (digit-char-p ch 16)) + (setq chc2 (digit-char-p ch2 16)))) + (.parse-error + "Non-hexidecimal digits after %: %c%c." ch ch2)) + (let ((ci (+ (* 16 chc) chc2))) + (if* (or (null reserved-chars) + (> ci 127) ; bug11527 + (= 0 (sbit reserved-chars ci))) + then ;; ok as is + (setf (char new-string new-i) + (code-char ci)) + else (setf (char new-string new-i) #%) + (setf (char new-string (incf new-i)) ch) + (setf (char new-string (incf new-i)) ch2))) + else (setf (char new-string new-i) ch)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; Printing + +(defun render-uri (uri stream + &aux (escape (uri-escaped uri)) + (*print-pretty* nil)) + (when (null (uri-string uri)) + (setf (uri-string uri) + (let ((scheme (uri-scheme uri)) + (host (uri-host uri)) + (port (uri-port uri)) + (path (uri-path uri)) + (query (uri-query uri)) + (fragment (uri-fragment uri))) + (concatenate 'string + (when scheme + (encode-escaped-encoding + (string-downcase ;; for upper case lisps + (symbol-name scheme)) + *reserved-characters* escape)) + (when scheme ":") + (when (or host (eq :file scheme)) "//") + (when host + (encode-escaped-encoding + host *reserved-authority-characters* escape)) + (when port ":") + (when port + #-allegro (format nil "~D" port) + #+allegro (with-output-to-string (s) + (excl::maybe-print-fast s port)) + ) + (when path + (encode-escaped-encoding path + nil + ;;*reserved-path-characters* + escape)) + (when query "?") + (when query (encode-escaped-encoding query nil escape)) + (when fragment "#") + (when fragment (encode-escaped-encoding fragment nil escape)))))) + (if* stream + then (format stream "~a" (uri-string uri)) + else (uri-string uri))) + +(defun render-parsed-path (path-list escape) + (do* ((res '()) + (first (car path-list)) + (pl (cdr path-list) (cdr pl)) + (pe (car pl) (car pl))) + ((null pl) + (when res (apply #'concatenate 'string (nreverse res)))) + (when (or (null first) + (prog1 (eq :absolute first) + (setq first nil))) + (push "/" res)) + (if* (atom pe) + then (push + (encode-escaped-encoding pe *reserved-path-characters* escape) + res) + else ;; contains params + (push (encode-escaped-encoding + (car pe) *reserved-path-characters* escape) + res) + (dolist (item (cdr pe)) + (push ";" res) + (push (encode-escaped-encoding + item *reserved-path-characters* escape) + res))))) + +(defun render-urn (urn stream + &aux (*print-pretty* nil)) + (when (null (uri-string urn)) + (setf (uri-string urn) + (let ((nid (urn-nid urn)) + (nss (urn-nss urn))) + (concatenate 'string "urn:" nid ":" nss)))) + (if* stream + then (format stream "~a" (uri-string urn)) + else (uri-string urn))) + +(defparameter *escaped-encoding* + (vector #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\a #\b #\c #\d #\e #\f)) + +(defun encode-escaped-encoding (string reserved-chars escape) + (when (null escape) (return-from encode-escaped-encoding string)) + ;; Make a string as big as it possibly needs to be (3 times the original + ;; size), and truncate it at the end. + (do* ((max (length string)) + (new-max (* 3 max)) ;; worst case new size + (new-string (make-string new-max)) + (i 0 (1+ i)) + (new-i -1) + c ci) + ((= i max) + (shrink-vector new-string (incf new-i))) + (setq ci (char-int (setq c (char string i)))) + (if* (or (null reserved-chars) + (> ci 127) + (= 0 (sbit reserved-chars ci))) + then ;; ok as is + (incf new-i) + (setf (char new-string new-i) c) + else ;; need to escape it + (multiple-value-bind (q r) (truncate ci 16) + (setf (char new-string (incf new-i)) #%) + (setf (char new-string (incf new-i)) (elt *escaped-encoding* q)) + (setf (char new-string (incf new-i)) + (elt *escaped-encoding* r)))))) + +(defmethod print-object ((uri uri) stream) + (if* *print-escape* + then (print-unreadable-object (uri stream :type t) (render-uri uri stream)) + else (render-uri uri stream))) + +(defmethod print-object ((urn urn) stream) + (if* *print-escape* + then (print-unreadable-object (urn stream :type t) (render-urn urn stream)) + else (render-urn urn stream))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; merging and unmerging + +(defmethod merge-uris ((uri string) (base string) &optional place) + (merge-uris (parse-uri uri) (parse-uri base) place)) + +(defmethod merge-uris ((uri uri) (base string) &optional place) + (merge-uris uri (parse-uri base) place)) + +(defmethod merge-uris ((uri string) (base uri) &optional place) + (merge-uris (parse-uri uri) base place)) + + +(defmethod merge-uris ((uri uri) (base uri) &optional place) + ;; See ../doc/rfc2396.txt for info on the algorithm we use to merge + ;; URIs. + ;; + (tagbody +;;;; step 2 + (when (and (null (uri-parsed-path uri)) + (null (uri-scheme uri)) + (null (uri-host uri)) + (null (uri-port uri)) + (null (uri-query uri))) + (return-from merge-uris + (let ((new (copy-uri base :place place))) + (when (uri-query uri) + (setf (uri-query new) (uri-query uri))) + (when (uri-fragment uri) + (setf (uri-fragment new) (uri-fragment uri))) + new))) + + (setq uri (copy-uri uri :place place)) + +;;;; step 3 + (when (uri-scheme uri) + (return-from merge-uris uri)) + (setf (uri-scheme uri) (uri-scheme base)) + +;;;; step 4 + (when (uri-host uri) (go :done)) + (setf (uri-host uri) (uri-host base)) + (setf (uri-port uri) (uri-port base)) + +;;;; step 5 + (let ((p (uri-parsed-path uri))) + + ;; bug13133: + ;; The following form causes our implementation to be at odds with + ;; RFC 2396, however this is apparently what was intended by the + ;; authors of the RFC. Specifically, (merge-uris "?y" "/foo") + ;; should return #<uri /foo?y> instead of #<uri ?y>, according to + ;; this: +;;; http://www.apache.org/~fielding/uri/rev-2002/issues.html#003-relative-query + (when (null p) + (setf (uri-path uri) (uri-path base)) + (go :done)) + + (when (and p (eq :absolute (car p))) + (when (equal '(:absolute "") p) + ;; Canonicalize the way parsing does: + (setf (uri-path uri) nil)) + (go :done))) + +;;;; step 6 + (let* ((base-path + (or (uri-parsed-path base) + ;; needed because we canonicalize away a path of just `/': + '(:absolute ""))) + (path (uri-parsed-path uri)) + new-path-list) + (when (not (eq :absolute (car base-path))) + (error "Cannot merge ~a and ~a, since latter is not absolute." + uri base)) + + ;; steps 6a and 6b: + (setq new-path-list + (append (butlast base-path) + (if* path then (cdr path) else '("")))) + + ;; steps 6c and 6d: + (let ((last (last new-path-list))) + (if* (atom (car last)) + then (when (string= "." (car last)) + (setf (car last) "")) + else (when (string= "." (caar last)) + (setf (caar last) "")))) + (setq new-path-list + (delete "." new-path-list :test #'(lambda (a b) + (if* (atom b) + then (string= a b) + else nil)))) + + ;; steps 6e and 6f: + (let ((npl (cdr new-path-list)) + index tmp fix-tail) + (setq fix-tail + (string= ".." (let ((l (car (last npl)))) + (if* (atom l) + then l + else (car l))))) + (loop + (setq index + (position ".." npl + :test #'(lambda (a b) + (string= a + (if* (atom b) + then b + else (car b)))))) + (when (null index) (return)) + (when (= 0 index) + ;; The RFC says, in 6g, "that the implementation may handle + ;; this error by retaining these components in the resolved + ;; path, by removing them from the resolved path, or by + ;; avoiding traversal of the reference." The examples in C.2 + ;; imply that we should do the first thing (retain them), so + ;; that's what we'll do. + (return)) + (if* (= 1 index) + then (setq npl (cddr npl)) + else (setq tmp npl) + (dotimes (x (- index 2)) (setq tmp (cdr tmp))) + (setf (cdr tmp) (cdddr tmp)))) + (setf (cdr new-path-list) npl) + (when fix-tail (setq new-path-list (nconc new-path-list '(""))))) + + ;; step 6g: + ;; don't complain if new-path-list starts with `..'. See comment + ;; above about this step. + + ;; step 6h: + (when (or (equal '(:absolute "") new-path-list) + (equal '(:absolute) new-path-list)) + (setq new-path-list nil)) + (setf (uri-path uri) + (render-parsed-path new-path-list + ;; don't know, so have to assume: + t))) + +;;;; step 7 + :done + (return-from merge-uris uri))) + +(defmethod enough-uri ((uri string) (base string) &optional place) + (enough-uri (parse-uri uri) (parse-uri base) place)) + +(defmethod enough-uri ((uri uri) (base string) &optional place) + (enough-uri uri (parse-uri base) place)) + +(defmethod enough-uri ((uri string) (base uri) &optional place) + (enough-uri (parse-uri uri) base place)) + +(defmethod enough-uri ((uri uri) (base uri) &optional place) + (let ((new-scheme nil) + (new-host nil) + (new-port nil) + (new-parsed-path nil)) + + (when (or (and (uri-scheme uri) + (not (equalp (uri-scheme uri) (uri-scheme base)))) + (and (uri-host uri) + (not (equalp (uri-host uri) (uri-host base)))) + (not (equalp (uri-port uri) (uri-port base)))) + (return-from enough-uri uri)) + + (when (null (uri-host uri)) + (setq new-host (uri-host base))) + (when (null (uri-port uri)) + (setq new-port (uri-port base))) + + (when (null (uri-scheme uri)) + (setq new-scheme (uri-scheme base))) + + ;; Now, for the hard one, path. + ;; We essentially do here what enough-namestring does. + (do* ((base-path (uri-parsed-path base)) + (path (uri-parsed-path uri)) + (bp base-path (cdr bp)) + (p path (cdr p))) + ((or (null bp) (null p)) + ;; If p is nil, that means we have something like + ;; (enough-uri "/foo/bar" "/foo/bar/baz.htm"), so + ;; new-parsed-path will be nil. + (when (null bp) + (setq new-parsed-path (copy-list p)) + (when (not (symbolp (car new-parsed-path))) + (push :relative new-parsed-path)))) + (if* (equal (car bp) (car p)) + thenret ;; skip it + else (setq new-parsed-path (copy-list p)) + (when (not (symbolp (car new-parsed-path))) + (push :relative new-parsed-path)) + (return))) + + (let ((new-path + (when new-parsed-path + (render-parsed-path new-parsed-path + ;; don't know, so have to assume: + t))) + (new-query (uri-query uri)) + (new-fragment (uri-fragment uri)) + (new-plist (copy-list (uri-plist uri)))) + (if* (and (null new-scheme) + (null new-host) + (null new-port) + (null new-path) + (null new-parsed-path) + (null new-query) + (null new-fragment)) + then ;; can't have a completely empty uri! + (copy-uri nil + :class (class-of uri) + :place place + :path "/" + :plist new-plist) + else (copy-uri nil + :class (class-of uri) + :place place + :scheme new-scheme + :host new-host + :port new-port + :path new-path + :parsed-path new-parsed-path + :query new-query + :fragment new-fragment + :plist new-plist))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; support for interning URIs + +(defun make-uri-space (&rest keys &key (size 777) &allow-other-keys) + #+allegro + (apply #'make-hash-table :size size + :hash-function 'uri-hash + :test 'uri= :values nil keys) + #-allegro + (apply #'make-hash-table :size size keys)) + +(defun gethash-uri (uri table) + #+allegro (gethash uri table) + #-allegro + (let* ((hash (uri-hash uri)) + (existing (gethash hash table))) + (dolist (u existing) + (when (uri= u uri) + (return-from gethash-uri (values u t)))) + (values nil nil))) + +(defun puthash-uri (uri table) + #+allegro (excl:puthash-key uri table) + #-allegro + (let ((existing (gethash (uri-hash uri) table))) + (dolist (u existing) + (when (uri= u uri) + (return-from puthash-uri u))) + (setf (gethash (uri-hash uri) table) + (cons uri existing)) + uri)) + + +(defun uri-hash (uri) + (if* (uri-hashcode uri) + thenret + else (setf (uri-hashcode uri) + (sxhash + #+allegro + (render-uri uri nil) + #-allegro + (string-downcase + (render-uri uri nil)))))) + +(defvar *uris* (make-uri-space)) + +(defun uri-space () *uris*) + +(defun (setf uri-space) (new-val) + (setq *uris* new-val)) + +;; bootstrapping (uri= changed from function to method): +(when (fboundp 'uri=) (fmakunbound 'uri=)) + +(defgeneric uri= (uri1 uri2)) +(defmethod uri= ((uri1 uri) (uri2 uri)) + (when (not (eq (uri-scheme uri1) (uri-scheme uri2))) + (return-from uri= nil)) + ;; RFC2396 says: a URL with an explicit ":port", where the port is + ;; the default for the scheme, is the equivalent to one where the + ;; port is elided. Hmmmm. This means that this function has to be + ;; scheme dependent. Grrrr. + (let ((default-port (case (uri-scheme uri1) + (:http 80) + (:https 443) + (:ftp 21) + (:telnet 23)))) + (and (equalp (uri-host uri1) (uri-host uri2)) + (eql (or (uri-port uri1) default-port) + (or (uri-port uri2) default-port)) + (string= (uri-path uri1) (uri-path uri2)) + (string= (uri-query uri1) (uri-query uri2)) + (string= (uri-fragment uri1) (uri-fragment uri2))))) + +(defmethod uri= ((urn1 urn) (urn2 urn)) + (when (not (eq (uri-scheme urn1) (uri-scheme urn2))) + (return-from uri= nil)) + (and (equalp (urn-nid urn1) (urn-nid urn2)) + (urn-nss-equal (urn-nss urn1) (urn-nss urn2)))) + +(defun urn-nss-equal (nss1 nss2 &aux len) + ;; Return t iff the nss values are the same. + ;; %2c and %2C are equivalent. + (when (or (null nss1) (null nss2) + (not (= (setq len (length nss1)) + (length nss2)))) + (return-from urn-nss-equal nil)) + (do* ((i 0 (1+ i)) + (state :char) + c1 c2) + ((= i len) t) + (setq c1 (char nss1 i)) + (setq c2 (char nss2 i)) + (ecase state + (:char + (if* (and (char= #% c1) (char= #% c2)) + then (setq state :percent+1) + elseif (char/= c1 c2) + then (return nil))) + (:percent+1 + (when (char-not-equal c1 c2) (return nil)) + (setq state :percent+2)) + (:percent+2 + (when (char-not-equal c1 c2) (return nil)) + (setq state :char))))) + +(defmethod intern-uri ((xuri uri) &optional (uri-space *uris*)) + (let ((uri (gethash-uri xuri uri-space))) + (if* uri + thenret + else (puthash-uri xuri uri-space)))) + +(defmethod intern-uri ((uri string) &optional (uri-space *uris*)) + (intern-uri (parse-uri uri) uri-space)) + +(defun unintern-uri (uri &optional (uri-space *uris*)) + (if* (eq t uri) + then (clrhash uri-space) + elseif (uri-p uri) + then (remhash uri uri-space) + else (error "bad uri: ~s." uri))) + +(defmacro do-all-uris ((var &optional uri-space result-form) + &rest forms + &environment env) + "do-all-uris (var [[uri-space] result-form]) + {declaration}* {tag | statement}* +Executes the forms once for each uri with var bound to the current uri" + (let ((f (gensym)) + (g-ignore (gensym)) + (g-uri-space (gensym)) + (body (third (parse-body forms env)))) + `(let ((,g-uri-space (or ,uri-space *uris*))) + (prog nil + (flet ((,f (,var &optional ,g-ignore) + (declare (ignore-if-unused ,var ,g-ignore)) + (tagbody ,@body))) + (maphash #',f ,g-uri-space)) + (return ,result-form))))) + +(defun sharp-u (stream chr arg) + (declare (ignore chr arg)) + (let ((arg (read stream nil nil t))) + (if *read-suppress* + nil + (if* (stringp arg) + then (parse-uri arg) + else + + (internal-reader-error + stream + "#u takes a string or list argument: ~s" arg))))) + + +#+allegro +excl:: +#+allegro +(locally (declare (special std-lisp-readtable)) + (let ((*readtable* std-lisp-readtable)) + (set-dispatch-macro-character ## #\u #'puri::sharp-u))) +#-allegro +(set-dispatch-macro-character ## #\u #'puri::sharp-u) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(provide :uri) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; timings +;; (don't run under emacs with M-x fi:common-lisp) + +#+allegro +(eval-when (:compile-toplevel :load-toplevel :execute) + (import 'excl::gc)) + +#-allegro +(defun gc (&rest options) + (declare (ignore options)) + #+sbcl (sb-ext::gc) + #+cmu (ext::gc) + ) + +(defun time-uri-module () + (declare (optimize (speed 3) (safety 0) (debug 0))) + (let ((uri "http://www.franz.com/a/b;x;y;z/c/foo?bar=baz&xxx#foo") + (uri2 "http://www.franz.com/a/b;x;y;z/c/%2ffoo?bar=baz&xxx#foo")) + (gc t) (gc :tenure) (gc :tenure) (gc :tenure) + (format t "~&;;; starting timing testing 1...~%") + (time (dotimes (i 100000) (parse-uri uri))) + + (gc t) (gc :tenure) (gc :tenure) (gc :tenure) + (format t "~&;;; starting timing testing 2...~%") + (let ((uri (parse-uri uri))) + (time (dotimes (i 100000) + ;; forces no caching of the printed representation: + (setf (uri-string uri) nil) + (format nil "~a" uri)))) + + (gc t) (gc :tenure) (gc :tenure) (gc :tenure) + (format t "~&;;; starting timing testing 3...~%") + (time + (progn + (dotimes (i 100000) (parse-uri uri2)) + (let ((uri (parse-uri uri))) + (dotimes (i 100000) + ;; forces no caching of the printed representation: + (setf (uri-string uri) nil) + (format nil "~a" uri))))))) + +;;******** reference output (ultra, modified 5.0.1): +;;; starting timing testing 1... +; cpu time (non-gc) 13,710 msec user, 0 msec system +; cpu time (gc) 600 msec user, 10 msec system +; cpu time (total) 14,310 msec user, 10 msec system +; real time 14,465 msec +; space allocation: +; 1,804,261 cons cells, 7 symbols, 41,628,832 other bytes, 0 static bytes +;;; starting timing testing 2... +; cpu time (non-gc) 27,500 msec user, 0 msec system +; cpu time (gc) 280 msec user, 20 msec system +; cpu time (total) 27,780 msec user, 20 msec system +; real time 27,897 msec +; space allocation: +; 1,900,463 cons cells, 0 symbols, 17,693,712 other bytes, 0 static bytes +;;; starting timing testing 3... +; cpu time (non-gc) 52,290 msec user, 10 msec system +; cpu time (gc) 1,290 msec user, 30 msec system +; cpu time (total) 53,580 msec user, 40 msec system +; real time 54,062 msec +; space allocation: +; 7,800,205 cons cells, 0 symbols, 81,697,496 other bytes, 0 static bytes + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; after improving decode-escaped-encoding/encode-escaped-encoding: + +;;; starting timing testing 1... +; cpu time (non-gc) 14,520 msec user, 0 msec system +; cpu time (gc) 400 msec user, 0 msec system +; cpu time (total) 14,920 msec user, 0 msec system +; real time 15,082 msec +; space allocation: +; 1,800,270 cons cells, 0 symbols, 41,600,160 other bytes, 0 static bytes +;;; starting timing testing 2... +; cpu time (non-gc) 27,490 msec user, 10 msec system +; cpu time (gc) 300 msec user, 0 msec system +; cpu time (total) 27,790 msec user, 10 msec system +; real time 28,025 msec +; space allocation: +; 1,900,436 cons cells, 0 symbols, 17,693,712 other bytes, 0 static bytes +;;; starting timing testing 3... +; cpu time (non-gc) 47,900 msec user, 20 msec system +; cpu time (gc) 920 msec user, 10 msec system +; cpu time (total) 48,820 msec user, 30 msec system +; real time 49,188 msec +; space allocation: +; 3,700,215 cons cells, 0 symbols, 81,707,144 other bytes, 0 static bytes

Added: branches/trunk-reorg/thirdparty/puri-1.5.1/tests.lisp =================================================================== --- branches/trunk-reorg/thirdparty/puri-1.5.1/tests.lisp 2007-10-04 19:10:49 UTC (rev 2204) +++ branches/trunk-reorg/thirdparty/puri-1.5.1/tests.lisp 2007-10-04 19:13:23 UTC (rev 2205) @@ -0,0 +1,419 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;; copyright (c) 1999-2001 Franz Inc, Berkeley, CA - All rights reserved. +;; copyright (c) 2003 Kevin Rosenberg (significant fixes for using +;; tester package) +;; +;; The software, data and information contained herein are proprietary +;; to, and comprise valuable trade secrets of, Franz, Inc. They are +;; given in confidence by Franz, Inc. pursuant to a written license +;; agreement, and may be stored and used only in accordance with the terms +;; of such license. +;; +;; Restricted Rights Legend +;; ------------------------ +;; Use, duplication, and disclosure of the software, data and information +;; contained herein by any agency, department or entity of the U.S. +;; Government are subject to restrictions of Restricted Rights for +;; Commercial Software developed at private expense as specified in +;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. +;; +;; Original version from ACL 6.1: +;; t-uri.cl,v 1.3.6.3.2.1 2001/08/09 17:42:43 layer +;; +;; $Id: tests.lisp 11031 2006-08-15 00:59:34Z kevin $ + + +(defpackage #:puri-tests (:use #:puri #:cl #:ptester)) +(in-package #:puri-tests) + +(unintern-uri t) + +(defmacro gen-test-forms () + (let ((res '()) + (base-uri "http://a/b/c/d;p?q")) + + (dolist (x `(;; (relative-uri result base-uri compare-function) +;;;; RFC Appendix C.1 (normal examples) + ("g:h" "g:h" ,base-uri) + ("g" "http://a/b/c/g" ,base-uri) + ("./g" "http://a/b/c/g" ,base-uri) + ("g/" "http://a/b/c/g/" ,base-uri) + ("/g" "http://a/g" ,base-uri) + ("//g" "http://g" ,base-uri) + ;; Following was changed from appendix C of RFC 2396 + ;; http://www.apache.org/~fielding/uri/rev-2002/issues.html#003-relative-query + #-ignore ("?y" "http://a/b/c/d;p?y" ,base-uri) + #+ignore ("?y" "http://a/b/c/?y" ,base-uri) + ("g?y" "http://a/b/c/g?y" ,base-uri) + ("#s" "http://a/b/c/d;p?q#s" ,base-uri) + ("g#s" "http://a/b/c/g#s" ,base-uri) + ("g?y#s" "http://a/b/c/g?y#s" ,base-uri) + (";x" "http://a/b/c/;x" ,base-uri) + ("g;x" "http://a/b/c/g;x" ,base-uri) + ("g;x?y#s" "http://a/b/c/g;x?y#s" ,base-uri) + ("." "http://a/b/c/" ,base-uri) + ("./" "http://a/b/c/" ,base-uri) + (".." "http://a/b/" ,base-uri) + ("../" "http://a/b/" ,base-uri) + ("../g" "http://a/b/g" ,base-uri) + ("../.." "http://a/" ,base-uri) + ("../../" "http://a/" ,base-uri) + ("../../g" "http://a/g" ,base-uri) +;;;; RFC Appendix C.2 (abnormal examples) + ("" "http://a/b/c/d;p?q" ,base-uri) + ("../../../g" "http://a/../g" ,base-uri) + ("../../../../g" "http://a/../../g" ,base-uri) + ("/./g" "http://a/./g" ,base-uri) + ("/../g" "http://a/../g" ,base-uri) + ("g." "http://a/b/c/g." ,base-uri) + (".g" "http://a/b/c/.g" ,base-uri) + ("g.." "http://a/b/c/g.." ,base-uri) + ("..g" "http://a/b/c/..g" ,base-uri) + ("./../g" "http://a/b/g" ,base-uri) + ("./g/." "http://a/b/c/g/" ,base-uri) + ("g/./h" "http://a/b/c/g/h" ,base-uri) + ("g/../h" "http://a/b/c/h" ,base-uri) + ("g;x=1/./y" "http://a/b/c/g;x=1/y" ,base-uri) + ("g;x=1/../y" "http://a/b/c/y" ,base-uri) + ("g?y/./x" "http://a/b/c/g?y/./x" ,base-uri) + ("g?y/../x" "http://a/b/c/g?y/../x" ,base-uri) + ("g#s/./x" "http://a/b/c/g#s/./x" ,base-uri) + ("g#s/../x" "http://a/b/c/g#s/../x" ,base-uri) + ("http:g" "http:g" ,base-uri) + + ("foo/bar/baz.htm#foo" + "http://a/b/foo/bar/baz.htm#foo" + "http://a/b/c.htm") + ("foo/bar/baz.htm#foo" + "http://a/b/foo/bar/baz.htm#foo" + "http://a/b/") + ("foo/bar/baz.htm#foo" + "http://a/foo/bar/baz.htm#foo" + "http://a/b") + ("foo/bar;x;y/bam.htm" + "http://a/b/c/foo/bar;x;y/bam.htm" + "http://a/b/c/"))) + (push `(test (intern-uri ,(second x)) + (intern-uri (merge-uris (intern-uri ,(first x)) + (intern-uri ,(third x)))) + :test 'uri=) + res)) + +;;;; intern tests + (dolist (x '(;; default port and specifying the default port are + ;; supposed to compare the same: + ("http://www.franz.com:80" "http://www.franz.com") + ("http://www.franz.com:80" "http://www.franz.com" eq) + ;; make sure they're `eq': + ("http://www.franz.com:80" "http://www.franz.com" eq) + ("http://www.franz.com" "http://www.franz.com" eq) + ("http://www.franz.com/foo" "http://www.franz.com/foo" eq) + ("http://www.franz.com/foo?bar" + "http://www.franz.com/foo?bar" eq) + ("http://www.franz.com/foo?bar#baz" + "http://www.franz.com/foo?bar#baz" eq) + ("http://WWW.FRANZ.COM" "http://www.franz.com" eq) + ("http://www.FRANZ.com" "http://www.franz.com" eq) + ("http://www.franz.com" "http://www.franz.com/" eq) + (;; %72 is "r", %2f is "/", %3b is ";" + "http://www.franz.com/ba%72%2f%3b;x;y;z/baz/" + "http://www.franz.com/bar%2f%3b;x;y;z/baz/" eq))) + (push `(test (intern-uri ,(second x)) + (intern-uri ,(first x)) + :test ',(if (third x) + (third x) + 'uri=)) + res)) + +;;;; parsing and equivalence tests + (push `(test + (parse-uri "http://foo+bar?baz=b%26lob+bof") + (parse-uri (parse-uri "http://foo+bar?baz=b%26lob+bof")) + :test 'uri=) + res) + (push '(test + (parse-uri "http://www.foo.com") + (parse-uri (parse-uri "http://www.foo.com?")) ; allow ? at end + :test 'uri=) + res) + (push `(test + "baz=b%26lob+bof" + (uri-query (parse-uri "http://foo+bar?baz=b%26lob+bof")) + :test 'string=) + res) + (push `(test + "baz=b%26lob+bof%3d" + (uri-query (parse-uri "http://foo+bar?baz=b%26lob+bof%3d")) + :test 'string=) + res) + (push + `(test (parse-uri "xxx?%41") (parse-uri "xxx?A") :test 'uri=) + res) + (push + `(test "A" (uri-query (parse-uri "xxx?%41")) :test 'string=) + res) + + (push `(test-error (parse-uri " ") + :condition-type 'uri-parse-error) + res) + (push `(test-error (parse-uri "foo ") + :condition-type 'uri-parse-error) + res) + (push `(test-error (parse-uri " foo ") + :condition-type 'uri-parse-error) + res) + (push `(test-error (parse-uri "<foo") + :condition-type 'uri-parse-error) + res) + (push `(test-error (parse-uri "foo>") + :condition-type 'uri-parse-error) + res) + (push `(test-error (parse-uri "<foo>") + :condition-type 'uri-parse-error) + res) + (push `(test-error (parse-uri "%") + :condition-type 'uri-parse-error) + res) + (push `(test-error (parse-uri "foo%xyr") + :condition-type 'uri-parse-error) + res) + (push `(test-error (parse-uri ""foo"") + :condition-type 'uri-parse-error) + res) + (push `(test "%20" (format nil "~a" (parse-uri "%20")) + :test 'string=) + res) + (push `(test "&" (format nil "~a" (parse-uri "%26")) + :test 'string=) + res) + (push + `(test "foo%23bar" (format nil "~a" (parse-uri "foo%23bar")) + :test 'string=) + res) + (push + `(test "foo%23bar#foobar" + (format nil "~a" (parse-uri "foo%23bar#foobar")) + :test 'string=) + res) + (push + `(test "foo%23bar#foobar#baz" + (format nil "~a" (parse-uri "foo%23bar#foobar#baz")) + :test 'string=) + res) + (push + `(test "foo%23bar#foobar#baz" + (format nil "~a" (parse-uri "foo%23bar#foobar%23baz")) + :test 'string=) + res) + (push + `(test "foo%23bar#foobar/baz" + (format nil "~a" (parse-uri "foo%23bar#foobar%2fbaz")) + :test 'string=) + res) + (push `(test-error (parse-uri "foobar??") + :condition-type 'uri-parse-error) + res) + (push `(test-error (parse-uri "foobar?foo?") + :condition-type 'uri-parse-error) + res) + (push `(test "foobar?%3f" + (format nil "~a" (parse-uri "foobar?%3f")) + :test 'string=) + res) + (push `(test + "http://foo/bAr;3/baz?baf=3" + (format nil "~a" (parse-uri "http://foo/b%41r;3/baz?baf=3")) + :test 'string=) + res) + (push `(test + '(:absolute ("/bAr" "3") "baz") + (uri-parsed-path (parse-uri "http://foo/%2fb%41r;3/baz?baf=3")) + :test 'equal) + res) + (push `(test + "/%2fbAr;3/baz" + (let ((u (parse-uri "http://foo/%2fb%41r;3/baz?baf=3"))) + (setf (uri-parsed-path u) '(:absolute ("/bAr" "3") "baz")) + (uri-path u)) + :test 'string=) + res) + (push `(test + "http://www.verada.com:8010/kapow?name=foo%3Dbar%25" + (format nil "~a" + (parse-uri + "http://www.verada.com:8010/kapow?name=foo%3Dbar%25")) + :test 'string=) + res) + (push `(test + "ftp://parcftp.xerox.com/pub/pcl/mop/" + (format nil "~a" + (parse-uri "ftp://parcftp.xerox.com:/pub/pcl/mop/")) + :test 'string=) + res) + +;;;; enough-uri tests + (dolist (x `(("http://www.franz.com/foo/bar/baz.htm" + "http://www.franz.com/foo/bar/" + "baz.htm") + ("http://www.franz.com/foo/bar/baz.htm" + "http://www.franz.com/foo/bar" + "baz.htm") + ("http://www.franz.com:80/foo/bar/baz.htm" + "http://www.franz.com:80/foo/bar" + "baz.htm") + ("http:/foo/bar/baz.htm" "http:/foo/bar" "baz.htm") + ("http:/foo/bar/baz.htm" "http:/foo/bar/" "baz.htm") + ("/foo/bar/baz.htm" "/foo/bar" "baz.htm") + ("/foo/bar/baz.htm" "/foo/bar/" "baz.htm") + ("/foo/bar/baz.htm#foo" "/foo/bar/" "baz.htm#foo") + ("/foo/bar/baz.htm?bar#foo" "/foo/bar/" "baz.htm?bar#foo") + + ("http://www.dnai.com/~layer/foo.htm" + "http://www.known.net" + "http://www.dnai.com/~layer/foo.htm") + ("http://www.dnai.com/~layer/foo.htm" + "http://www.dnai.com:8000/~layer/" + "http://www.dnai.com/~layer/foo.htm") + ("http://www.dnai.com:8000/~layer/foo.htm" + "http://www.dnai.com/~layer/" + "http://www.dnai.com:8000/~layer/foo.htm") + ("http://www.franz.com" + "http://www.franz.com" + "/"))) + (push `(test (parse-uri ,(third x)) + (enough-uri (parse-uri ,(first x)) + (parse-uri ,(second x))) + :test 'uri=) + res)) + +;;;; urn tests, ideas of which are from rfc2141 + (let ((urn "urn:com:foo-the-bar")) + (push `(test "com" (urn-nid (parse-uri ,urn)) + :test #'string=) + res) + (push `(test "foo-the-bar" (urn-nss (parse-uri ,urn)) + :test #'string=) + res)) + (push `(test-error (parse-uri "urn:") + :condition-type 'uri-parse-error) + res) + (push `(test-error (parse-uri "urn:foo") + :condition-type 'uri-parse-error) + res) + (push `(test-error (parse-uri "urn:foo$") + :condition-type 'uri-parse-error) + res) + (push `(test-error (parse-uri "urn:foo_") + :condition-type 'uri-parse-error) + res) + (push `(test-error (parse-uri "urn:foo:foo&bar") + :condition-type 'uri-parse-error) + res) + (push `(test (parse-uri "URN:foo:a123,456") + (parse-uri "urn:foo:a123,456") + :test #'uri=) + res) + (push `(test (parse-uri "URN:foo:a123,456") + (parse-uri "urn:FOO:a123,456") + :test #'uri=) + res) + (push `(test (parse-uri "urn:foo:a123,456") + (parse-uri "urn:FOO:a123,456") + :test #'uri=) + res) + (push `(test (parse-uri "URN:FOO:a123%2c456") + (parse-uri "urn:foo:a123%2C456") + :test #'uri=) + res) + (push `(test + nil + (uri= (parse-uri "urn:foo:A123,456") + (parse-uri "urn:FOO:a123,456"))) + res) + (push `(test + nil + (uri= (parse-uri "urn:foo:A123,456") + (parse-uri "urn:foo:a123,456"))) + res) + (push `(test + nil + (uri= (parse-uri "urn:foo:A123,456") + (parse-uri "URN:foo:a123,456"))) + res) + (push `(test + nil + (uri= (parse-uri "urn:foo:a123%2C456") + (parse-uri "urn:FOO:a123,456"))) + res) + (push `(test + nil + (uri= (parse-uri "urn:foo:a123%2C456") + (parse-uri "urn:foo:a123,456"))) + res) + (push `(test + nil + (uri= (parse-uri "URN:FOO:a123%2c456") + (parse-uri "urn:foo:a123,456"))) + res) + (push `(test + nil + (uri= (parse-uri "urn:FOO:a123%2c456") + (parse-uri "urn:foo:a123,456"))) + res) + (push `(test + nil + (uri= (parse-uri "urn:foo:a123%2c456") + (parse-uri "urn:foo:a123,456"))) + res) + + (push `(test t + (uri= (parse-uri "foo") (parse-uri "foo#"))) + res) + + (push + '(let ((puri::*strict-parse* nil)) + (test-no-error + (puri:parse-uri + "http://foo.com/bar?a=zip%7Czop"))) + res) + (push + '(test-error + (puri:parse-uri "http://foo.com/bar?a=zip%7Czop") + :condition-type 'uri-parse-error) + res) + + (push + '(let ((puri::*strict-parse* nil)) + (test-no-error + (puri:parse-uri + "http://arc3.msn.com/ADSAdClient31.dll?GetAd?PG=NBCSBU?SC=D2?AN=1.0586041"))) + res) + (push + '(test-error + (puri:parse-uri + "http://arc3.msn.com/ADSAdClient31.dll?GetAd?PG=NBCSBU?SC=D2?AN=1.0586041") + :condition-type 'uri-parse-error) + res) + + (push + '(let ((puri::*strict-parse* nil)) + (test-no-error + (puri:parse-uri + "http://scbc.booksonline.com/cgi-bin/ndCGI.exe/Develop/pagClubHome.hrfTIOLI_o..."))) + res) + (push + '(test-error + (puri:parse-uri + "http://scbc.booksonline.com/cgi-bin/ndCGI.exe/Develop/pagClubHome.hrfTIOLI_o...") + :condition-type 'uri-parse-error) + res) + + `(progn ,@(nreverse res)))) + +(defun do-tests () + (let ((*break-on-test-failures* t)) + (with-tests (:name "puri") + (gen-test-forms))) + t) + +

Added: branches/trunk-reorg/thirdparty/puri-1.5.1/uri.html =================================================================== --- branches/trunk-reorg/thirdparty/puri-1.5.1/uri.html 2007-10-04 19:10:49 UTC (rev 2204) +++ branches/trunk-reorg/thirdparty/puri-1.5.1/uri.html 2007-10-04 19:13:23 UTC (rev 2205) @@ -0,0 +1,406 @@ +<html> + +<head> +<title>URI support in Allegro CL</title> +</head> + +<body> + +<h1>URI support in Allegro CL</h1> + +<p>This document contains the following sections:</p> +<p><a href="#uri-intro-1">1.0 Introduction</a><br> +<a href="#uri-api-1">2.0 The URI API definition</a><br> +<a href="#parsing-decoding-1">3.0 Parsing, escape decoding/encoding and the path</a><br> +<a href="#interning-uris-1">4.0 Interning URIs</a><br> +<a href="#acl-implementation-1">5.0 Allegro CL implementation notes</a><br> +<a href="#examples-1">6.0 Examples</a><br> +</p> + +<p>This version of the Allegro CL URI support documentation is for distribution with the +Open Source version of the URI code. Links to Allegro CL documentation other than +URI-specific files have been supressed. To see Allegro CL documentation, see <a +href="http://www.franz.com/support/documentation/%22%3Ehttp://www.franz.com/suppor...</a>, +which is the Allegro CL documentation page of the franz inc. website. Links to Allegro CL +documentation can be found on that page. </p> + +<hr> + +<hr> + +<h2><a name="uri-intro-1">1.0 Introduction</a></h2> + +<p><em>URI</em> stands for <em>Universal Resource Identifier</em>. For a description of +URIs, see RFC2396, which can be found in several places, including the IETF web site (<a +href="http://www.ietf.org/rfc/rfc2396.txt%22%3Ehttp://www.ietf.org/rfc/rfc2396.txt</a>) and +the UCI/ICS web site (<a href="http://www.ics.uci.edu/pub/ietf/uri/rfc2396.txt">http://www.ics.uci.edu/pub/ietf/uri/rfc2396.txt</a>). +We prefer the UCI/ICS one as it has more examples. </p> + +<p>URIs are a superset in functionality and syntax to URLs (Universal Resource Locators) +and URNs (Universal Resource Names). That is, RFC2396 updates and merges RFC1738 and +RFC1808 into a single syntax, called the URI. It does exclude some portions of RFC1738 +that define specific syntax of individual URL schemes. </p> + +<p>In URL slang, the <em>scheme</em> is usually called the `protocol', but it is called +scheme in RFC1738. A URL `host' corresponds to the URI `authority.' The URL slang +`bookmark' or `anchor' is `fragment' in URI lingo. </p> + +<p>The URI facility was available as a patch to Allegro CL 5.0.1 and is included with +release 6.0. the URI facility might not be in an Allegro CL image. Evaluate <code>(require +:uri)</code> to ensure the facility is loaded (that form returns <code>nil</code> if the +URI module is already loaded). </p> + +<p>Broadly, the URI facility creates a Lisp object that represents a URI, and provides +setters and accessors to fields in the URI object. The URI object can also be interned, +much like symbols in CL are. This document describes the facility and the related +operators. </p> + +<p>Aside from the obvious slots which are called out in the RFC, URIs also have a property +list. With interning, this is another similarity between URIs and CL symbols. </p> + +<hr> + +<hr> + +<h2><a name="uri-api-1">2.0 The URI API definition</a></h2> + +<p>Symbols naming objects (functions, variables, etc.) in the <em>uri</em> module are +exported from the <code>net.uri</code> package. </p> + +<p>URIs are represented by CLOS objects. Their slots are: </p> + +<pre> +scheme +host +port +path +query +fragment +plist +</pre> + +<p>The <code>host</code> and <code>port</code> slots together correspond to the <code>authority</code> +(see RFC2396). There is an accessor-like function, <a href="operators/uri-authority.htm"><b>uri-authority</b></a>, +that can be used to extract the authority from a URI. See the RFC2396 specifications +pointed to at the beginning of the <a href="#uri-intro-1">1.0 Introduction</a> for details +of all the slots except <code>plist</code>. The <code>plist</code> slot contains a +standard Common Lisp property list. </p> + +<p>All symbols are external in the <code>net.uri</code> package, unless otherwise noted. +Brief descriptions are given in this document, with complete descriptions in the +individual pages. + +<ul> + <li><a href="classes/uri.htm"><code>uri</code></a>: the class of URI objects. </li> + <li><a href="classes/urn.htm"><code>urn</code></a>: the class of URN objects. </li> + <li><a href="operators/uri-p.htm"><b>uri-p</b></a> <p><b>Arguments: </b><i>object</i></p> + <p>Returns true if <i>object</i> is an instance of class <a href="classes/uri.htm"><code>uri</code></a>. + </p> + </li> + <li><a href="operators/copy-uri.htm"><b>copy-uri</b></a> <p><b>Arguments: </b><i>uri </i>&amp;key + <i>place scheme host port path query fragment plist </i></p> + <p>Copies the specified URI object. See the description page for information on the + keyword arguments. </p> + </li> + <li><a href="operators/uri-scheme.htm"><b>uri-scheme</b></a><br> + <a href="operators/uri-host.htm"><b>uri-host</b></a><br> + <a href="operators/uri-port.htm"><b>uri-port</b></a><br> + <a href="operators/uri-path.htm"><b>uri-path</b></a><br> + <a href="operators/uri-query.htm"><b>uri-query</b></a><br> + <a href="operators/uri-fragment.htm"><b>uri-fragment</b></a><br> + <a href="operators/uri-plist.htm"><b>uri-plist</b></a><br> + <p><b>Arguments: </b><i>uri-object </i></p> + <p>These accessors return the value of the associated slots of the <i>uri-object</i> </p> + </li> + <li><a href="operators/uri-authority.htm"><b>uri-authority</b></a> <p><b>Arguments: </b><i>uri-object + </i></p> + <p>Returns the authority of <i>uri-object</i>. The authority combines the host and port. </p> + </li> + <li><a href="operators/render-uri.htm"><b>render-uri</b></a> <p><b>Arguments: </b><i>uri + stream </i></p> + <p>Print to <i>stream</i> the printed representation of <i>uri</i>. </p> + </li> + <li><a href="operators/parse-uri.htm"><b>parse-uri</b></a> <p><b>Arguments: </b><i>string </i>&amp;key + (<i>class</i> 'uri)<i> </i></p> + <p>Parse <i>string</i> into a URI object. </p> + </li> + <li><a href="operators/merge-uris.htm"><b>merge-uris</b></a> <p><b>Arguments: </b><i>uri + base-uri </i>&amp;optional <i>place </i></p> + <p>Return an absolute URI, based on <i>uri</i>, which can be relative, and <i>base-uri</i> + which must be absolute. </p> + </li> + <li><a href="operators/enough-uri.htm"><b>enough-uri</b></a> <p><b>Arguments: </b><i>uri + base </i></p> + <p>Converts <i>uri</i> into a relative URI using <i>base</i> as the base URI. </p> + </li> + <li><a href="operators/uri-parsed-path.htm"><b>uri-parsed-path</b></a> <p><b>Arguments: </b><i>uri + </i></p> + <p>Return the parsed representation of the path. </p> + </li> + <li><a href="operators/uri.htm"><b>uri</b></a> <p><b>Arguments: </b><i>object </i></p> + <p>Defined methods: if argument is a uri object, return it; create a uri object if + possible and return it, or error if not possible. </p> + </li> +</ul> + +<hr> + +<hr> + +<h2><a name="parsing-decoding-1">3.0 Parsing, escape decoding/encoding and the path</a></h2> + +<p>The method <a href="operators/uri-path.htm"><b>uri-path</b></a> returns the path +portion of the URI, in string form. The method <a href="operators/uri-parsed-path.htm"><b>uri-parsed-path</b></a> +returns the path portion of the URI, in list form. This list form is discussed below, +after a discussion of decoding/encoding. </p> + +<p>RFC2396 lays out a method for inserting into URIs <em>reserved characters</em>. You do +this by escaping the character. An <em>escaped</em> character is defined like this: </p> + +<pre> +escaped = &quot;%&quot; hex hex + +hex = digit | &quot;A&quot; | &quot;B&quot; | &quot;C&quot; | &quot;D&quot; | &quot;E&quot; | &quot;F&quot; | &quot;a&quot; | &quot;b&quot; | &quot;c&quot; | &quot;d&quot; | &quot;e&quot; | &quot;f&quot; +</pre> + +<p>In addition, the RFC defines excluded characters: </p> + +<pre> +&quot;&lt;&quot; | &quot;&gt;&quot; | &quot;#&quot; | &quot;%&quot; | &lt;&quot;&gt; | &quot;{&quot; | &quot;}&quot; | &quot;|&quot; | &quot;&quot; | &quot;^&quot; | &quot;[&quot; | &quot;]&quot; | &quot;`&quot; +</pre> + +<p>The set of reserved characters are: </p> + +<pre> +&quot;;&quot; | &quot;/&quot; | &quot;?&quot; | &quot;:&quot; | &quot;@&quot; | &quot;&amp;&quot; | &quot;=&quot; | &quot;+&quot; | &quot;$&quot; | &quot;,&quot; +</pre> + +<p>with the following exceptions: + +<ul> + <li>within the authority component, the characters &quot;;&quot;, &quot;:&quot;, + &quot;@&quot;, &quot;?&quot;, and &quot;/&quot; are reserved. </li> + <li>within a path segment, the characters &quot;/&quot;, &quot;;&quot;, &quot;=&quot;, and + &quot;?&quot; are reserved. </li> + <li>within a query component, the characters &quot;;&quot;, &quot;/&quot;, &quot;?&quot;, + &quot;:&quot;, &quot;@&quot;, &quot;&amp;&quot;, &quot;=&quot;, &quot;+&quot;, + &quot;,&quot;, and &quot;$&quot; are reserved. </li> +</ul> + +<p>From the RFC, there are two important rules about escaping and unescaping (encoding and +decoding): + +<ul> + <li>decoding should only happen when the URI is parsed into component parts;</li> + <li>encoding can only occur when a URI is made from component parts (ie, rendered for + printing). </li> +</ul> + +<p>The implication of this is that to decode the URI, it must be in a parsed state. That +is, you can't convert <font face="Courier New">%2f</font> (the escaped form of +&quot;/&quot;) until the path has been parsed into its component parts. Another important +desire is for the application viewing the component parts to see the decoded values of the +components. For example, consider: </p> + +<pre> +http://www.franz.com/calculator/3%2f2 +</pre> + +<p>This might be the implementation of a calculator, and how someone would execute 3/2. +Clearly, the application that implements this would want to see path components of +&quot;calculator&quot; and &quot;3/2&quot;. &quot;3%2f2&quot; would not be useful to the +calculator application. </p> + +<p>For the reasons given above, a parsed version of the path is available and has the +following form: </p> + +<pre> +([:absolute | :relative] component1 [component2...]) +</pre> + +<p>where components are: </p> + +<pre> +element | (element param1 [param2 ...]) +</pre> + +<p>and <em>element</em> is a path element, and the param's are path element parameters. +For example, the result of </p> + +<pre> +(uri-parsed-path (parse-uri &quot;foo;10/bar:x;y;z/baz.htm&quot;)) +</pre> + +<p>is </p> + +<pre> +(:relative (&quot;foo&quot; &quot;10&quot;) (&quot;bar:x&quot; &quot;y&quot; &quot;z&quot;) &quot;baz.htm&quot;) +</pre> + +<p>There is a certain amount of canonicalization that occurs when parsing: + +<ul> + <li>A path of <code>(:absolute)</code> or <code>(:absolute &quot;&quot;)</code> is + equivalent to a <code>nil</code> path. That is, <code>http://a/</code> is parsed with a <code>nil</code> + path and printed as <code>http://a</code>. </li> + <li>Escaped characters that are not reserved are not escaped upon printing. For example, <code>&quot;foob%61r&quot;</code> + is parsed into <code>&quot;foobar&quot;</code> and appears as <code>&quot;foobar&quot;</code> + when the URI is printed. </li> +</ul> + +<hr> + +<hr> + +<h2><a name="interning-uris-1">4.0 Interning URIs</a></h2> + +<p>This section describes how to intern URIs. Interning is not mandatory. URIs can be used +perfectly well without interning them. </p> + +<p>Interned URIs in Allegro are like symbols. That is, a string representing a URI, when +parsed and interned, will always yield an <strong>eq</strong> object. For example: </p> + +<pre> +(eq (intern-uri &quot;http://www.franz.com%22;) + (intern-uri &quot;http://www.franz.com%22;)) +</pre> + +<p>is always true. (Two strings with identical contents may or may not be <strong>eq</strong> +in Common Lisp, note.) </p> + +<p>The functions associated with interning are: + +<ul> + <li><a href="operators/make-uri-space.htm"><b>make-uri-space</b></a> <p><b>Arguments: </b>&amp;key + <i>size </i></p> + <p>Make a new hash-table object to contain interned URIs. </p> + </li> + <li><a href="operators/uri-space.htm"><b>uri-space</b></a> <p><b>Arguments: </b></p> + <p>Return the object into which URIs are currently being interned. </p> + </li> + <li><a href="operators/uri_eq.htm"><b>uri=</b></a> <p><b>Arguments: </b><i>uri1 uri2 </i></p> + <p>Returns true if <i>uri1</i> and <i>uri2</i> are equivalent. </p> + </li> + <li><a href="operators/intern-uri.htm"><b>intern-uri</b></a> <p><b>Arguments: </b><i>uri-name + </i>&amp;optional <i>uri-space </i></p> + <p>Intern the uri object specified in the uri-space specified. Methods exist for strings + and uri objects. </p> + </li> + <li><a href="operators/unintern-uri.htm"><b>unintern-uri</b></a> <p><b>Arguments: </b><i>uri + </i>&amp;optional <i>uri-space </i></p> + <p>Unintern the uri object specified or all uri objects (in <i>uri-space</i> if specified) + if <i>uri</i> is <code>t</code>. </p> + </li> + <li><a href="operators/do-all-uris.htm"><b>do-all-uris</b></a> <p><b>Arguments: </b><i>(var </i>&amp;optional + <i>uri-space result) </i>&amp;body <i>body </i></p> + <p>Bind <i>var</i> to all currently defined uris (in <i>uri-space</i> if specified) and + evaluate <i>body</i>. </p> + </li> +</ul> + +<hr> + +<hr> + +<h2><a name="acl-implementation-1">5.0 Allegro CL implementation notes</a></h2> + +<ol> + <li>The following are true: <br> + <code>(uri= (parse-uri &quot;http://www.franz.com/%22;)</code> <br> + &nbsp; &nbsp; <code>(parse-uri &quot;http://www.franz.com%22;))</code> <br> + <code>(eq (intern-uri &quot;http://www.franz.com/%22;)</code> <br> + &nbsp;&nbsp; <code>(intern-uri &quot;http://www.franz.com%22;))</code><br> + </li> + <li>The following is true: <br> + <code>(eq (intern-uri &quot;http://www.franz.com:80/foo/bar.htm%22;)</code> <br> + &nbsp; &nbsp; <code>(intern-uri &quot;http://www.franz.com/foo/bar.htm%22;))</code><br> + (I.e. specifying the default port is the same as specifying no port at all. This is + specific in RFC2396.) </li> + <li>The <em>scheme</em> and <em>authority</em> are case-insensitive. In Allegro CL, the + scheme is a keyword that appears in the normal case for the Lisp in which you are + executing. </li> + <li><code>#u&quot;...&quot;</code> is shorthand for <code>(parse-uri &quot;...&quot;)</code> + but if an existing <code>#u</code> dispatch macro definition exists, it will not be + overridden. </li> + <li>The interaction between setting the scheme, host, port, path, query, and fragment slots + of URI objects, in conjunction with interning URIs will have very bad and unpredictable + results. </li> + <li>The printable representation of URIs is cached, for efficiency. This caching is undone + when the above slots are changed. That is, when you create a URI the printed + representation is cached. When you change one of the above mentioned slots, the printed + representation is cleared and calculated when the URI is next printed. For example: </li> +</ol> + +<pre> +user(10): (setq u #u&quot;http://foo.bar.com/foo/bar%22;) +#&lt;uri http://foo.bar.com/foo/bar%3E; +user(11): (setf (net.uri:uri-host u) &quot;foo.com&quot;) +&quot;foo.com&quot; +user(12): u +#&lt;uri http://foo.com/foo/bar%3E; +user(13): +</pre> + +<p>This allows URIs behavior to follow the principle of least surprise. </p> + +<hr> + +<hr> + +<h2><a name="examples-1">6.0 Examples</a></h2> + +<pre> +uri(10): (use-package :net.uri) +t +uri(11): (parse-uri &quot;foo&quot;) +#&lt;uri foo&gt; +uri(12): #u&quot;foo&quot; +#&lt;uri foo&gt; +uri(13): (setq base (intern-uri &quot;http://www.franz.com/foo/bar/%22;)) +#&lt;uri http://www.franz.com/foo/bar/%3E; +uri(14): (merge-uris (parse-uri &quot;foo.htm&quot;) base) +#&lt;uri http://www.franz.com/foo/bar/foo.htm%3E; +uri(15): (merge-uris (parse-uri &quot;?foo&quot;) base) +#&lt;uri http://www.franz.com/foo/bar/?foo%3E; +uri(16): (setq base (intern-uri &quot;http://www.franz.com/foo/bar/baz.htm%22;)) +#&lt;uri http://www.franz.com/foo/bar/baz.htm%3E; +uri(17): (merge-uris (parse-uri &quot;foo.htm&quot;) base) +#&lt;uri http://www.franz.com/foo/bar/foo.htm%3E; +uri(18): (merge-uris #u&quot;?foo&quot; base) +#&lt;uri http://www.franz.com/foo/bar/?foo%3E; +uri(19): (describe #u&quot;http://www.franz.com%22;) +#&lt;uri http://www.franz.com%3E; is an instance of #&lt;standard-class net.uri:uri&gt;: + The following slots have :instance allocation: + scheme :http + host &quot;www.franz.com&quot; + port nil + path nil + query nil + fragment nil + plist nil + escaped nil + string &quot;http://www.franz.com%22; + parsed-path nil + hashcode nil +uri(20): (describe #u&quot;http://www.franz.com/%22;) +#&lt;uri http://www.franz.com%3E; is an instance of #&lt;standard-class net.uri:uri&gt;: + The following slots have :instance allocation: + scheme :http + host &quot;www.franz.com&quot; + port nil + path nil + query nil + fragment nil + plist nil + escaped nil + string &quot;http://www.franz.com%22; + parsed-path nil + hashcode nil +uri(21): #u&quot;foobar#baz%23xxx&quot; +#&lt;uri foobar#baz#xxx&gt; +</pre> + +<p><small>Copyright (c) 1998-2001, Franz Inc. Berkeley, CA., USA. All rights reserved. +Created 2001.8.16.</small></p> +</body> +</html>

Added: branches/trunk-reorg/thirdparty/trivial-gray-streams-2006-09-16/COPYING =================================================================== --- branches/trunk-reorg/thirdparty/trivial-gray-streams-2006-09-16/COPYING 2007-10-04 19:10:49 UTC (rev 2204) +++ branches/trunk-reorg/thirdparty/trivial-gray-streams-2006-09-16/COPYING 2007-10-04 19:13:23 UTC (rev 2205) @@ -0,0 +1,21 @@ + Copyright (c) 2005 David Lichteblau + + 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/trivial-gray-streams-2006-09-16/CVS/Entries =================================================================== --- branches/trunk-reorg/thirdparty/trivial-gray-streams-2006-09-16/CVS/Entries 2007-10-04 19:10:49 UTC (rev 2204) +++ branches/trunk-reorg/thirdparty/trivial-gray-streams-2006-09-16/CVS/Entries 2007-10-04 19:13:23 UTC (rev 2205) @@ -0,0 +1,7 @@ +/COPYING/1.1/Sun Dec 4 23:41:05 2005// +/Makefile/1.1.1.1/Wed Nov 9 22:11:00 2005// +/README/1.3/Thu Sep 14 17:45:36 2006// +/mixin.lisp/1.5/Thu Sep 14 17:45:36 2006// +/package.lisp/1.4/Thu Sep 14 17:45:36 2006// +/trivial-gray-streams.asd/1.1.1.1/Wed Nov 9 22:11:00 2005// +D

Added: branches/trunk-reorg/thirdparty/trivial-gray-streams-2006-09-16/CVS/Repository =================================================================== --- branches/trunk-reorg/thirdparty/trivial-gray-streams-2006-09-16/CVS/Repository 2007-10-04 19:10:49 UTC (rev 2204) +++ branches/trunk-reorg/thirdparty/trivial-gray-streams-2006-09-16/CVS/Repository 2007-10-04 19:13:23 UTC (rev 2205) @@ -0,0 +1 @@ +trivial-gray-streams

Added: branches/trunk-reorg/thirdparty/trivial-gray-streams-2006-09-16/CVS/Root =================================================================== --- branches/trunk-reorg/thirdparty/trivial-gray-streams-2006-09-16/CVS/Root 2007-10-04 19:10:49 UTC (rev 2204) +++ branches/trunk-reorg/thirdparty/trivial-gray-streams-2006-09-16/CVS/Root 2007-10-04 19:13:23 UTC (rev 2205) @@ -0,0 +1 @@ +:ext:dlichteblau@common-lisp.net:/project/cl-plus-ssl/cvsroot

Added: branches/trunk-reorg/thirdparty/trivial-gray-streams-2006-09-16/Makefile =================================================================== --- branches/trunk-reorg/thirdparty/trivial-gray-streams-2006-09-16/Makefile 2007-10-04 19:10:49 UTC (rev 2204) +++ branches/trunk-reorg/thirdparty/trivial-gray-streams-2006-09-16/Makefile 2007-10-04 19:13:23 UTC (rev 2205) @@ -0,0 +1,3 @@ +.PHONY: clean +clean: + rm -f *.fasl *.x86f *.fas *.ufsl *.lib *.pfsl

Added: branches/trunk-reorg/thirdparty/trivial-gray-streams-2006-09-16/README =================================================================== --- branches/trunk-reorg/thirdparty/trivial-gray-streams-2006-09-16/README 2007-10-04 19:10:49 UTC (rev 2204) +++ branches/trunk-reorg/thirdparty/trivial-gray-streams-2006-09-16/README 2007-10-04 19:13:23 UTC (rev 2205) @@ -0,0 +1,37 @@ +trivial-gray-streams +==================== + +This system provides an extremely thin compatibility layer for gray +streams. It is nearly *too* trivial for a complete package, except that +I have copy&pasted this code into enough projects now that I decided to +factor it out once again now, and then *never* have to touch it again. + + +How to use it +============= + +1. Use the package TRIVIAL-GRAY-STREAMS instead of whatever + implementation-specific package you would have to use otherwise to + get at gray stream symbols. +2. For STREAM-READ-SEQUENCE and STREAM-WRITE-SEQUENCE, notice that we + use two required arguments and allow additional keyword arguments. + So the lambda list when defining a method on either function should look + like this: + (stream sequence start end &key) +3. In order for (2) to work on all Lisps, make sure to subclass all your + stream classes from TRIVIAL-GRAY-STREAM-MIXIN if you intend to define + methods on those two generic functions. + + +Extensions +========== + +Generic function STREAM-READ-SEQUENCE (stream sequence start end &key) +Generic function STREAM-WRITE-SEQUENCE (stream sequence start end &key) + + See above. + +Generic function STREAM-FILE-POSITION (stream) => file position +Generic function (SETF STREAM-FILE-POSITION) (position-spec stream) => successp + + Will only be called by LispWorks and CLISP.

Added: branches/trunk-reorg/thirdparty/trivial-gray-streams-2006-09-16/mixin.lisp =================================================================== --- branches/trunk-reorg/thirdparty/trivial-gray-streams-2006-09-16/mixin.lisp 2007-10-04 19:10:49 UTC (rev 2204) +++ branches/trunk-reorg/thirdparty/trivial-gray-streams-2006-09-16/mixin.lisp 2007-10-04 19:13:23 UTC (rev 2205) @@ -0,0 +1,117 @@ +(in-package :trivial-gray-streams) + +(defclass trivial-gray-stream-mixin () ()) + +(defgeneric stream-read-sequence + (stream sequence start end &key &allow-other-keys)) +(defgeneric stream-write-sequence + (stream sequence start end &key &allow-other-keys)) + +(defgeneric stream-file-position (stream)) +(defgeneric (setf stream-file-position) (newval stream)) + +(defmethod stream-write-string + ((stream trivial-gray-stream-mixin) seq &optional start end) + (stream-write-sequence stream seq (or start 0) (or end (length seq)))) + +;; Implementations should provide this default method, I believe, but +;; at least sbcl and allegro don't. +(defmethod stream-terpri ((stream trivial-gray-stream-mixin)) + (write-char #\newline stream)) + +(defmethod stream-file-position ((stream trivial-gray-stream-mixin)) + nil) + +(defmethod (setf stream-file-position) + (newval (stream trivial-gray-stream-mixin)) + (declare (ignore newval)) + nil) + +#+allegro +(progn + (defmethod excl:stream-read-sequence + ((s trivial-gray-stream-mixin) seq &optional start end) + (stream-read-sequence s seq (or start 0) (or end (length seq)))) + (defmethod stream:stream-write-sequence + ((s trivial-gray-stream-mixin) seq &optional start end) + (stream-write-sequence s seq (or start 0) (or end (length seq))))) + +#+cmu +(progn + (defmethod ext:stream-read-sequence + ((s trivial-gray-stream-mixin) seq &optional start end) + (stream-read-sequence s seq (or start 0) (or end (length seq)))) + (defmethod ext:stream-write-sequence + ((s trivial-gray-stream-mixin) seq &optional start end) + (stream-write-sequence s seq (or start 0) (or end (length seq))))) + +#+lispworks +(progn + (defmethod stream:stream-read-sequence + ((s trivial-gray-stream-mixin) seq start end) + (stream-read-sequence s seq start end)) + (defmethod stream:stream-write-sequence + ((s trivial-gray-stream-mixin) seq start end) + (stream-write-sequence s seq start end)) + + (defmethod stream:stream-file-position ((stream trivial-gray-stream-mixin)) + (stream-file-position stream)) + (defmethod (setf stream:stream-file-position) + (newval (stream trivial-gray-stream-mixin)) + (setf (stream-file-position stream) newval))) + +#+openmcl +(progn + (defmethod ccl:stream-read-vector + ((s trivial-gray-stream-mixin) seq start end) + (stream-read-sequence s seq start end)) + (defmethod ccl:stream-write-vector + ((s trivial-gray-stream-mixin) seq start end) + (stream-write-sequence s seq start end))) + +#+clisp +(progn + (defmethod gray:stream-read-byte-sequence + ((s trivial-gray-stream-mixin) + seq + &optional start end no-hang interactive) + (when no-hang + (error "this stream does not support the NO-HANG argument")) + (when interactive + (error "this stream does not support the INTERACTIVE argument")) + (stream-read-sequence s seq start end)) + + (defmethod gray:stream-write-byte-sequence + ((s trivial-gray-stream-mixin) + seq + &optional start end no-hang interactive) + (when no-hang + (error "this stream does not support the NO-HANG argument")) + (when interactive + (error "this stream does not support the INTERACTIVE argument")) + (stream-write-sequence s seq start end)) + + (defmethod gray:stream-read-char-sequence + ((s trivial-gray-stream-mixin) seq &optional start end) + (stream-read-sequence s seq start end)) + + (defmethod gray:stream-write-char-sequence + ((s trivial-gray-stream-mixin) seq &optional start end) + (stream-write-sequence s seq start end)) + + (defmethod gray:stream-position ((stream trivial-gray-stream-mixin) position) + (if position + (setf (stream-file-position stream) position) + (stream-file-position stream)))) + +#+sbcl +(progn + (defmethod sb-gray:stream-read-sequence + ((s trivial-gray-stream-mixin) seq &optional start end) + (stream-read-sequence s seq (or start 0) (or end (length seq)))) + (defmethod sb-gray:stream-write-sequence + ((s trivial-gray-stream-mixin) seq &optional start end) + (stream-write-sequence s seq (or start 0) (or end (length seq)))) + ;; SBCL extension: + (defmethod sb-gray:stream-line-length ((stream trivial-gray-stream-mixin)) + 80))

Added: branches/trunk-reorg/thirdparty/trivial-gray-streams-2006-09-16/package.lisp =================================================================== --- branches/trunk-reorg/thirdparty/trivial-gray-streams-2006-09-16/package.lisp 2007-10-04 19:10:49 UTC (rev 2204) +++ branches/trunk-reorg/thirdparty/trivial-gray-streams-2006-09-16/package.lisp 2007-10-04 19:13:23 UTC (rev 2205) @@ -0,0 +1,44 @@ +(in-package :trivial-gray-streams-system) + +#+cmu +(eval-when (:compile-toplevel :load-toplevel :execute) + (require :gray-streams)) + +#+allegro +(eval-when (:compile-toplevel :load-toplevel :execute) + (unless (fboundp 'stream:stream-write-string) + (require "streamc.fasl"))) + +(macrolet + ((frob () + (let + ((common-symbols + '(#:fundamental-stream #:fundamental-input-stream + #:fundamental-output-stream #:fundamental-character-stream + #:fundamental-binary-stream #:fundamental-character-input-stream + #:fundamental-character-output-stream + #:fundamental-binary-input-stream + #:fundamental-binary-output-stream #:stream-read-char + #:stream-unread-char #:stream-read-char-no-hang + #:stream-peek-char #:stream-listen #:stream-read-line + #:stream-clear-input #:stream-write-char #:stream-line-column + #:stream-start-line-p #:stream-write-string #:stream-terpri + #:stream-fresh-line #:stream-finish-output #:stream-force-output + #:stream-clear-output #:stream-advance-to-column + #:stream-read-byte #:stream-write-byte))) + `(defpackage :trivial-gray-streams + (:use :cl) + (:import-from #+sbcl :sb-gray + #+allegro :excl + #+cmu :ext + #+clisp :gray + #+openmcl :ccl + #+lispworks :stream + #-(or sbcl allegro cmu clisp openmcl lispworks) ... + ,@common-symbols) + (:export #:trivial-gray-stream-mixin + #:stream-read-sequence + #:stream-write-sequence + #:stream-file-position + ,@common-symbols))))) + (frob))

Added: branches/trunk-reorg/thirdparty/trivial-gray-streams-2006-09-16/trivial-gray-streams.asd =================================================================== --- branches/trunk-reorg/thirdparty/trivial-gray-streams-2006-09-16/trivial-gray-streams.asd 2007-10-04 19:10:49 UTC (rev 2204) +++ branches/trunk-reorg/thirdparty/trivial-gray-streams-2006-09-16/trivial-gray-streams.asd 2007-10-04 19:13:23 UTC (rev 2205) @@ -0,0 +1,9 @@ +;;; -*- mode: lisp -*- + +(defpackage :trivial-gray-streams-system +(:use :cl :asdf)) +(in-package :trivial-gray-streams-system) + +(defsystem :trivial-gray-streams + :serial t + :components ((:file "package") (:file "mixin")))