[bknr-cvs] r2205 - in branches/trunk-reorg/thirdparty: . puri-1.5.1 trivial-gray-streams-2006-09-16 trivial-gray-streams-2006-09-16/CVS
bknr at bknr.net
bknr at bknr.net
Thu Oct 4 19:13:25 UTC 2007
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 at 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 at 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 , at 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 , at 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) , at 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 , at 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|zop")))
+ res)
+ (push
+ '(test-error
+ (puri:parse-uri "http://foo.com/bar?a=zip|zop")
+ :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_onWebEvent(hrfTIOLI)?selGetClubOffer.TB_OFFER_ID_OFFER=344879%2e0&selGetClubOffer.TB_OFFER_ID_ITEM=34487%2e0&selGetClubOffer.TB_OFFER_ID_OFFER=344879%2e0&^CSpCommand.currRowNumber=5&hrfTIOLI=The+Visual+Basic+6+Programmer%27s+Toolkit&SPIDERSESSION=%3f%3f%3f%3f%3f%5f%3f%3f%3f%40%5b%3f%3f%3f%3fBOs%5cH%3f%3f%3f%3f%3f%3f%3f%3f%3fMMpXO%5f%40JG%7d%40%5c%5f%3f%3f%3fECK%5dt%3fLDT%3fTBD%3fDDTxPEToBS%40%5f%5dBDgXVoKBSDs%7cDT%3fK%3fd%3fTIb%7ceHbkeMfh%60LRpO%5cact%5eUC%7bMu%5fyWUGzLUhP%5ebpdWRka%5dFO%3f%5dBopW%3f%40HMrxbMRd%60LOpuMVga%3fv%3fTS%3fpODT%40O&%5euniqueValue=977933764843")))
+ res)
+ (push
+ '(test-error
+ (puri:parse-uri
+ "http://scbc.booksonline.com/cgi-bin/ndCGI.exe/Develop/pagClubHome.hrfTIOLI_onWebEvent(hrfTIOLI)?selGetClubOffer.TB_OFFER_ID_OFFER=344879%2e0&selGetClubOffer.TB_OFFER_ID_ITEM=34487%2e0&selGetClubOffer.TB_OFFER_ID_OFFER=344879%2e0&^CSpCommand.currRowNumber=5&hrfTIOLI=The+Visual+Basic+6+Programmer%27s+Toolkit&SPIDERSESSION=%3f%3f%3f%3f%3f%5f%3f%3f%3f%40%5b%3f%3f%3f%3fBOs%5cH%3f%3f%3f%3f%3f%3f%3f%3f%3fMMpXO%5f%40JG%7d%40%5c%5f%3f%3f%3fECK%5dt%3fLDT%3fTBD%3fDDTxPEToBS%40%5f%5dBDgXVoKBSDs%7cDT%3fK%3fd%3fTIb%7ceHbkeMfh%60LRpO%5cact%5eUC%7bMu%5fyWUGzLUhP%5ebpdWRka%5dFO%3f%5dBopW%3f%40HMrxbMRd%60LOpuMVga%3fv%3fTS%3fpODT%40O&%5euniqueValue=977933764843")
+ :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/">http://www.franz.com/support/documentation/</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">http://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>&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>&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>&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 = "%" hex hex
+
+hex = digit | "A" | "B" | "C" | "D" | "E" | "F" | "a" | "b" | "c" | "d" | "e" | "f"
+</pre>
+
+<p>In addition, the RFC defines excluded characters: </p>
+
+<pre>
+"<" | ">" | "#" | "%" | <"> | "{" | "}" | "|" | "\" | "^" | "[" | "]" | "`"
+</pre>
+
+<p>The set of reserved characters are: </p>
+
+<pre>
+";" | "/" | "?" | ":" | "@" | "&" | "=" | "+" | "$" | ","
+</pre>
+
+<p>with the following exceptions:
+
+<ul>
+ <li>within the authority component, the characters ";", ":",
+ "@", "?", and "/" are reserved. </li>
+ <li>within a path segment, the characters "/", ";", "=", and
+ "?" are reserved. </li>
+ <li>within a query component, the characters ";", "/", "?",
+ ":", "@", "&", "=", "+",
+ ",", and "$" 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
+"/") 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
+"calculator" and "3/2". "3%2f2" 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 "foo;10/bar:x;y;z/baz.htm"))
+</pre>
+
+<p>is </p>
+
+<pre>
+(:relative ("foo" "10") ("bar:x" "y" "z") "baz.htm")
+</pre>
+
+<p>There is a certain amount of canonicalization that occurs when parsing:
+
+<ul>
+ <li>A path of <code>(:absolute)</code> or <code>(:absolute "")</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>"foob%61r"</code>
+ is parsed into <code>"foobar"</code> and appears as <code>"foobar"</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 "http://www.franz.com")
+ (intern-uri "http://www.franz.com"))
+</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>&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>&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>&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>&optional
+ <i>uri-space result) </i>&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 "http://www.franz.com/")</code> <br>
+ <code>(parse-uri "http://www.franz.com"))</code> <br>
+ <code>(eq (intern-uri "http://www.franz.com/")</code> <br>
+ <code>(intern-uri "http://www.franz.com"))</code><br>
+ </li>
+ <li>The following is true: <br>
+ <code>(eq (intern-uri "http://www.franz.com:80/foo/bar.htm")</code> <br>
+ <code>(intern-uri "http://www.franz.com/foo/bar.htm"))</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"..."</code> is shorthand for <code>(parse-uri "...")</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"http://foo.bar.com/foo/bar")
+#<uri http://foo.bar.com/foo/bar>
+user(11): (setf (net.uri:uri-host u) "foo.com")
+"foo.com"
+user(12): u
+#<uri http://foo.com/foo/bar>
+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 "foo")
+#<uri foo>
+uri(12): #u"foo"
+#<uri foo>
+uri(13): (setq base (intern-uri "http://www.franz.com/foo/bar/"))
+#<uri http://www.franz.com/foo/bar/>
+uri(14): (merge-uris (parse-uri "foo.htm") base)
+#<uri http://www.franz.com/foo/bar/foo.htm>
+uri(15): (merge-uris (parse-uri "?foo") base)
+#<uri http://www.franz.com/foo/bar/?foo>
+uri(16): (setq base (intern-uri "http://www.franz.com/foo/bar/baz.htm"))
+#<uri http://www.franz.com/foo/bar/baz.htm>
+uri(17): (merge-uris (parse-uri "foo.htm") base)
+#<uri http://www.franz.com/foo/bar/foo.htm>
+uri(18): (merge-uris #u"?foo" base)
+#<uri http://www.franz.com/foo/bar/?foo>
+uri(19): (describe #u"http://www.franz.com")
+#<uri http://www.franz.com> is an instance of #<standard-class net.uri:uri>:
+ The following slots have :instance allocation:
+ scheme :http
+ host "www.franz.com"
+ port nil
+ path nil
+ query nil
+ fragment nil
+ plist nil
+ escaped nil
+ string "http://www.franz.com"
+ parsed-path nil
+ hashcode nil
+uri(20): (describe #u"http://www.franz.com/")
+#<uri http://www.franz.com> is an instance of #<standard-class net.uri:uri>:
+ The following slots have :instance allocation:
+ scheme :http
+ host "www.franz.com"
+ port nil
+ path nil
+ query nil
+ fragment nil
+ plist nil
+ escaped nil
+ string "http://www.franz.com"
+ parsed-path nil
+ hashcode nil
+uri(21): #u"foobar#baz%23xxx"
+#<uri foobar#baz#xxx>
+</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 at 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) ...
+ , at common-symbols)
+ (:export #:trivial-gray-stream-mixin
+ #:stream-read-sequence
+ #:stream-write-sequence
+ #:stream-file-position
+ , at 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")))
More information about the Bknr-cvs
mailing list