Initial revision
This commit is contained in:
david
459
xml/COPYING
Normal file
459
xml/COPYING
Normal file
@ -0,0 +1,459 @@
|
||||
GNU LESSER GENERAL PUBLIC LICENSE
|
||||
Version 2.1, February 1999
|
||||
|
||||
Copyright (C) 1991, 1999 Free Software Foundation, Inc.
|
||||
59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
|
||||
Everyone is permitted to copy and distribute verbatim copies
|
||||
of this license document, but changing it is not allowed.
|
||||
|
||||
[This is the first released version of the Lesser GPL. It also counts
|
||||
as the successor of the GNU Library Public License, version 2, hence
|
||||
the version number 2.1.]
|
||||
|
||||
Preamble
|
||||
|
||||
The licenses for most software are designed to take away your
|
||||
freedom to share and change it. By contrast, the GNU General Public
|
||||
Licenses are intended to guarantee your freedom to share and change
|
||||
free software--to make sure the software is free for all its users.
|
||||
|
||||
This license, the Lesser General Public License, applies to some
|
||||
specially designated software packages--typically libraries--of the
|
||||
Free Software Foundation and other authors who decide to use it. You
|
||||
can use it too, but we suggest you first think carefully about whether
|
||||
this license or the ordinary General Public License is the better
|
||||
strategy to use in any particular case, based on the explanations below.
|
||||
|
||||
When we speak of free software, we are referring to freedom of use,
|
||||
not price. Our General Public Licenses are designed to make sure that
|
||||
you have the freedom to distribute copies of free software (and charge
|
||||
for this service if you wish); that you receive source code or can get
|
||||
it if you want it; that you can change the software and use pieces of
|
||||
it in new free programs; and that you are informed that you can do
|
||||
these things.
|
||||
|
||||
To protect your rights, we need to make restrictions that forbid
|
||||
distributors to deny you these rights or to ask you to surrender these
|
||||
rights. These restrictions translate to certain responsibilities for
|
||||
you if you distribute copies of the library or if you modify it.
|
||||
|
||||
For example, if you distribute copies of the library, whether gratis
|
||||
or for a fee, you must give the recipients all the rights that we gave
|
||||
you. You must make sure that they, too, receive or can get the source
|
||||
code. If you link other code with the library, you must provide
|
||||
complete object files to the recipients, so that they can relink them
|
||||
with the library after making changes to the library and recompiling
|
||||
it. And you must show them these terms so they know their rights.
|
||||
|
||||
We protect your rights with a two-step method: (1) we copyright the
|
||||
library, and (2) we offer you this license, which gives you legal
|
||||
permission to copy, distribute and/or modify the library.
|
||||
|
||||
To protect each distributor, we want to make it very clear that
|
||||
there is no warranty for the free library. Also, if the library is
|
||||
modified by someone else and passed on, the recipients should know
|
||||
that what they have is not the original version, so that the original
|
||||
author's reputation will not be affected by problems that might be
|
||||
introduced by others.
|
||||
|
||||
Finally, software patents pose a constant threat to the existence of
|
||||
any free program. We wish to make sure that a company cannot
|
||||
effectively restrict the users of a free program by obtaining a
|
||||
restrictive license from a patent holder. Therefore, we insist that
|
||||
any patent license obtained for a version of the library must be
|
||||
consistent with the full freedom of use specified in this license.
|
||||
|
||||
Most GNU software, including some libraries, is covered by the
|
||||
ordinary GNU General Public License. This license, the GNU Lesser
|
||||
General Public License, applies to certain designated libraries, and
|
||||
is quite different from the ordinary General Public License. We use
|
||||
this license for certain libraries in order to permit linking those
|
||||
libraries into non-free programs.
|
||||
|
||||
When a program is linked with a library, whether statically or using
|
||||
a shared library, the combination of the two is legally speaking a
|
||||
combined work, a derivative of the original library. The ordinary
|
||||
General Public License therefore permits such linking only if the
|
||||
entire combination fits its criteria of freedom. The Lesser General
|
||||
Public License permits more lax criteria for linking other code with
|
||||
the library.
|
||||
|
||||
We call this license the "Lesser" General Public License because it
|
||||
does Less to protect the user's freedom than the ordinary General
|
||||
Public License. It also provides other free software developers Less
|
||||
of an advantage over competing non-free programs. These disadvantages
|
||||
are the reason we use the ordinary General Public License for many
|
||||
libraries. However, the Lesser license provides advantages in certain
|
||||
special circumstances.
|
||||
|
||||
For example, on rare occasions, there may be a special need to
|
||||
encourage the widest possible use of a certain library, so that it becomes
|
||||
a de-facto standard. To achieve this, non-free programs must be
|
||||
allowed to use the library. A more frequent case is that a free
|
||||
library does the same job as widely used non-free libraries. In this
|
||||
case, there is little to gain by limiting the free library to free
|
||||
software only, so we use the Lesser General Public License.
|
||||
|
||||
In other cases, permission to use a particular library in non-free
|
||||
programs enables a greater number of people to use a large body of
|
||||
free software. For example, permission to use the GNU C Library in
|
||||
non-free programs enables many more people to use the whole GNU
|
||||
operating system, as well as its variant, the GNU/Linux operating
|
||||
system.
|
||||
|
||||
Although the Lesser General Public License is Less protective of the
|
||||
users' freedom, it does ensure that the user of a program that is
|
||||
linked with the Library has the freedom and the wherewithal to run
|
||||
that program using a modified version of the Library.
|
||||
|
||||
The precise terms and conditions for copying, distribution and
|
||||
modification follow. Pay close attention to the difference between a
|
||||
"work based on the library" and a "work that uses the library". The
|
||||
former contains code derived from the library, whereas the latter must
|
||||
be combined with the library in order to run.
|
||||
|
||||
GNU LESSER GENERAL PUBLIC LICENSE
|
||||
TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
|
||||
|
||||
0. This License Agreement applies to any software library or other
|
||||
program which contains a notice placed by the copyright holder or
|
||||
other authorized party saying it may be distributed under the terms of
|
||||
this Lesser General Public License (also called "this License").
|
||||
Each licensee is addressed as "you".
|
||||
|
||||
A "library" means a collection of software functions and/or data
|
||||
prepared so as to be conveniently linked with application programs
|
||||
(which use some of those functions and data) to form executables.
|
||||
|
||||
The "Library", below, refers to any such software library or work
|
||||
which has been distributed under these terms. A "work based on the
|
||||
Library" means either the Library or any derivative work under
|
||||
copyright law: that is to say, a work containing the Library or a
|
||||
portion of it, either verbatim or with modifications and/or translated
|
||||
straightforwardly into another language. (Hereinafter, translation is
|
||||
included without limitation in the term "modification".)
|
||||
|
||||
"Source code" for a work means the preferred form of the work for
|
||||
making modifications to it. For a library, complete source code means
|
||||
all the source code for all modules it contains, plus any associated
|
||||
interface definition files, plus the scripts used to control compilation
|
||||
and installation of the library.
|
||||
|
||||
Activities other than copying, distribution and modification are not
|
||||
covered by this License; they are outside its scope. The act of
|
||||
running a program using the Library is not restricted, and output from
|
||||
such a program is covered only if its contents constitute a work based
|
||||
on the Library (independent of the use of the Library in a tool for
|
||||
writing it). Whether that is true depends on what the Library does
|
||||
and what the program that uses the Library does.
|
||||
|
||||
1. You may copy and distribute verbatim copies of the Library's
|
||||
complete source code as you receive it, in any medium, provided that
|
||||
you conspicuously and appropriately publish on each copy an
|
||||
appropriate copyright notice and disclaimer of warranty; keep intact
|
||||
all the notices that refer to this License and to the absence of any
|
||||
warranty; and distribute a copy of this License along with the
|
||||
Library.
|
||||
|
||||
You may charge a fee for the physical act of transferring a copy,
|
||||
and you may at your option offer warranty protection in exchange for a
|
||||
fee.
|
||||
|
||||
2. You may modify your copy or copies of the Library or any portion
|
||||
of it, thus forming a work based on the Library, and copy and
|
||||
distribute such modifications or work under the terms of Section 1
|
||||
above, provided that you also meet all of these conditions:
|
||||
|
||||
a) The modified work must itself be a software library.
|
||||
|
||||
b) You must cause the files modified to carry prominent notices
|
||||
stating that you changed the files and the date of any change.
|
||||
|
||||
c) You must cause the whole of the work to be licensed at no
|
||||
charge to all third parties under the terms of this License.
|
||||
|
||||
d) If a facility in the modified Library refers to a function or a
|
||||
table of data to be supplied by an application program that uses
|
||||
the facility, other than as an argument passed when the facility
|
||||
is invoked, then you must make a good faith effort to ensure that,
|
||||
in the event an application does not supply such function or
|
||||
table, the facility still operates, and performs whatever part of
|
||||
its purpose remains meaningful.
|
||||
|
||||
(For example, a function in a library to compute square roots has
|
||||
a purpose that is entirely well-defined independent of the
|
||||
application. Therefore, Subsection 2d requires that any
|
||||
application-supplied function or table used by this function must
|
||||
be optional: if the application does not supply it, the square
|
||||
root function must still compute square roots.)
|
||||
|
||||
These requirements apply to the modified work as a whole. If
|
||||
identifiable sections of that work are not derived from the Library,
|
||||
and can be reasonably considered independent and separate works in
|
||||
themselves, then this License, and its terms, do not apply to those
|
||||
sections when you distribute them as separate works. But when you
|
||||
distribute the same sections as part of a whole which is a work based
|
||||
on the Library, the distribution of the whole must be on the terms of
|
||||
this License, whose permissions for other licensees extend to the
|
||||
entire whole, and thus to each and every part regardless of who wrote
|
||||
it.
|
||||
|
||||
Thus, it is not the intent of this section to claim rights or contest
|
||||
your rights to work written entirely by you; rather, the intent is to
|
||||
exercise the right to control the distribution of derivative or
|
||||
collective works based on the Library.
|
||||
|
||||
In addition, mere aggregation of another work not based on the Library
|
||||
with the Library (or with a work based on the Library) on a volume of
|
||||
a storage or distribution medium does not bring the other work under
|
||||
the scope of this License.
|
||||
|
||||
3. You may opt to apply the terms of the ordinary GNU General Public
|
||||
License instead of this License to a given copy of the Library. To do
|
||||
this, you must alter all the notices that refer to this License, so
|
||||
that they refer to the ordinary GNU General Public License, version 2,
|
||||
instead of to this License. (If a newer version than version 2 of the
|
||||
ordinary GNU General Public License has appeared, then you can specify
|
||||
that version instead if you wish.) Do not make any other change in
|
||||
these notices.
|
||||
|
||||
Once this change is made in a given copy, it is irreversible for
|
||||
that copy, so the ordinary GNU General Public License applies to all
|
||||
subsequent copies and derivative works made from that copy.
|
||||
|
||||
This option is useful when you wish to copy part of the code of
|
||||
the Library into a program that is not a library.
|
||||
|
||||
4. You may copy and distribute the Library (or a portion or
|
||||
derivative of it, under Section 2) in object code or executable form
|
||||
under the terms of Sections 1 and 2 above provided that you accompany
|
||||
it with the complete corresponding machine-readable source code, which
|
||||
must be distributed under the terms of Sections 1 and 2 above on a
|
||||
medium customarily used for software interchange.
|
||||
|
||||
If distribution of object code is made by offering access to copy
|
||||
from a designated place, then offering equivalent access to copy the
|
||||
source code from the same place satisfies the requirement to
|
||||
distribute the source code, even though third parties are not
|
||||
compelled to copy the source along with the object code.
|
||||
|
||||
5. A program that contains no derivative of any portion of the
|
||||
Library, but is designed to work with the Library by being compiled or
|
||||
linked with it, is called a "work that uses the Library". Such a
|
||||
work, in isolation, is not a derivative work of the Library, and
|
||||
therefore falls outside the scope of this License.
|
||||
|
||||
However, linking a "work that uses the Library" with the Library
|
||||
creates an executable that is a derivative of the Library (because it
|
||||
contains portions of the Library), rather than a "work that uses the
|
||||
library". The executable is therefore covered by this License.
|
||||
Section 6 states terms for distribution of such executables.
|
||||
|
||||
When a "work that uses the Library" uses material from a header file
|
||||
that is part of the Library, the object code for the work may be a
|
||||
derivative work of the Library even though the source code is not.
|
||||
Whether this is true is especially significant if the work can be
|
||||
linked without the Library, or if the work is itself a library. The
|
||||
threshold for this to be true is not precisely defined by law.
|
||||
|
||||
If such an object file uses only numerical parameters, data
|
||||
structure layouts and accessors, and small macros and small inline
|
||||
functions (ten lines or less in length), then the use of the object
|
||||
file is unrestricted, regardless of whether it is legally a derivative
|
||||
work. (Executables containing this object code plus portions of the
|
||||
Library will still fall under Section 6.)
|
||||
|
||||
Otherwise, if the work is a derivative of the Library, you may
|
||||
distribute the object code for the work under the terms of Section 6.
|
||||
Any executables containing that work also fall under Section 6,
|
||||
whether or not they are linked directly with the Library itself.
|
||||
|
||||
6. As an exception to the Sections above, you may also combine or
|
||||
link a "work that uses the Library" with the Library to produce a
|
||||
work containing portions of the Library, and distribute that work
|
||||
under terms of your choice, provided that the terms permit
|
||||
modification of the work for the customer's own use and reverse
|
||||
engineering for debugging such modifications.
|
||||
|
||||
You must give prominent notice with each copy of the work that the
|
||||
Library is used in it and that the Library and its use are covered by
|
||||
this License. You must supply a copy of this License. If the work
|
||||
during execution displays copyright notices, you must include the
|
||||
copyright notice for the Library among them, as well as a reference
|
||||
directing the user to the copy of this License. Also, you must do one
|
||||
of these things:
|
||||
|
||||
a) Accompany the work with the complete corresponding
|
||||
machine-readable source code for the Library including whatever
|
||||
changes were used in the work (which must be distributed under
|
||||
Sections 1 and 2 above); and, if the work is an executable linked
|
||||
with the Library, with the complete machine-readable "work that
|
||||
uses the Library", as object code and/or source code, so that the
|
||||
user can modify the Library and then relink to produce a modified
|
||||
executable containing the modified Library. (It is understood
|
||||
that the user who changes the contents of definitions files in the
|
||||
Library will not necessarily be able to recompile the application
|
||||
to use the modified definitions.)
|
||||
|
||||
b) Use a suitable shared library mechanism for linking with the
|
||||
Library. A suitable mechanism is one that (1) uses at run time a
|
||||
copy of the library already present on the user's computer system,
|
||||
rather than copying library functions into the executable, and (2)
|
||||
will operate properly with a modified version of the library, if
|
||||
the user installs one, as long as the modified version is
|
||||
interface-compatible with the version that the work was made with.
|
||||
|
||||
c) Accompany the work with a written offer, valid for at
|
||||
least three years, to give the same user the materials
|
||||
specified in Subsection 6a, above, for a charge no more
|
||||
than the cost of performing this distribution.
|
||||
|
||||
d) If distribution of the work is made by offering access to copy
|
||||
from a designated place, offer equivalent access to copy the above
|
||||
specified materials from the same place.
|
||||
|
||||
e) Verify that the user has already received a copy of these
|
||||
materials or that you have already sent this user a copy.
|
||||
|
||||
For an executable, the required form of the "work that uses the
|
||||
Library" must include any data and utility programs needed for
|
||||
reproducing the executable from it. However, as a special exception,
|
||||
the materials to be distributed need not include anything that is
|
||||
normally distributed (in either source or binary form) with the major
|
||||
components (compiler, kernel, and so on) of the operating system on
|
||||
which the executable runs, unless that component itself accompanies
|
||||
the executable.
|
||||
|
||||
It may happen that this requirement contradicts the license
|
||||
restrictions of other proprietary libraries that do not normally
|
||||
accompany the operating system. Such a contradiction means you cannot
|
||||
use both them and the Library together in an executable that you
|
||||
distribute.
|
||||
|
||||
7. You may place library facilities that are a work based on the
|
||||
Library side-by-side in a single library together with other library
|
||||
facilities not covered by this License, and distribute such a combined
|
||||
library, provided that the separate distribution of the work based on
|
||||
the Library and of the other library facilities is otherwise
|
||||
permitted, and provided that you do these two things:
|
||||
|
||||
a) Accompany the combined library with a copy of the same work
|
||||
based on the Library, uncombined with any other library
|
||||
facilities. This must be distributed under the terms of the
|
||||
Sections above.
|
||||
|
||||
b) Give prominent notice with the combined library of the fact
|
||||
that part of it is a work based on the Library, and explaining
|
||||
where to find the accompanying uncombined form of the same work.
|
||||
|
||||
8. You may not copy, modify, sublicense, link with, or distribute
|
||||
the Library except as expressly provided under this License. Any
|
||||
attempt otherwise to copy, modify, sublicense, link with, or
|
||||
distribute the Library is void, and will automatically terminate your
|
||||
rights under this License. However, parties who have received copies,
|
||||
or rights, from you under this License will not have their licenses
|
||||
terminated so long as such parties remain in full compliance.
|
||||
|
||||
9. You are not required to accept this License, since you have not
|
||||
signed it. However, nothing else grants you permission to modify or
|
||||
distribute the Library or its derivative works. These actions are
|
||||
prohibited by law if you do not accept this License. Therefore, by
|
||||
modifying or distributing the Library (or any work based on the
|
||||
Library), you indicate your acceptance of this License to do so, and
|
||||
all its terms and conditions for copying, distributing or modifying
|
||||
the Library or works based on it.
|
||||
|
||||
10. Each time you redistribute the Library (or any work based on the
|
||||
Library), the recipient automatically receives a license from the
|
||||
original licensor to copy, distribute, link with or modify the Library
|
||||
subject to these terms and conditions. You may not impose any further
|
||||
restrictions on the recipients' exercise of the rights granted herein.
|
||||
You are not responsible for enforcing compliance by third parties with
|
||||
this License.
|
||||
|
||||
11. If, as a consequence of a court judgment or allegation of patent
|
||||
infringement or for any other reason (not limited to patent issues),
|
||||
conditions are imposed on you (whether by court order, agreement or
|
||||
otherwise) that contradict the conditions of this License, they do not
|
||||
excuse you from the conditions of this License. If you cannot
|
||||
distribute so as to satisfy simultaneously your obligations under this
|
||||
License and any other pertinent obligations, then as a consequence you
|
||||
may not distribute the Library at all. For example, if a patent
|
||||
license would not permit royalty-free redistribution of the Library by
|
||||
all those who receive copies directly or indirectly through you, then
|
||||
the only way you could satisfy both it and this License would be to
|
||||
refrain entirely from distribution of the Library.
|
||||
|
||||
If any portion of this section is held invalid or unenforceable under any
|
||||
particular circumstance, the balance of the section is intended to apply,
|
||||
and the section as a whole is intended to apply in other circumstances.
|
||||
|
||||
It is not the purpose of this section to induce you to infringe any
|
||||
patents or other property right claims or to contest validity of any
|
||||
such claims; this section has the sole purpose of protecting the
|
||||
integrity of the free software distribution system which is
|
||||
implemented by public license practices. Many people have made
|
||||
generous contributions to the wide range of software distributed
|
||||
through that system in reliance on consistent application of that
|
||||
system; it is up to the author/donor to decide if he or she is willing
|
||||
to distribute software through any other system and a licensee cannot
|
||||
impose that choice.
|
||||
|
||||
This section is intended to make thoroughly clear what is believed to
|
||||
be a consequence of the rest of this License.
|
||||
|
||||
12. If the distribution and/or use of the Library is restricted in
|
||||
certain countries either by patents or by copyrighted interfaces, the
|
||||
original copyright holder who places the Library under this License may add
|
||||
an explicit geographical distribution limitation excluding those countries,
|
||||
so that distribution is permitted only in or among countries not thus
|
||||
excluded. In such case, this License incorporates the limitation as if
|
||||
written in the body of this License.
|
||||
|
||||
13. The Free Software Foundation may publish revised and/or new
|
||||
versions of the Lesser General Public License from time to time.
|
||||
Such new versions will be similar in spirit to the present version,
|
||||
but may differ in detail to address new problems or concerns.
|
||||
|
||||
Each version is given a distinguishing version number. If the Library
|
||||
specifies a version number of this License which applies to it and
|
||||
"any later version", you have the option of following the terms and
|
||||
conditions either of that version or of any later version published by
|
||||
the Free Software Foundation. If the Library does not specify a
|
||||
license version number, you may choose any version ever published by
|
||||
the Free Software Foundation.
|
||||
|
||||
14. If you wish to incorporate parts of the Library into other free
|
||||
programs whose distribution conditions are incompatible with these,
|
||||
write to the author to ask for permission. For software which is
|
||||
copyrighted by the Free Software Foundation, write to the Free
|
||||
Software Foundation; we sometimes make exceptions for this. Our
|
||||
decision will be guided by the two goals of preserving the free status
|
||||
of all derivatives of our free software and of promoting the sharing
|
||||
and reuse of software generally.
|
||||
|
||||
NO WARRANTY
|
||||
|
||||
15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO
|
||||
WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW.
|
||||
EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR
|
||||
OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY
|
||||
KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE
|
||||
IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE
|
||||
LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME
|
||||
THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION.
|
||||
|
||||
16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN
|
||||
WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY
|
||||
AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU
|
||||
FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR
|
||||
CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE
|
||||
LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING
|
||||
RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A
|
||||
FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF
|
||||
SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH
|
||||
DAMAGES.
|
||||
|
||||
END OF TERMS AND CONDITIONS
|
||||
|
||||
161
xml/catalog.lisp
Normal file
161
xml/catalog.lisp
Normal file
@ -0,0 +1,161 @@
|
||||
;;;; catalogs.lisp -- XML Catalogs -*- Mode: Lisp; readtable: runes -*-
|
||||
;;;;
|
||||
;;;; This file is part of the CXML parser, released under (L)LGPL.
|
||||
;;;; See file COPYING for details.
|
||||
;;;;
|
||||
;;;; Developed 2004 for headcraft - http://headcraft.de/
|
||||
;;;; Copyright: David Lichteblau
|
||||
|
||||
(in-package :cxml)
|
||||
|
||||
;;; http://www.oasis-open.org/committees/entity/spec.html
|
||||
;;;
|
||||
;;; Bugs:
|
||||
;;; - We validate using the Catalog DTD while parsing, which is too strict
|
||||
;;; and will will fail to parse files using other parser's extensions.
|
||||
;;; (Jedenfalls behauptet das die Spec.)
|
||||
;;; A long-term solution might be an XML Schema validator.
|
||||
;;;
|
||||
;;; XXX Das mit dem :dtd geht natuerlich gar nicht. Die Option muss weg.
|
||||
|
||||
(defvar *prefer* nil)
|
||||
(defvar *catalog*
|
||||
'(;; libxml standard
|
||||
"/etc/xml/catalog"
|
||||
;; FreeBSD
|
||||
"/usr/local/share/xml/catalog.ports"))
|
||||
|
||||
(defparameter *catalog-dtd* nil)
|
||||
|
||||
(defun parse-catalog (files)
|
||||
(let ((result '()))
|
||||
(loop
|
||||
(let ((file (pop files)))
|
||||
(unless file
|
||||
(return))
|
||||
(multiple-value-bind (entries next) (parse-catalog-file file)
|
||||
(setf result (append result entries))
|
||||
(setf files (append next files)))))
|
||||
result))
|
||||
|
||||
(defun parse-catalog-file (uri)
|
||||
(handler-case
|
||||
(parse-catalog-file/strict uri)
|
||||
(file-error () nil)
|
||||
(parser-error () nil)))
|
||||
|
||||
(defun parse-catalog-file/strict (uri)
|
||||
(when (stringp uri)
|
||||
(setf uri (puri:parse-uri uri)))
|
||||
(unless *catalog-dtd*
|
||||
(let ((cxml
|
||||
(slot-value (asdf:find-system :cxml) 'asdf::relative-pathname)))
|
||||
(setf *catalog-dtd*
|
||||
(parse-dtd-file (merge-pathnames "catalog.dtd" cxml)))))
|
||||
(with-open-stream (s (open (uri-to-pathname uri)
|
||||
:element-type '(unsigned-byte 8)
|
||||
:direction :input))
|
||||
(parse-stream s
|
||||
(make-instance 'catalog-parser :uri uri)
|
||||
:validate t
|
||||
;; XXX das geht nicht
|
||||
:dtd *catalog-dtd*)))
|
||||
|
||||
(defclass catalog-parser ()
|
||||
((entries :initform '() :accessor entries)
|
||||
(next :initform '() :accessor next)
|
||||
(prefer-stack :initform (list *prefer*) :accessor prefer-stack)
|
||||
(base-stack :accessor base-stack)))
|
||||
|
||||
(defmethod initialize-instance :after
|
||||
((instance catalog-parser) &key uri)
|
||||
(setf (base-stack instance) (list uri)))
|
||||
|
||||
(defmethod prefer ((handler catalog-parser))
|
||||
(car (prefer-stack handler)))
|
||||
|
||||
(defmethod base ((handler catalog-parser))
|
||||
(car (base-stack handler)))
|
||||
|
||||
(defun get-attribute/lname (name attributes)
|
||||
(member name attributes
|
||||
:key (lambda (a)
|
||||
(or (sax:attribute-local-name a)
|
||||
(sax:attribute-qname a)))
|
||||
:test #'rod=))
|
||||
|
||||
(defmethod sax:start-element ((handler catalog-parser) uri lname qname attrs)
|
||||
(declare (ignore uri))
|
||||
(setf lname (or lname qname))
|
||||
;; we can dispatch on lnames only because we validate against the DTD,
|
||||
;; which disallows other namespaces.
|
||||
(push (string-or (get-attribute/lname #"prefer" attrs) (prefer handler))
|
||||
(prefer-stack handler))
|
||||
(push (string-or (get-attribute/lname #"base" attrs) (base handler))
|
||||
(base-stack handler))
|
||||
(cond
|
||||
((rod= lname #"public")
|
||||
(push (list :public
|
||||
(get-attribute/lname #"publicId" attrs)
|
||||
(puri:merge-uris
|
||||
(puri:parse-uri (get-attribute/lname #"uri" attrs))
|
||||
(base handler)))
|
||||
(entries handler)))
|
||||
((rod= lname #"system")
|
||||
(push (list :system
|
||||
(get-attribute/lname #"systemId" attrs)
|
||||
(puri:merge-uris
|
||||
(puri:parse-uri (get-attribute/lname #"uri" attrs))
|
||||
(base handler)))
|
||||
(entries handler)))
|
||||
((rod= lname #"uri")
|
||||
(push (list :uri
|
||||
(get-attribute/lname #"name" attrs)
|
||||
(puri:merge-uris
|
||||
(puri:parse-uri (get-attribute/lname #"uri" attrs))
|
||||
(base handler)))
|
||||
(entries handler)))
|
||||
((rod= lname #"rewriteSystem")
|
||||
(push (list :rewrite-system
|
||||
(get-attribute/lname #"systemIdStartString" attrs)
|
||||
(get-attribute/lname #"rewritePrefix" attrs))
|
||||
(entries handler)))
|
||||
((rod= lname #"rewriteURI")
|
||||
(push (list :rewrite-uri
|
||||
(get-attribute/lname #"uriStartString" attrs)
|
||||
(get-attribute/lname #"rewritePrefix" attrs))
|
||||
(entries handler)))
|
||||
((rod= lname #"delegatePublic")
|
||||
(push (list :delegate-public
|
||||
(get-attribute/lname #"publicIdStartString" attrs)
|
||||
(puri:merge-uris
|
||||
(puri:parse-uri (get-attribute/lname #"catalog" attrs))
|
||||
(base handler)))
|
||||
(entries handler)))
|
||||
((rod= lname #"delegateSystem")
|
||||
(push (list :delegate-system
|
||||
(get-attribute/lname #"systemIdStartString" attrs)
|
||||
(puri:merge-uris
|
||||
(puri:parse-uri (get-attribute/lname #"catalog" attrs))
|
||||
(base handler)))
|
||||
(entries handler)))
|
||||
((rod= lname #"delegateURI")
|
||||
(push (list :delegate-uri
|
||||
(get-attribute/lname #"uriStartString" attrs)
|
||||
(puri:merge-uris
|
||||
(puri:parse-uri (get-attribute/lname #"catalog" attrs))
|
||||
(base handler)))
|
||||
(entries handler)))
|
||||
((rod= lname #"nextCatalog")
|
||||
(push (puri:merge-uris
|
||||
(puri:parse-uri (get-attribute/lname #"catalog" attrs))
|
||||
(base handler))
|
||||
(next handler)))))
|
||||
|
||||
(defmethod sax:end-element ((handler catalog-parser) uri lname qname)
|
||||
(declare (ignore uri lname qname))
|
||||
(pop (base-stack handler))
|
||||
(pop (prefer-stack handler)))
|
||||
|
||||
(defmethod sax:end-document ((handler catalog-parser))
|
||||
(values (reverse (entries handler)) (reverse (next handler))))
|
||||
127
xml/characters.lisp
Normal file
127
xml/characters.lisp
Normal file
@ -0,0 +1,127 @@
|
||||
;;; XXX wird derzeit in DOM:CREATE-ATTRIBUTE verwendet. Muesste aber wohl vom
|
||||
;;; Parser auch schon geprueft werden. Vorher sollte man allerdings die
|
||||
;;; Geschwindigkeit der Sache mal untersuchen.
|
||||
|
||||
(in-package :xml)
|
||||
|
||||
(defun valid-name-p (rod)
|
||||
(and (not (zerop (length rod)))
|
||||
(let ((initial (elt rod 0)))
|
||||
(or (rune-in-range-p initial *base-char-ranges*)
|
||||
(rune-in-range-p initial *ideographic-ranges*)
|
||||
(eql initial #.(char-code #\_))
|
||||
(eql initial #.(char-code #\:))))
|
||||
(every #'rune-name-char-p rod)))
|
||||
|
||||
(defun rune-name-char-p (rune)
|
||||
(or (rune-in-range-p rune *base-char-ranges*)
|
||||
(rune-in-range-p rune *ideographic-ranges*)
|
||||
(eql rune #.(char-code #\.))
|
||||
(eql rune #.(char-code #\-))
|
||||
(eql rune #.(char-code #\_))
|
||||
(eql rune #.(char-code #\:))
|
||||
(rune-in-range-p rune *combining-char-ranges*)
|
||||
(rune-in-range-p rune *extender-ranges*)))
|
||||
|
||||
(defun rune-in-range-p (rune range)
|
||||
;; XXX FIXME, das geht doch besser
|
||||
(block nil
|
||||
(map nil (lambda (range)
|
||||
(when (< rune (car range))
|
||||
(return nil))
|
||||
(when (<= rune (cadr range))
|
||||
(return t)))
|
||||
range)))
|
||||
|
||||
(defparameter *base-char-ranges*
|
||||
#((#x0041 #x005A) (#x0061 #x007A) (#x00C0 #x00D6) (#x00D8 #x00F6)
|
||||
(#x00F8 #x00FF) (#x0100 #x0131) (#x0134 #x013E) (#x0141 #x0148)
|
||||
(#x014A #x017E) (#x0180 #x01C3) (#x01CD #x01F0) (#x01F4 #x01F5)
|
||||
(#x01FA #x0217) (#x0250 #x02A8) (#x02BB #x02C1) (#x0386 #x0386)
|
||||
(#x0388 #x038A) (#x038C #x038C) (#x038E #x03A1) (#x03A3 #x03CE)
|
||||
(#x03D0 #x03D6) (#x03DA #x03DA) (#x03DC #x03DC) (#x03DE #x03DE)
|
||||
(#x03E0 #x03E0) (#x03E2 #x03F3) (#x0401 #x040C) (#x040E #x044F)
|
||||
(#x0451 #x045C) (#x045E #x0481) (#x0490 #x04C4) (#x04C7 #x04C8)
|
||||
(#x04CB #x04CC) (#x04D0 #x04EB) (#x04EE #x04F5) (#x04F8 #x04F9)
|
||||
(#x0531 #x0556) (#x0559 #x0559) (#x0561 #x0586) (#x05D0 #x05EA)
|
||||
(#x05F0 #x05F2) (#x0621 #x063A) (#x0641 #x064A) (#x0671 #x06B7)
|
||||
(#x06BA #x06BE) (#x06C0 #x06CE) (#x06D0 #x06D3) (#x06D5 #x06D5)
|
||||
(#x06E5 #x06E6) (#x0905 #x0939) (#x093D #x093D) (#x0958 #x0961)
|
||||
(#x0985 #x098C) (#x098F #x0990) (#x0993 #x09A8) (#x09AA #x09B0)
|
||||
(#x09B2 #x09B2) (#x09B6 #x09B9) (#x09DC #x09DD) (#x09DF #x09E1)
|
||||
(#x09F0 #x09F1) (#x0A05 #x0A0A) (#x0A0F #x0A10) (#x0A13 #x0A28)
|
||||
(#x0A2A #x0A30) (#x0A32 #x0A33) (#x0A35 #x0A36) (#x0A38 #x0A39)
|
||||
(#x0A59 #x0A5C) (#x0A5E #x0A5E) (#x0A72 #x0A74) (#x0A85 #x0A8B)
|
||||
(#x0A8D #x0A8D) (#x0A8F #x0A91) (#x0A93 #x0AA8) (#x0AAA #x0AB0)
|
||||
(#x0AB2 #x0AB3) (#x0AB5 #x0AB9) (#x0ABD #x0ABD) (#x0AE0 #x0AE0)
|
||||
(#x0B05 #x0B0C) (#x0B0F #x0B10) (#x0B13 #x0B28) (#x0B2A #x0B30)
|
||||
(#x0B32 #x0B33) (#x0B36 #x0B39) (#x0B3D #x0B3D) (#x0B5C #x0B5D)
|
||||
(#x0B5F #x0B61) (#x0B85 #x0B8A) (#x0B8E #x0B90) (#x0B92 #x0B95)
|
||||
(#x0B99 #x0B9A) (#x0B9C #x0B9C) (#x0B9E #x0B9F) (#x0BA3 #x0BA4)
|
||||
(#x0BA8 #x0BAA) (#x0BAE #x0BB5) (#x0BB7 #x0BB9) (#x0C05 #x0C0C)
|
||||
(#x0C0E #x0C10) (#x0C12 #x0C28) (#x0C2A #x0C33) (#x0C35 #x0C39)
|
||||
(#x0C60 #x0C61) (#x0C85 #x0C8C) (#x0C8E #x0C90) (#x0C92 #x0CA8)
|
||||
(#x0CAA #x0CB3) (#x0CB5 #x0CB9) (#x0CDE #x0CDE) (#x0CE0 #x0CE1)
|
||||
(#x0D05 #x0D0C) (#x0D0E #x0D10) (#x0D12 #x0D28) (#x0D2A #x0D39)
|
||||
(#x0D60 #x0D61) (#x0E01 #x0E2E) (#x0E30 #x0E30) (#x0E32 #x0E33)
|
||||
(#x0E40 #x0E45) (#x0E81 #x0E82) (#x0E84 #x0E84) (#x0E87 #x0E88)
|
||||
(#x0E8A #x0E8A) (#x0E8D #x0E8D) (#x0E94 #x0E97) (#x0E99 #x0E9F)
|
||||
(#x0EA1 #x0EA3) (#x0EA5 #x0EA5) (#x0EA7 #x0EA7) (#x0EAA #x0EAB)
|
||||
(#x0EAD #x0EAE) (#x0EB0 #x0EB0) (#x0EB2 #x0EB3) (#x0EBD #x0EBD)
|
||||
(#x0EC0 #x0EC4) (#x0F40 #x0F47) (#x0F49 #x0F69) (#x10A0 #x10C5)
|
||||
(#x10D0 #x10F6) (#x1100 #x1100) (#x1102 #x1103) (#x1105 #x1107)
|
||||
(#x1109 #x1109) (#x110B #x110C) (#x110E #x1112) (#x113C #x113C)
|
||||
(#x113E #x113E) (#x1140 #x1140) (#x114C #x114C) (#x114E #x114E)
|
||||
(#x1150 #x1150) (#x1154 #x1155) (#x1159 #x1159) (#x115F #x1161)
|
||||
(#x1163 #x1163) (#x1165 #x1165) (#x1167 #x1167) (#x1169 #x1169)
|
||||
(#x116D #x116E) (#x1172 #x1173) (#x1175 #x1175) (#x119E #x119E)
|
||||
(#x11A8 #x11A8) (#x11AB #x11AB) (#x11AE #x11AF) (#x11B7 #x11B8)
|
||||
(#x11BA #x11BA) (#x11BC #x11C2) (#x11EB #x11EB) (#x11F0 #x11F0)
|
||||
(#x11F9 #x11F9) (#x1E00 #x1E9B) (#x1EA0 #x1EF9) (#x1F00 #x1F15)
|
||||
(#x1F18 #x1F1D) (#x1F20 #x1F45) (#x1F48 #x1F4D) (#x1F50 #x1F57)
|
||||
(#x1F59 #x1F59) (#x1F5B #x1F5B) (#x1F5D #x1F5D) (#x1F5F #x1F7D)
|
||||
(#x1F80 #x1FB4) (#x1FB6 #x1FBC) (#x1FBE #x1FBE) (#x1FC2 #x1FC4)
|
||||
(#x1FC6 #x1FCC) (#x1FD0 #x1FD3) (#x1FD6 #x1FDB) (#x1FE0 #x1FEC)
|
||||
(#x1FF2 #x1FF4) (#x1FF6 #x1FFC) (#x2126 #x2126) (#x212A #x212B)
|
||||
(#x212E #x212E) (#x2180 #x2182) (#x3041 #x3094) (#x30A1 #x30FA)
|
||||
(#x3105 #x312C) (#xAC00 #xD7A3)))
|
||||
|
||||
(defparameter *ideographic-ranges*
|
||||
#((#x4E00 #x9FA5) (#x3007 #x3007) (#x3021 #x3029)))
|
||||
|
||||
(defparameter *combining-char-ranges*
|
||||
#((#x0300 #x0345) (#x0360 #x0361) (#x0483 #x0486) (#x0591 #x05A1)
|
||||
(#x05A3 #x05B9) (#x05BB #x05BD) (#x05BF #x05BF) (#x05C1 #x05C2)
|
||||
(#x05C4 #x05C4) (#x064B #x0652) (#x0670 #x0670) (#x06D6 #x06DC)
|
||||
(#x06DD #x06DF) (#x06E0 #x06E4) (#x06E7 #x06E8) (#x06EA #x06ED)
|
||||
(#x0901 #x0903) (#x093C #x093C) (#x093E #x094C) (#x094D #x094D)
|
||||
(#x0951 #x0954) (#x0962 #x0963) (#x0981 #x0983) (#x09BC #x09BC)
|
||||
(#x09BE #x09BE) (#x09BF #x09BF) (#x09C0 #x09C4) (#x09C7 #x09C8)
|
||||
(#x09CB #x09CD) (#x09D7 #x09D7) (#x09E2 #x09E3) (#x0A02 #x0A02)
|
||||
(#x0A3C #x0A3C) (#x0A3E #x0A3E) (#x0A3F #x0A3F) (#x0A40 #x0A42)
|
||||
(#x0A47 #x0A48) (#x0A4B #x0A4D) (#x0A70 #x0A71) (#x0A81 #x0A83)
|
||||
(#x0ABC #x0ABC) (#x0ABE #x0AC5) (#x0AC7 #x0AC9) (#x0ACB #x0ACD)
|
||||
(#x0B01 #x0B03) (#x0B3C #x0B3C) (#x0B3E #x0B43) (#x0B47 #x0B48)
|
||||
(#x0B4B #x0B4D) (#x0B56 #x0B57) (#x0B82 #x0B83) (#x0BBE #x0BC2)
|
||||
(#x0BC6 #x0BC8) (#x0BCA #x0BCD) (#x0BD7 #x0BD7) (#x0C01 #x0C03)
|
||||
(#x0C3E #x0C44) (#x0C46 #x0C48) (#x0C4A #x0C4D) (#x0C55 #x0C56)
|
||||
(#x0C82 #x0C83) (#x0CBE #x0CC4) (#x0CC6 #x0CC8) (#x0CCA #x0CCD)
|
||||
(#x0CD5 #x0CD6) (#x0D02 #x0D03) (#x0D3E #x0D43) (#x0D46 #x0D48)
|
||||
(#x0D4A #x0D4D) (#x0D57 #x0D57) (#x0E31 #x0E31) (#x0E34 #x0E3A)
|
||||
(#x0E47 #x0E4E) (#x0EB1 #x0EB1) (#x0EB4 #x0EB9) (#x0EBB #x0EBC)
|
||||
(#x0EC8 #x0ECD) (#x0F18 #x0F19) (#x0F35 #x0F35) (#x0F37 #x0F37)
|
||||
(#x0F39 #x0F39) (#x0F3E #x0F3E) (#x0F3F #x0F3F) (#x0F71 #x0F84)
|
||||
(#x0F86 #x0F8B) (#x0F90 #x0F95) (#x0F97 #x0F97) (#x0F99 #x0FAD)
|
||||
(#x0FB1 #x0FB7) (#x0FB9 #x0FB9) (#x20D0 #x20DC) (#x20E1 #x20E1)
|
||||
(#x302A #x302F) (#x3099 #x3099) (#x309A #x309A)))
|
||||
|
||||
(defparameter *digit-ranges*
|
||||
#((#x0030 #x0039) (#x0660 #x0669) (#x06F0 #x06F9) (#x0966 #x096F)
|
||||
(#x09E6 #x09EF) (#x0A66 #x0A6F) (#x0AE6 #x0AEF) (#x0B66 #x0B6F)
|
||||
(#x0BE7 #x0BEF) (#x0C66 #x0C6F) (#x0CE6 #x0CEF) (#x0D66 #x0D6F)
|
||||
(#x0E50 #x0E59) (#x0ED0 #x0ED9) (#x0F20 #x0F29)))
|
||||
|
||||
(defparameter *extender-ranges*
|
||||
#((#x00B7 #x00B7) (#x02D0 #x02D0) (#x02D1 #x02D1) (#x0387 #x0387)
|
||||
(#x0640 #x0640) (#x0E46 #x0E46) (#x0EC6 #x0EC6) (#x3005 #x3005)
|
||||
(#x3031 #x3035) (#x309D #x309E) (#x30FC #x30FE)))
|
||||
46
xml/dom-builder.lisp
Normal file
46
xml/dom-builder.lisp
Normal file
@ -0,0 +1,46 @@
|
||||
(in-package :dom-impl)
|
||||
|
||||
(export 'dom-builder)
|
||||
|
||||
(defclass dom-builder ()
|
||||
((document :initform nil :accessor document)
|
||||
(element-stack :initform '() :accessor element-stack)))
|
||||
|
||||
(defmethod sax:start-document ((handler dom-builder))
|
||||
(let ((document (make-instance 'dom-impl::document))
|
||||
(doctype (make-instance 'dom-impl::document-type
|
||||
:notations (make-hash-table :test #'equalp))))
|
||||
(setf (slot-value document 'dom-impl::owner) document
|
||||
(slot-value document 'dom-impl::doc-type) doctype)
|
||||
(setf (document handler) document)
|
||||
(push document (element-stack handler))))
|
||||
|
||||
(defmethod sax:end-document ((handler dom-builder))
|
||||
(setf (slot-value (document handler) 'children )
|
||||
(nreverse (slot-value (document handler) 'children)))
|
||||
(document handler))
|
||||
|
||||
(defmethod sax:start-element ((handler dom-builder) namespace-uri local-name qname attributes)
|
||||
(with-slots (document element-stack) handler
|
||||
(let ((element (dom:create-element document qname))
|
||||
(parent (car element-stack)))
|
||||
(dolist (attr attributes)
|
||||
(dom:set-attribute element (xml::attribute-qname attr) (xml::attribute-value attr)))
|
||||
(setf (slot-value element 'dom-impl::parent) parent)
|
||||
(push element (slot-value parent 'dom-impl::children))
|
||||
(push element element-stack))))
|
||||
|
||||
(defmethod sax:end-element ((handler dom-builder) namespace-uri local-name qname)
|
||||
(let ((element (pop (element-stack handler))))
|
||||
(setf (slot-value element 'dom-impl::children)
|
||||
(nreverse (slot-value element 'dom-impl::children)))))
|
||||
|
||||
(defmethod sax:characters ((handler dom-builder) data)
|
||||
(with-slots (document element-stack) handler
|
||||
(let ((node (dom:create-text-node document data)))
|
||||
(push node (slot-value (car element-stack) 'dom-impl::children)))))
|
||||
|
||||
(defmethod sax:processing-instruction ((handler dom-builder) target data)
|
||||
(with-slots (document element-stack) handler
|
||||
(let ((node (dom:create-processing-instruction document target data)))
|
||||
(push node (slot-value (car element-stack) 'dom-impl::children)))))
|
||||
512
xml/dom-impl.lisp
Normal file
512
xml/dom-impl.lisp
Normal file
@ -0,0 +1,512 @@
|
||||
(defpackage :dom-impl
|
||||
(:use :glisp))
|
||||
|
||||
(in-package :dom-impl)
|
||||
|
||||
;; Classes
|
||||
|
||||
(defclass node ()
|
||||
((parent :initarg :parent :initform nil)
|
||||
(children :initarg :children :initform nil)
|
||||
(owner :initarg :owner :initform nil)))
|
||||
|
||||
(defclass document (node)
|
||||
((doc-type :initarg :doc-type :reader dom:doctype)))
|
||||
|
||||
(defclass document-fragment (node)
|
||||
())
|
||||
|
||||
(defclass character-data (node)
|
||||
((data :initarg :data :reader dom:data)))
|
||||
|
||||
(defclass attribute (node)
|
||||
((name :initarg :name :reader dom:name)
|
||||
(value :initarg :value :reader dom:value)
|
||||
(specified-p :initarg :specified-p :reader dom:specified)))
|
||||
|
||||
(defclass element (node)
|
||||
((tag-name :initarg :tag-name :reader dom:tag-name)
|
||||
(attributes :initarg :attributes :reader dom:attributes
|
||||
:initform (make-instance 'named-node-map))))
|
||||
|
||||
(defclass text (character-data)
|
||||
())
|
||||
|
||||
(defclass comment (character-data)
|
||||
())
|
||||
|
||||
(defclass cdata-section (text)
|
||||
())
|
||||
|
||||
(defclass document-type (node)
|
||||
((name :initarg :name :reader dom:name)
|
||||
(entities :initarg :entities :reader dom:entities)
|
||||
(notations :initarg :notations :reader dom:notations)))
|
||||
|
||||
(defclass notation (node)
|
||||
((name :initarg :name :reader dom:name)
|
||||
(public-id :initarg :public-id :reader dom:public-id)
|
||||
(system-id :initarg :system-id :reader dom:system-id)))
|
||||
|
||||
(defclass entity (node)
|
||||
((name :initarg :name :reader dom:name)
|
||||
(public-id :initarg :public-id :reader dom:public-id)
|
||||
(system-id :initarg :system-id :reader dom:system-id)
|
||||
(notation-name :initarg :notation-name :reader dom:notation-name)))
|
||||
|
||||
(defclass entity-reference (node)
|
||||
((name :initarg :name :reader dom:name)))
|
||||
|
||||
(defclass processing-instruction (node)
|
||||
((target :initarg :target :reader dom:target)
|
||||
(data :initarg :data :reader dom:data)))
|
||||
|
||||
(defclass named-node-map ()
|
||||
((items :initarg :items :reader dom:items
|
||||
:initform nil) ))
|
||||
|
||||
|
||||
;;; Implementation
|
||||
|
||||
;; document-fragment protocol
|
||||
;; document protocol
|
||||
|
||||
(defmethod dom:implementation ((document document))
|
||||
'implementation)
|
||||
|
||||
(defmethod dom:document-element ((document document))
|
||||
(dolist (k (dom:child-nodes document))
|
||||
(cond ((typep k 'element)
|
||||
(return k)))))
|
||||
|
||||
(defmethod dom:create-element ((document document) tag-name)
|
||||
(setf tag-name (rod tag-name))
|
||||
(make-instance 'element
|
||||
:tag-name tag-name
|
||||
:owner document))
|
||||
|
||||
(defmethod dom:create-document-fragment ((document document))
|
||||
(make-instance 'document-fragment
|
||||
:owner document))
|
||||
|
||||
(defmethod dom:create-text-node ((document document) data)
|
||||
(setf data (rod data))
|
||||
(make-instance 'text
|
||||
:data data
|
||||
:owner document))
|
||||
|
||||
(defmethod dom:create-comment ((document document) data)
|
||||
(setf data (rod data))
|
||||
(make-instance 'comment
|
||||
:data data
|
||||
:owner document))
|
||||
|
||||
(defmethod dom:create-cdata-section ((document document) data)
|
||||
(setf data (rod data))
|
||||
(make-instance 'cdata-section
|
||||
:data data
|
||||
:owner document))
|
||||
|
||||
(defmethod dom:create-processing-instruction ((document document) target data)
|
||||
(setf target (rod target))
|
||||
(setf data (rod data))
|
||||
(make-instance 'processing-instruction
|
||||
:owner document
|
||||
:target target
|
||||
:data data))
|
||||
|
||||
(defmethod dom:create-attribute ((document document) name)
|
||||
(setf name (rod name))
|
||||
(make-instance 'attribute
|
||||
:name name
|
||||
:specified-p nil ;???
|
||||
:owner document))
|
||||
|
||||
(defmethod dom:create-entity-reference ((document document) name)
|
||||
(setf name (rod name))
|
||||
(make-instance 'entity-reference
|
||||
:name name
|
||||
:owner document))
|
||||
|
||||
(defmethod dom:get-elements-by-tag-name ((document document) tag-name)
|
||||
(setf tag-name (rod tag-name))
|
||||
(let ((result nil))
|
||||
(setf tag-name (rod tag-name))
|
||||
(let ((wild-p (rod= tag-name '#.(string-rod "*"))))
|
||||
(labels ((walk (n)
|
||||
(when (and (dom:element-p n)
|
||||
(or wild-p (tag-name-eq tag-name (dom:node-name n))))
|
||||
(push n result))
|
||||
(mapc #'walk (dom:child-nodes n))))
|
||||
(walk document)
|
||||
(reverse result)))))
|
||||
|
||||
;;; Node
|
||||
|
||||
(defmethod dom:parent-node ((node node))
|
||||
(slot-value node 'parent))
|
||||
|
||||
(defmethod dom:child-nodes ((node node))
|
||||
(slot-value node 'children))
|
||||
|
||||
(defmethod dom:first-child ((node node))
|
||||
(car (slot-value node 'children)))
|
||||
|
||||
(defmethod dom:last-child ((node node))
|
||||
(car (last (slot-value node 'children))))
|
||||
|
||||
(defmethod dom:previous-sibling ((node node))
|
||||
(with-slots (parent) node
|
||||
(when parent
|
||||
(with-slots (children) parent
|
||||
(do ((q children (cdr q)))
|
||||
((null (cdr q)) niL)
|
||||
(cond ((eq (cadr q) node)
|
||||
(return (car q)))))))))
|
||||
|
||||
(defmethod dom:next-sibling ((node node))
|
||||
(with-slots (parent) node
|
||||
(when parent
|
||||
(with-slots (children) parent
|
||||
(do ((q children (cdr q)))
|
||||
((null (cdr q)) niL)
|
||||
(cond ((eq (car q) node)
|
||||
(return (cadr q)))))))))
|
||||
|
||||
(defmethod dom:owner-document ((node node))
|
||||
(slot-value node 'owner))
|
||||
|
||||
(defun ensure-valid-insertion-request (node new-child)
|
||||
(unless (can-adopt-p node new-child)
|
||||
;; HIERARCHY_REQUEST_ERR
|
||||
(error "~S cannot adopt ~S." node new-child))
|
||||
(unless (eq (dom:owner-document node)
|
||||
(dom:owner-document new-child))
|
||||
;; WRONG_DOCUMENT_ERR
|
||||
(error "~S cannot adopt ~S, since it was created by a different document."
|
||||
node new-child))
|
||||
(with-slots (children) node
|
||||
(unless (null (slot-value new-child 'parent))
|
||||
(cond ((eq (slot-value new-child 'parent)
|
||||
node)
|
||||
;; remove it first
|
||||
(setf children (delete new-child children)))
|
||||
(t
|
||||
;; otherwise it is an error.
|
||||
;; GB_INTEGRITY_ERR
|
||||
(error "~S is already adopted." new-child)))) ))
|
||||
|
||||
(defmethod dom:insert-before ((node node) (new-child node) (ref-child t))
|
||||
(ensure-valid-insertion-request node new-child)
|
||||
(with-slots (children) node
|
||||
(cond ((eq (car children) ref-child)
|
||||
(setf (slot-value new-child 'parent) node)
|
||||
(setf children (cons new-child children)))
|
||||
(t
|
||||
(do ((q children (cdr q)))
|
||||
((null (cdr q))
|
||||
(cond ((null ref-child)
|
||||
(setf (slot-value new-child 'parent) node)
|
||||
(setf (cdr q) (cons new-child nil)))
|
||||
(t
|
||||
;; NOT_FOUND_ERR
|
||||
(error "~S is no child of ~S." ref-child node))))
|
||||
(cond ((eq (cadr q) ref-child)
|
||||
(setf (slot-value new-child 'parent) node)
|
||||
(setf (cdr q) (cons new-child (cdr q)))
|
||||
(return))))))
|
||||
new-child))
|
||||
|
||||
(defmethod dom:insert-before ((node node) (fragment document-fragment) ref-child)
|
||||
(dolist (child (dom:child-nodes fragment))
|
||||
(dom:insert-before node child ref-child))
|
||||
fragment)
|
||||
|
||||
(defmethod dom:replace-child ((node node) (new-child node) (old-child node))
|
||||
(ensure-valid-insertion-request node new-child)
|
||||
(with-slots (children) node
|
||||
(do ((q children (cdr q)))
|
||||
((null q)
|
||||
;; NOT_FOUND_ERR
|
||||
(error "~S is no child of ~S." old-child node))
|
||||
(cond ((eq (car q) old-child)
|
||||
(setf (car q) new-child)
|
||||
(setf (slot-value new-child 'parent) node)
|
||||
(setf (slot-value old-child 'parent) nil)
|
||||
(return))))
|
||||
old-child))
|
||||
|
||||
(defmethod dom:append-child ((node node) (new-child node))
|
||||
(ensure-valid-insertion-request node new-child)
|
||||
(with-slots (children) node
|
||||
(setf children (nconc children (list new-child)))
|
||||
(setf (slot-value new-child 'parent) node)
|
||||
new-child))
|
||||
|
||||
(defmethod dom:has-child-nodes ((node node))
|
||||
(not (null (slot-value node 'children))))
|
||||
|
||||
(defmethod dom:append-child ((node node) (new-child document-fragment))
|
||||
(dolist (child (dom:child-nodes new-child))
|
||||
(dom:append-child node child))
|
||||
new-child)
|
||||
|
||||
;; was auf node noch implemetiert werden muss:
|
||||
;; - node-type
|
||||
;; - can-adopt-p
|
||||
;; - ggf attributes
|
||||
;; - node-name
|
||||
;; - node-value
|
||||
|
||||
;; node-name
|
||||
|
||||
(defmethod dom:node-name ((self document))
|
||||
'#.(string-rod "#document"))
|
||||
|
||||
(defmethod dom:node-name ((self document-fragment))
|
||||
'#.(string-rod "#document-fragment"))
|
||||
|
||||
(defmethod dom:node-name ((self text))
|
||||
'#.(string-rod "#text"))
|
||||
|
||||
(defmethod dom:node-name ((self cdata-section))
|
||||
'#.(string-rod "#cdata-section"))
|
||||
|
||||
(defmethod dom:node-name ((self comment))
|
||||
'#.(string-rod "#comment"))
|
||||
|
||||
(defmethod dom:node-name ((self attribute))
|
||||
(dom:name self))
|
||||
|
||||
(defmethod dom:node-name ((self element))
|
||||
(dom:tag-name self))
|
||||
|
||||
(defmethod dom:node-name ((self document-type))
|
||||
(dom:name self))
|
||||
|
||||
(defmethod dom:node-name ((self notation))
|
||||
(dom:name self))
|
||||
|
||||
(defmethod dom:node-name ((self entity))
|
||||
(dom:name self))
|
||||
|
||||
(defmethod dom:node-name ((self entity-reference))
|
||||
(dom:name self))
|
||||
|
||||
(defmethod dom:node-name ((self processing-instruction))
|
||||
(dom:target self))
|
||||
|
||||
;; node-type
|
||||
|
||||
(defmethod dom:node-type ((self document)) :document)
|
||||
(defmethod dom:node-type ((self document-fragment)) :document-fragment)
|
||||
(defmethod dom:node-type ((self text)) :text)
|
||||
(defmethod dom:node-type ((self comment)) :comment)
|
||||
(defmethod dom:node-type ((self cdata-section)) :cdata-section)
|
||||
(defmethod dom:node-type ((self attribute)) :attribute)
|
||||
(defmethod dom:node-type ((self element)) :element)
|
||||
(defmethod dom:node-type ((self document-type)) :document-type)
|
||||
(defmethod dom:node-type ((self notation)) :notation)
|
||||
(defmethod dom:node-type ((self entity)) :entity)
|
||||
(defmethod dom:node-type ((self entity-reference)) :entity-reference)
|
||||
(defmethod dom:node-type ((self processing-instruction)) :processing-instruction)
|
||||
|
||||
;; node-value
|
||||
|
||||
(defmethod dom:node-value ((self document)) nil)
|
||||
(defmethod dom:node-value ((self document-fragment)) nil)
|
||||
(defmethod dom:node-value ((self character-data)) (dom:data self))
|
||||
(defmethod dom:node-value ((self attribute)) (dom:name self))
|
||||
(defmethod dom:node-value ((self element)) nil)
|
||||
(defmethod dom:node-value ((self document-type)) nil)
|
||||
(defmethod dom:node-value ((self notation)) nil)
|
||||
(defmethod dom:node-value ((self entity)) nil)
|
||||
(defmethod dom:node-value ((self entity-reference)) nil)
|
||||
(defmethod dom:node-value ((self processing-instruction)) (dom:data self))
|
||||
|
||||
;; attributes
|
||||
|
||||
;; (gibt es nur auf element)
|
||||
|
||||
(defmethod dom:attributes ((self node))
|
||||
nil)
|
||||
|
||||
;; dann fehlt noch can-adopt und attribute conventions fuer adoption
|
||||
|
||||
;;; NAMED-NODE-MAP
|
||||
|
||||
(defmethod dom:get-named-item ((self named-node-map) name)
|
||||
(setf name (rod name))
|
||||
(with-slots (items) self
|
||||
(dolist (k items nil)
|
||||
(cond ((rod= name (dom:node-name k))
|
||||
(return k))))))
|
||||
|
||||
(defmethod dom:set-named-item ((self named-node-map) arg)
|
||||
(let ((name (dom:node-name arg)))
|
||||
(with-slots (items) self
|
||||
(dolist (k items (progn (setf items (cons arg items))nil))
|
||||
(cond ((rod= name (dom:node-name k))
|
||||
(setf items (cons arg (delete k items)))
|
||||
(return k)))))))
|
||||
|
||||
(defmethod dom:remove-named-item ((self named-node-map) name)
|
||||
(setf name (rod name))
|
||||
(with-slots (items) self
|
||||
(dolist (k items nil)
|
||||
(cond ((rod= name (dom:node-name k))
|
||||
(setf items (delete k items))
|
||||
(return k))))))
|
||||
|
||||
(defmethod dom:length ((self named-node-map))
|
||||
(with-slots (items) self
|
||||
(length items)))
|
||||
|
||||
(defmethod dom:item ((self named-node-map) index)
|
||||
(with-slots (items) self
|
||||
(elt items index)))
|
||||
|
||||
;;; CHARACTER-DATA
|
||||
|
||||
(defmethod dom:length ((node character-data))
|
||||
(length (slot-value node 'value)))
|
||||
|
||||
(defmethod dom:substring-data ((node character-data) offset count)
|
||||
(subseq (slot-value node 'value) offset (+ offset count)))
|
||||
|
||||
(defmethod dom:append-data ((node character-data) arg)
|
||||
(setq arg (rod arg))
|
||||
(with-slots (value) node
|
||||
(setf value (concatenate (type-of value) value arg)))
|
||||
(values))
|
||||
|
||||
(defmethod dom:delete-data ((node character-data) offset count)
|
||||
(with-slots (value) node
|
||||
(let ((new (make-array (- (length value) count) :element-type (type-of value))))
|
||||
(replace new value
|
||||
:start1 0 :end1 offset
|
||||
:start2 0 :end2 offset)
|
||||
(replace new value
|
||||
:start1 offset :end1 (length new)
|
||||
:start2 (+ offset count) :end2 (length value))
|
||||
(setf value new)))
|
||||
(values))
|
||||
|
||||
(defmethod dom:replace-data ((node character-data) offset count arg)
|
||||
(setf arg (rod arg))
|
||||
(with-slots (value) node
|
||||
(replace value arg
|
||||
:start1 offset :end1 (+ offset count)
|
||||
:start2 0 :end2 count))
|
||||
(values))
|
||||
|
||||
;;; ATTR
|
||||
|
||||
;; hmm... value muss noch entities lesen und text-nodes in die hierarchie h<>ngen.
|
||||
|
||||
(defmethod (setf dom:value) (new-value (node attribute))
|
||||
(setf (slot-value node 'value) (rod new-value)))
|
||||
|
||||
;;; ELEMENT
|
||||
|
||||
(defmethod dom:get-attribute-node ((element element) name)
|
||||
(dom:get-named-item (dom:attributes element) name))
|
||||
|
||||
(defmethod dom:set-attribute-node ((element element) (new-attr attribute))
|
||||
(dom:set-named-item (dom:attributes element) new-attr))
|
||||
|
||||
(defmethod dom:get-attribute ((element element) name)
|
||||
(let ((a (dom:get-attribute-node element name)))
|
||||
(if a
|
||||
(dom:value a)
|
||||
nil)))
|
||||
|
||||
(defmethod dom:set-attribute ((element element) name value)
|
||||
(with-slots (owner) element
|
||||
(dom:set-attribute-node
|
||||
element (make-instance 'attribute
|
||||
:owner owner
|
||||
:name name
|
||||
:value value
|
||||
:specified-p t))
|
||||
(values)))
|
||||
|
||||
(defmethod dom:remove-attribute-node ((element element) (old-attr attribute))
|
||||
(let ((res (dom:remove-named-item element (dom:name old-attr))))
|
||||
(if res
|
||||
res
|
||||
;; NOT_FOUND_ERR
|
||||
(error "Attribute not found."))))
|
||||
|
||||
(defmethod dom:get-elements-by-tag-name ((element element) name)
|
||||
name
|
||||
(error "Not implemented."))
|
||||
|
||||
(defmethod dom:normalize ((element element))
|
||||
(error "Not implemented.") )
|
||||
|
||||
;;; TEXT
|
||||
|
||||
(defmethod dom:split-text ((text text) offset)
|
||||
offset
|
||||
(error "Not implemented."))
|
||||
|
||||
;;; COMMENT -- nix
|
||||
;;; CDATA-SECTION -- nix
|
||||
|
||||
;;; DOCUMENT-TYPE -- missing
|
||||
;;; NOTATION -- nix
|
||||
;;; ENTITY -- nix
|
||||
;;; ENTITY-REFERENCE -- nix
|
||||
;;; PROCESSING-INSTRUCTION -- nix
|
||||
|
||||
;; Notbehelf!
|
||||
(defun can-adopt-p (x y) x y t)
|
||||
|
||||
|
||||
;;; predicates
|
||||
|
||||
(defmethod dom:node-p ((object node)) t)
|
||||
(defmethod dom:node-p ((object t)) nil)
|
||||
|
||||
(defmethod dom:document-p ((object document)) t)
|
||||
(defmethod dom:document-p ((object t)) nil)
|
||||
|
||||
(defmethod dom:document-fragment-p ((object document-fragment)) t)
|
||||
(defmethod dom:document-fragment-p ((object t)) nil)
|
||||
|
||||
(defmethod dom:character-data-p ((object character-data)) t)
|
||||
(defmethod dom:character-data-p ((object t)) nil)
|
||||
|
||||
(defmethod dom:attribute-p ((object attribute)) t)
|
||||
(defmethod dom:attribute-p ((object t)) nil)
|
||||
|
||||
(defmethod dom:element-p ((object element)) t)
|
||||
(defmethod dom:element-p ((object t)) nil)
|
||||
|
||||
(defmethod dom:text-node-p ((object text)) t)
|
||||
(defmethod dom:text-node-p ((object t)) nil)
|
||||
|
||||
(defmethod dom:comment-p ((object comment)) t)
|
||||
(defmethod dom:comment-p ((object t)) nil)
|
||||
|
||||
(defmethod dom:cdata-section-p ((object cdata-section)) t)
|
||||
(defmethod dom:cdata-section-p ((object t)) nil)
|
||||
|
||||
(defmethod dom:document-type-p ((object document-type)) t)
|
||||
(defmethod dom:document-type-p ((object t)) nil)
|
||||
|
||||
(defmethod dom:notation-p ((object notation)) t)
|
||||
(defmethod dom:notation-p ((object t)) nil)
|
||||
|
||||
(defmethod dom:entity-p ((object entity)) t)
|
||||
(defmethod dom:entity-p ((object t)) nil)
|
||||
|
||||
(defmethod dom:entity-reference-p ((object entity-reference)) t)
|
||||
(defmethod dom:entity-reference-p ((object t)) nil)
|
||||
|
||||
(defmethod dom:processing-instruction-p ((object processing-instruction)) t)
|
||||
(defmethod dom:processing-instruction-p ((object t)) nil)
|
||||
|
||||
(defmethod dom:named-node-map-p ((object named-node-map)) t)
|
||||
(defmethod dom:named-node-map-p ((object t)) nil)
|
||||
102
xml/dompack.lisp
Normal file
102
xml/dompack.lisp
Normal file
@ -0,0 +1,102 @@
|
||||
(defpackage :dom
|
||||
(:use)
|
||||
(:export
|
||||
|
||||
;; methods
|
||||
#:has-feature
|
||||
#:doctype
|
||||
#:implementation
|
||||
#:document-element
|
||||
#:create-element
|
||||
#:create-document-fragment
|
||||
#:create-text-node
|
||||
#:create-comment
|
||||
#:create-cdata-section
|
||||
#:create-processing-instruction
|
||||
#:create-attribute
|
||||
#:create-entity-reference
|
||||
#:get-elements-by-tag-name
|
||||
#:node-name
|
||||
#:node-value
|
||||
#:node-type
|
||||
#:parent-node
|
||||
#:child-nodes
|
||||
#:first-child
|
||||
#:last-child
|
||||
#:previous-sibling
|
||||
#:next-sibling
|
||||
#:attributes
|
||||
#:owner-document
|
||||
#:insert-before
|
||||
#:replace-child
|
||||
#:remove-child
|
||||
#:append-child
|
||||
#:has-child-nodes
|
||||
#:clone-node
|
||||
#:item
|
||||
#:length
|
||||
#:get-named-item
|
||||
#:set-named-item
|
||||
#:remove-named-item
|
||||
#:data
|
||||
#:substring-data
|
||||
#:append-data
|
||||
#:insert-data
|
||||
#:delete-data
|
||||
#:replace-data
|
||||
#:name
|
||||
#:specified
|
||||
#:value
|
||||
#:tag-name
|
||||
#:get-attribute
|
||||
#:set-attribute
|
||||
#:remove-atttribute
|
||||
#:get-attribute-node
|
||||
#:set-attribute-node
|
||||
#:remove-attribute-node
|
||||
#:normalize
|
||||
#:split-text
|
||||
#:entities
|
||||
#:notations
|
||||
#:public-id
|
||||
#:system-id
|
||||
#:notation-name
|
||||
#:target
|
||||
|
||||
;; protocol classes
|
||||
#:dom-implementation
|
||||
#:document-fragment
|
||||
#:document
|
||||
#:node
|
||||
#:node-list
|
||||
#:named-node-map
|
||||
#:character-data
|
||||
#:attr
|
||||
#:element
|
||||
#:text
|
||||
#:comment
|
||||
#:cdata-section
|
||||
#:document-type
|
||||
#:notation
|
||||
#:entity
|
||||
#:entity-reference
|
||||
#:processing-instruction
|
||||
;;
|
||||
#:items
|
||||
;;
|
||||
#:node-p
|
||||
#:document-p
|
||||
#:document-fragment-p
|
||||
#:character-data-p
|
||||
#:attribute-p
|
||||
#:element-p
|
||||
#:text-node-p
|
||||
#:comment-p
|
||||
#:cdata-section-p
|
||||
#:document-type-p
|
||||
#:notation-p
|
||||
#:entity-p
|
||||
#:entity-reference-p
|
||||
#:processing-instruction-p
|
||||
#:named-node-map-p
|
||||
))
|
||||
568
xml/encodings-data.lisp
Normal file
568
xml/encodings-data.lisp
Normal file
@ -0,0 +1,568 @@
|
||||
(in-package :encoding)
|
||||
|
||||
(progn
|
||||
(add-name :us-ascii "ANSI_X3.4-1968")
|
||||
(add-name :us-ascii "iso-ir-6")
|
||||
(add-name :us-ascii "ANSI_X3.4-1986")
|
||||
(add-name :us-ascii "ISO_646.irv:1991")
|
||||
(add-name :us-ascii "ASCII")
|
||||
(add-name :us-ascii "ISO646-US")
|
||||
(add-name :us-ascii "US-ASCII")
|
||||
(add-name :us-ascii "us")
|
||||
(add-name :us-ascii "IBM367")
|
||||
(add-name :us-ascii "cp367")
|
||||
(add-name :us-ascii "csASCII")
|
||||
|
||||
(add-name :iso-8859-1 "ISO_8859-1:1987")
|
||||
(add-name :iso-8859-1 "iso-ir-100")
|
||||
(add-name :iso-8859-1 "ISO_8859-1")
|
||||
(add-name :iso-8859-1 "ISO-8859-1")
|
||||
(add-name :iso-8859-1 "latin1")
|
||||
(add-name :iso-8859-1 "l1")
|
||||
(add-name :iso-8859-1 "IBM819")
|
||||
(add-name :iso-8859-1 "CP819")
|
||||
(add-name :iso-8859-1 "csISOLatin1")
|
||||
|
||||
(add-name :iso-8859-2 "ISO_8859-2:1987")
|
||||
(add-name :iso-8859-2 "iso-ir-101")
|
||||
(add-name :iso-8859-2 "ISO_8859-2")
|
||||
(add-name :iso-8859-2 "ISO-8859-2")
|
||||
(add-name :iso-8859-2 "latin2")
|
||||
(add-name :iso-8859-2 "l2")
|
||||
(add-name :iso-8859-2 "csISOLatin2")
|
||||
|
||||
(add-name :iso-8859-3 "ISO_8859-3:1988")
|
||||
(add-name :iso-8859-3 "iso-ir-109")
|
||||
(add-name :iso-8859-3 "ISO_8859-3")
|
||||
(add-name :iso-8859-3 "ISO-8859-3")
|
||||
(add-name :iso-8859-3 "latin3")
|
||||
(add-name :iso-8859-3 "l3")
|
||||
(add-name :iso-8859-3 "csISOLatin3")
|
||||
|
||||
(add-name :iso-8859-4 "ISO_8859-4:1988")
|
||||
(add-name :iso-8859-4 "iso-ir-110")
|
||||
(add-name :iso-8859-4 "ISO_8859-4")
|
||||
(add-name :iso-8859-4 "ISO-8859-4")
|
||||
(add-name :iso-8859-4 "latin4")
|
||||
(add-name :iso-8859-4 "l4")
|
||||
(add-name :iso-8859-4 "csISOLatin4")
|
||||
|
||||
(add-name :iso-8859-6 "ISO_8859-6:1987")
|
||||
(add-name :iso-8859-6 "iso-ir-127")
|
||||
(add-name :iso-8859-6 "ISO_8859-6")
|
||||
(add-name :iso-8859-6 "ISO-8859-6")
|
||||
(add-name :iso-8859-6 "ECMA-114")
|
||||
(add-name :iso-8859-6 "ASMO-708")
|
||||
(add-name :iso-8859-6 "arabic")
|
||||
(add-name :iso-8859-6 "csISOLatinArabic")
|
||||
|
||||
(add-name :iso-8859-7 "ISO_8859-7:1987")
|
||||
(add-name :iso-8859-7 "iso-ir-126")
|
||||
(add-name :iso-8859-7 "ISO_8859-7")
|
||||
(add-name :iso-8859-7 "ISO-8859-7")
|
||||
(add-name :iso-8859-7 "ELOT_928")
|
||||
(add-name :iso-8859-7 "ECMA-118")
|
||||
(add-name :iso-8859-7 "greek")
|
||||
(add-name :iso-8859-7 "greek8")
|
||||
(add-name :iso-8859-7 "csISOLatinGreek")
|
||||
|
||||
(add-name :iso-8859-8 "ISO_8859-8:1988")
|
||||
(add-name :iso-8859-8 "iso-ir-138")
|
||||
(add-name :iso-8859-8 "ISO_8859-8")
|
||||
(add-name :iso-8859-8 "ISO-8859-8")
|
||||
(add-name :iso-8859-8 "hebrew")
|
||||
(add-name :iso-8859-8 "csISOLatinHebrew")
|
||||
|
||||
(add-name :iso-8859-5 "ISO_8859-5:1988")
|
||||
(add-name :iso-8859-5 "iso-ir-144")
|
||||
(add-name :iso-8859-5 "ISO_8859-5")
|
||||
(add-name :iso-8859-5 "ISO-8859-5")
|
||||
(add-name :iso-8859-5 "cyrillic")
|
||||
(add-name :iso-8859-5 "csISOLatinCyrillic")
|
||||
|
||||
(add-name :iso-8859-9 "ISO_8859-9:1989")
|
||||
(add-name :iso-8859-9 "iso-ir-148")
|
||||
(add-name :iso-8859-9 "ISO_8859-9")
|
||||
(add-name :iso-8859-9 "ISO-8859-9")
|
||||
(add-name :iso-8859-9 "latin5")
|
||||
(add-name :iso-8859-9 "l5")
|
||||
(add-name :iso-8859-9 "csISOLatin5")
|
||||
|
||||
(add-name :iso-8859-15 "ISO_8859-15")
|
||||
(add-name :iso-8859-15 "ISO-8859-15")
|
||||
|
||||
(add-name :iso-8859-14 "ISO_8859-14")
|
||||
(add-name :iso-8859-14 "ISO-8859-14")
|
||||
|
||||
(add-name :koi8-r "KOI8-R")
|
||||
(add-name :koi8-r "csKOI8R")
|
||||
|
||||
(add-name :utf-8 "UTF-8")
|
||||
|
||||
(add-name :utf-16 "UTF-16")
|
||||
|
||||
(add-name :ucs-4 "ISO-10646-UCS-4")
|
||||
(add-name :ucs-4 "UCS-4")
|
||||
|
||||
(add-name :ucs-2 "ISO-10646-UCS-2")
|
||||
(add-name :ucs-2 "UCS-2") )
|
||||
|
||||
|
||||
(progn
|
||||
(define-encoding :iso-8859-1
|
||||
(make-simple-8-bit-encoding
|
||||
:charset (find-charset :iso-8859-1)))
|
||||
|
||||
(define-encoding :iso-8859-2
|
||||
(make-simple-8-bit-encoding
|
||||
:charset (find-charset :iso-8859-2)))
|
||||
|
||||
(define-encoding :iso-8859-3
|
||||
(make-simple-8-bit-encoding
|
||||
:charset (find-charset :iso-8859-3)))
|
||||
|
||||
(define-encoding :iso-8859-4
|
||||
(make-simple-8-bit-encoding
|
||||
:charset (find-charset :iso-8859-4)))
|
||||
|
||||
(define-encoding :iso-8859-5
|
||||
(make-simple-8-bit-encoding
|
||||
:charset (find-charset :iso-8859-5)))
|
||||
|
||||
(define-encoding :iso-8859-6
|
||||
(make-simple-8-bit-encoding
|
||||
:charset (find-charset :iso-8859-6)))
|
||||
|
||||
(define-encoding :iso-8859-7
|
||||
(make-simple-8-bit-encoding
|
||||
:charset (find-charset :iso-8859-7)))
|
||||
|
||||
(define-encoding :iso-8859-8
|
||||
(make-simple-8-bit-encoding
|
||||
:charset (find-charset :iso-8859-8)))
|
||||
|
||||
(define-encoding :iso-8859-14
|
||||
(make-simple-8-bit-encoding
|
||||
:charset (find-charset :iso-8859-14)))
|
||||
|
||||
(define-encoding :iso-8859-15
|
||||
(make-simple-8-bit-encoding
|
||||
:charset (find-charset :iso-8859-15)))
|
||||
|
||||
(define-encoding :koi8-r
|
||||
(make-simple-8-bit-encoding
|
||||
:charset (find-charset :koi8-r)))
|
||||
|
||||
(define-encoding :utf-8 :utf-8)
|
||||
)
|
||||
|
||||
(progn
|
||||
(define-8-bit-charset :iso-8859-1
|
||||
#| #o00x |# #x0000 #x0001 #x0002 #x0003 #x0004 #x0005 #x0006 #x0007
|
||||
#| #o01x |# #x0008 #x0009 #x000A #x000B #x000C #x000A #x000E #x000F
|
||||
#| #o02x |# #x0010 #x0011 #x0012 #x0013 #x0014 #x0015 #x0016 #x0017
|
||||
#| #o03x |# #x0018 #x0019 #x001A #x001B #x001C #x001D #x001E #x001F
|
||||
#| #o04x |# #x0020 #x0021 #x0022 #x0023 #x0024 #x0025 #x0026 #x0027
|
||||
#| #o05x |# #x0028 #x0029 #x002A #x002B #x002C #x002D #x002E #x002F
|
||||
#| #o06x |# #x0030 #x0031 #x0032 #x0033 #x0034 #x0035 #x0036 #x0037
|
||||
#| #o07x |# #x0038 #x0039 #x003A #x003B #x003C #x003D #x003E #x003F
|
||||
#| #o10x |# #x0040 #x0041 #x0042 #x0043 #x0044 #x0045 #x0046 #x0047
|
||||
#| #o11x |# #x0048 #x0049 #x004A #x004B #x004C #x004D #x004E #x004F
|
||||
#| #o12x |# #x0050 #x0051 #x0052 #x0053 #x0054 #x0055 #x0056 #x0057
|
||||
#| #o13x |# #x0058 #x0059 #x005A #x005B #x005C #x005D #x005E #x005F
|
||||
#| #o14x |# #x0060 #x0061 #x0062 #x0063 #x0064 #x0065 #x0066 #x0067
|
||||
#| #o15x |# #x0068 #x0069 #x006A #x006B #x006C #x006D #x006E #x006F
|
||||
#| #o16x |# #x0070 #x0071 #x0072 #x0073 #x0074 #x0075 #x0076 #x0077
|
||||
#| #o17x |# #x0078 #x0079 #x007A #x007B #x007C #x007D #x007E #x007F
|
||||
#| #o20x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
|
||||
#| #o21x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
|
||||
#| #o22x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
|
||||
#| #o23x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
|
||||
#| #o24x |# #x00A0 #x00A1 #x00A2 #x00A3 #x00A4 #x00A5 #x00A6 #x00A7
|
||||
#| #o25x |# #x00A8 #x00A9 #x00AA #x00AB #x00AC #x00AD #x00AE #x00AF
|
||||
#| #o26x |# #x00B0 #x00B1 #x00B2 #x00B3 #x00B4 #x00B5 #x00B6 #x00B7
|
||||
#| #o27x |# #x00B8 #x00B9 #x00BA #x00BB #x00BC #x00BD #x00BE #x00BF
|
||||
#| #o30x |# #x00C0 #x00C1 #x00C2 #x00C3 #x00C4 #x00C5 #x00C6 #x00C7
|
||||
#| #o31x |# #x00C8 #x00C9 #x00CA #x00CB #x00CC #x00CD #x00CE #x00CF
|
||||
#| #o32x |# #x00D0 #x00D1 #x00D2 #x00D3 #x00D4 #x00D5 #x00D6 #x00D7
|
||||
#| #o33x |# #x00D8 #x00D9 #x00DA #x00DB #x00DC #x00DD #x00DE #x00DF
|
||||
#| #o34x |# #x00E0 #x00E1 #x00E2 #x00E3 #x00E4 #x00E5 #x00E6 #x00E7
|
||||
#| #o35x |# #x00E8 #x00E9 #x00EA #x00EB #x00EC #x00ED #x00EE #x00EF
|
||||
#| #o36x |# #x00F0 #x00F1 #x00F2 #x00F3 #x00F4 #x00F5 #x00F6 #x00F7
|
||||
#| #o37x |# #x00F8 #x00F9 #x00FA #x00FB #x00FC #x00FD #x00FE #x00FF)
|
||||
|
||||
(define-8-bit-charset :iso-8859-2
|
||||
#| #o00x |# #x0000 #x0001 #x0002 #x0003 #x0004 #x0005 #x0006 #x0007
|
||||
#| #o01x |# #x0008 #x0009 #x000A #x000B #x000C #x000A #x000E #x000F
|
||||
#| #o02x |# #x0010 #x0011 #x0012 #x0013 #x0014 #x0015 #x0016 #x0017
|
||||
#| #o03x |# #x0018 #x0019 #x001A #x001B #x001C #x001D #x001E #x001F
|
||||
#| #o04x |# #x0020 #x0021 #x0022 #x0023 #x0024 #x0025 #x0026 #x0027
|
||||
#| #o05x |# #x0028 #x0029 #x002A #x002B #x002C #x002D #x002E #x002F
|
||||
#| #o06x |# #x0030 #x0031 #x0032 #x0033 #x0034 #x0035 #x0036 #x0037
|
||||
#| #o07x |# #x0038 #x0039 #x003A #x003B #x003C #x003D #x003E #x003F
|
||||
#| #o10x |# #x0040 #x0041 #x0042 #x0043 #x0044 #x0045 #x0046 #x0047
|
||||
#| #o11x |# #x0048 #x0049 #x004A #x004B #x004C #x004D #x004E #x004F
|
||||
#| #o12x |# #x0050 #x0051 #x0052 #x0053 #x0054 #x0055 #x0056 #x0057
|
||||
#| #o13x |# #x0058 #x0059 #x005A #x005B #x005C #x005D #x005E #x005F
|
||||
#| #o14x |# #x0060 #x0061 #x0062 #x0063 #x0064 #x0065 #x0066 #x0067
|
||||
#| #o15x |# #x0068 #x0069 #x006A #x006B #x006C #x006D #x006E #x006F
|
||||
#| #o16x |# #x0070 #x0071 #x0072 #x0073 #x0074 #x0075 #x0076 #x0077
|
||||
#| #o17x |# #x0078 #x0079 #x007A #x007B #x007C #x007D #x007E #x007F
|
||||
#| #o20x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
|
||||
#| #o21x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
|
||||
#| #o22x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
|
||||
#| #o23x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
|
||||
#| #o24x |# #x00A0 #x0104 #x02D8 #x0141 #x00A4 #x013D #x015A #x00A7
|
||||
#| #o25x |# #x00A8 #x0160 #x015E #x0164 #x0179 #x00AD #x017D #x017B
|
||||
#| #o26x |# #x00B0 #x0105 #x02DB #x0142 #x00B4 #x013E #x015B #x02C7
|
||||
#| #o27x |# #x00B8 #x0161 #x015F #x0165 #x017A #x02DD #x017E #x017C
|
||||
#| #o30x |# #x0154 #x00C1 #x00C2 #x0102 #x00C4 #x0139 #x0106 #x00C7
|
||||
#| #o31x |# #x010C #x00C9 #x0118 #x00CB #x011A #x00CD #x00CE #x010E
|
||||
#| #o32x |# #x0110 #x0143 #x0147 #x00D3 #x00D4 #x0150 #x00D6 #x00D7
|
||||
#| #o33x |# #x0158 #x016E #x00DA #x0170 #x00DC #x00DD #x0162 #x00DF
|
||||
#| #o34x |# #x0155 #x00E1 #x00E2 #x0103 #x00E4 #x013A #x0107 #x00E7
|
||||
#| #o35x |# #x010D #x00E9 #x0119 #x00EB #x011B #x00ED #x00EE #x010F
|
||||
#| #o36x |# #x0111 #x0144 #x0148 #x00F3 #x00F4 #x0151 #x00F6 #x00F7
|
||||
#| #o37x |# #x0159 #x016F #x00FA #x0171 #x00FC #x00FD #x0163 #x02D9)
|
||||
|
||||
(define-8-bit-charset :iso-8859-3
|
||||
#| #o00x |# #x0000 #x0001 #x0002 #x0003 #x0004 #x0005 #x0006 #x0007
|
||||
#| #o01x |# #x0008 #x0009 #x000A #x000B #x000C #x000A #x000E #x000F
|
||||
#| #o02x |# #x0010 #x0011 #x0012 #x0013 #x0014 #x0015 #x0016 #x0017
|
||||
#| #o03x |# #x0018 #x0019 #x001A #x001B #x001C #x001D #x001E #x001F
|
||||
#| #o04x |# #x0020 #x0021 #x0022 #x0023 #x0024 #x0025 #x0026 #x0027
|
||||
#| #o05x |# #x0028 #x0029 #x002A #x002B #x002C #x002D #x002E #x002F
|
||||
#| #o06x |# #x0030 #x0031 #x0032 #x0033 #x0034 #x0035 #x0036 #x0037
|
||||
#| #o07x |# #x0038 #x0039 #x003A #x003B #x003C #x003D #x003E #x003F
|
||||
#| #o10x |# #x0040 #x0041 #x0042 #x0043 #x0044 #x0045 #x0046 #x0047
|
||||
#| #o11x |# #x0048 #x0049 #x004A #x004B #x004C #x004D #x004E #x004F
|
||||
#| #o12x |# #x0050 #x0051 #x0052 #x0053 #x0054 #x0055 #x0056 #x0057
|
||||
#| #o13x |# #x0058 #x0059 #x005A #x005B #x005C #x005D #x005E #x005F
|
||||
#| #o14x |# #x0060 #x0061 #x0062 #x0063 #x0064 #x0065 #x0066 #x0067
|
||||
#| #o15x |# #x0068 #x0069 #x006A #x006B #x006C #x006D #x006E #x006F
|
||||
#| #o16x |# #x0070 #x0071 #x0072 #x0073 #x0074 #x0075 #x0076 #x0077
|
||||
#| #o17x |# #x0078 #x0079 #x007A #x007B #x007C #x007D #x007E #x007F
|
||||
#| #o20x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
|
||||
#| #o21x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
|
||||
#| #o22x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
|
||||
#| #o23x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
|
||||
#| #o24x |# #x00A0 #x0126 #x02D8 #x00A3 #x00A4 #xFFFF #x0124 #x00A7
|
||||
#| #o25x |# #x00A8 #x0130 #x015E #x011E #x0134 #x00AD #xFFFF #x017B
|
||||
#| #o26x |# #x00B0 #x0127 #x00B2 #x00B3 #x00B4 #x00B5 #x0125 #x00B7
|
||||
#| #o27x |# #x00B8 #x0131 #x015F #x011F #x0135 #x00BD #xFFFF #x017C
|
||||
#| #o30x |# #x00C0 #x00C1 #x00C2 #xFFFF #x00C4 #x010A #x0108 #x00C7
|
||||
#| #o31x |# #x00C8 #x00C9 #x00CA #x00CB #x00CC #x00CD #x00CE #x00CF
|
||||
#| #o32x |# #xFFFF #x00D1 #x00D2 #x00D3 #x00D4 #x0120 #x00D6 #x00D7
|
||||
#| #o33x |# #x011C #x00D9 #x00DA #x00DB #x00DC #x016C #x015C #x00DF
|
||||
#| #o34x |# #x00E0 #x00E1 #x00E2 #xFFFF #x00E4 #x010B #x0109 #x00E7
|
||||
#| #o35x |# #x00E8 #x00E9 #x00EA #x00EB #x00EC #x00ED #x00EE #x00EF
|
||||
#| #o36x |# #xFFFF #x00F1 #x00F2 #x00F3 #x00F4 #x0121 #x00F6 #x00F7
|
||||
#| #o37x |# #x011D #x00F9 #x00FA #x00FB #x00FC #x016D #x015D #x02D9)
|
||||
|
||||
(define-8-bit-charset :iso-8859-4
|
||||
#| #o00x |# #x0000 #x0001 #x0002 #x0003 #x0004 #x0005 #x0006 #x0007
|
||||
#| #o01x |# #x0008 #x0009 #x000A #x000B #x000C #x000A #x000E #x000F
|
||||
#| #o02x |# #x0010 #x0011 #x0012 #x0013 #x0014 #x0015 #x0016 #x0017
|
||||
#| #o03x |# #x0018 #x0019 #x001A #x001B #x001C #x001D #x001E #x001F
|
||||
#| #o04x |# #x0020 #x0021 #x0022 #x0023 #x0024 #x0025 #x0026 #x0027
|
||||
#| #o05x |# #x0028 #x0029 #x002A #x002B #x002C #x002D #x002E #x002F
|
||||
#| #o06x |# #x0030 #x0031 #x0032 #x0033 #x0034 #x0035 #x0036 #x0037
|
||||
#| #o07x |# #x0038 #x0039 #x003A #x003B #x003C #x003D #x003E #x003F
|
||||
#| #o10x |# #x0040 #x0041 #x0042 #x0043 #x0044 #x0045 #x0046 #x0047
|
||||
#| #o11x |# #x0048 #x0049 #x004A #x004B #x004C #x004D #x004E #x004F
|
||||
#| #o12x |# #x0050 #x0051 #x0052 #x0053 #x0054 #x0055 #x0056 #x0057
|
||||
#| #o13x |# #x0058 #x0059 #x005A #x005B #x005C #x005D #x005E #x005F
|
||||
#| #o14x |# #x0060 #x0061 #x0062 #x0063 #x0064 #x0065 #x0066 #x0067
|
||||
#| #o15x |# #x0068 #x0069 #x006A #x006B #x006C #x006D #x006E #x006F
|
||||
#| #o16x |# #x0070 #x0071 #x0072 #x0073 #x0074 #x0075 #x0076 #x0077
|
||||
#| #o17x |# #x0078 #x0079 #x007A #x007B #x007C #x007D #x007E #x007F
|
||||
#| #o20x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
|
||||
#| #o21x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
|
||||
#| #o22x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
|
||||
#| #o23x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
|
||||
#| #o24x |# #x00A0 #x0104 #x0138 #x0156 #x00A4 #x0128 #x013B #x00A7
|
||||
#| #o25x |# #x00A8 #x0160 #x0112 #x0122 #x0166 #x00AD #x017D #x00AF
|
||||
#| #o26x |# #x00B0 #x0105 #x02DB #x0157 #x00B4 #x0129 #x013C #x02C7
|
||||
#| #o27x |# #x00B8 #x0161 #x0113 #x0123 #x0167 #x014A #x017E #x014B
|
||||
#| #o30x |# #x0100 #x00C1 #x00C2 #x00C3 #x00C4 #x00C5 #x00C6 #x012E
|
||||
#| #o31x |# #x010C #x00C9 #x0118 #x00CB #x0116 #x00CD #x00CE #x012A
|
||||
#| #o32x |# #x0110 #x0145 #x014C #x0136 #x00D4 #x00D5 #x00D6 #x00D7
|
||||
#| #o33x |# #x00D8 #x0172 #x00DA #x00DB #x00DC #x0168 #x016A #x00DF
|
||||
#| #o34x |# #x0101 #x00E1 #x00E2 #x00E3 #x00E4 #x00E5 #x00E6 #x012F
|
||||
#| #o35x |# #x010D #x00E9 #x0119 #x00EB #x0117 #x00ED #x00EE #x012B
|
||||
#| #o36x |# #x0111 #x0146 #x014D #x0137 #x00F4 #x00F5 #x00F6 #x00F7
|
||||
#| #o37x |# #x00F8 #x0173 #x00FA #x00FB #x00FC #x0169 #x016B #x02D9)
|
||||
|
||||
(define-8-bit-charset :iso-8859-5
|
||||
#| #o00x |# #x0000 #x0001 #x0002 #x0003 #x0004 #x0005 #x0006 #x0007
|
||||
#| #o01x |# #x0008 #x0009 #x000A #x000B #x000C #x000A #x000E #x000F
|
||||
#| #o02x |# #x0010 #x0011 #x0012 #x0013 #x0014 #x0015 #x0016 #x0017
|
||||
#| #o03x |# #x0018 #x0019 #x001A #x001B #x001C #x001D #x001E #x001F
|
||||
#| #o04x |# #x0020 #x0021 #x0022 #x0023 #x0024 #x0025 #x0026 #x0027
|
||||
#| #o05x |# #x0028 #x0029 #x002A #x002B #x002C #x002D #x002E #x002F
|
||||
#| #o06x |# #x0030 #x0031 #x0032 #x0033 #x0034 #x0035 #x0036 #x0037
|
||||
#| #o07x |# #x0038 #x0039 #x003A #x003B #x003C #x003D #x003E #x003F
|
||||
#| #o10x |# #x0040 #x0041 #x0042 #x0043 #x0044 #x0045 #x0046 #x0047
|
||||
#| #o11x |# #x0048 #x0049 #x004A #x004B #x004C #x004D #x004E #x004F
|
||||
#| #o12x |# #x0050 #x0051 #x0052 #x0053 #x0054 #x0055 #x0056 #x0057
|
||||
#| #o13x |# #x0058 #x0059 #x005A #x005B #x005C #x005D #x005E #x005F
|
||||
#| #o14x |# #x0060 #x0061 #x0062 #x0063 #x0064 #x0065 #x0066 #x0067
|
||||
#| #o15x |# #x0068 #x0069 #x006A #x006B #x006C #x006D #x006E #x006F
|
||||
#| #o16x |# #x0070 #x0071 #x0072 #x0073 #x0074 #x0075 #x0076 #x0077
|
||||
#| #o17x |# #x0078 #x0079 #x007A #x007B #x007C #x007D #x007E #x007F
|
||||
#| #o20x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
|
||||
#| #o21x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
|
||||
#| #o22x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
|
||||
#| #o23x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
|
||||
#| #o24x |# #x00A0 #x0401 #x0402 #x0403 #x0404 #x0405 #x0406 #x0407
|
||||
#| #o25x |# #x0408 #x0409 #x040A #x040B #x040C #x00AD #x040E #x040F
|
||||
#| #o26x |# #x0410 #x0411 #x0412 #x0413 #x0414 #x0415 #x0416 #x0417
|
||||
#| #o27x |# #x0418 #x0419 #x041A #x041B #x041C #x041D #x041E #x041F
|
||||
#| #o30x |# #x0420 #x0421 #x0422 #x0423 #x0424 #x0425 #x0426 #x0427
|
||||
#| #o31x |# #x0428 #x0429 #x042A #x042B #x042C #x042D #x042E #x042F
|
||||
#| #o32x |# #x0430 #x0431 #x0432 #x0433 #x0434 #x0435 #x0436 #x0437
|
||||
#| #o33x |# #x0438 #x0439 #x043A #x043B #x043C #x043D #x043E #x043F
|
||||
#| #o34x |# #x0440 #x0441 #x0442 #x0443 #x0444 #x0445 #x0446 #x0447
|
||||
#| #o35x |# #x0448 #x0449 #x044A #x044B #x044C #x044D #x044E #x044F
|
||||
#| #o36x |# #x2116 #x0451 #x0452 #x0453 #x0454 #x0455 #x0456 #x0457
|
||||
#| #o37x |# #x0458 #x0459 #x045A #x045B #x045C #x00A7 #x045E #x045F)
|
||||
|
||||
(define-8-bit-charset :iso-8859-6
|
||||
#| #o00x |# #x0000 #x0001 #x0002 #x0003 #x0004 #x0005 #x0006 #x0007
|
||||
#| #o01x |# #x0008 #x0009 #x000A #x000B #x000C #x000A #x000E #x000F
|
||||
#| #o02x |# #x0010 #x0011 #x0012 #x0013 #x0014 #x0015 #x0016 #x0017
|
||||
#| #o03x |# #x0018 #x0019 #x001A #x001B #x001C #x001D #x001E #x001F
|
||||
#| #o04x |# #x0020 #x0021 #x0022 #x0023 #x0024 #x0025 #x0026 #x0027
|
||||
#| #o05x |# #x0028 #x0029 #x002A #x002B #x002C #x002D #x002E #x002F
|
||||
#| #o06x |# #x0660 #x0661 #x0662 #x0663 #x0664 #x0665 #x0666 #x0667
|
||||
#| #o07x |# #x0668 #x0669 #x003A #x003B #x003C #x003D #x003E #x003F
|
||||
#| #o10x |# #x0040 #x0041 #x0042 #x0043 #x0044 #x0045 #x0046 #x0047
|
||||
#| #o11x |# #x0048 #x0049 #x004A #x004B #x004C #x004D #x004E #x004F
|
||||
#| #o12x |# #x0050 #x0051 #x0052 #x0053 #x0054 #x0055 #x0056 #x0057
|
||||
#| #o13x |# #x0058 #x0059 #x005A #x005B #x005C #x005D #x005E #x005F
|
||||
#| #o14x |# #x0060 #x0061 #x0062 #x0063 #x0064 #x0065 #x0066 #x0067
|
||||
#| #o15x |# #x0068 #x0069 #x006A #x006B #x006C #x006D #x006E #x006F
|
||||
#| #o16x |# #x0070 #x0071 #x0072 #x0073 #x0074 #x0075 #x0076 #x0077
|
||||
#| #o17x |# #x0078 #x0079 #x007A #x007B #x007C #x007D #x007E #x007F
|
||||
#| #o20x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
|
||||
#| #o21x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
|
||||
#| #o22x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
|
||||
#| #o23x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
|
||||
#| #o24x |# #x00A0 #xFFFF #xFFFF #xFFFF #x00A4 #xFFFF #xFFFF #xFFFF
|
||||
#| #o25x |# #xFFFF #xFFFF #xFFFF #xFFFF #x060C #x00AD #xFFFF #xFFFF
|
||||
#| #o26x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
|
||||
#| #o27x |# #xFFFF #xFFFF #xFFFF #x061B #xFFFF #xFFFF #xFFFF #x061F
|
||||
#| #o30x |# #xFFFF #x0621 #x0622 #x0623 #x0624 #x0625 #x0626 #x0627
|
||||
#| #o31x |# #x0628 #x0629 #x062A #x062B #x062C #x062D #x062E #x062F
|
||||
#| #o32x |# #x0630 #x0631 #x0632 #x0633 #x0634 #x0635 #x0636 #x0637
|
||||
#| #o33x |# #x0638 #x0639 #x063A #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
|
||||
#| #o34x |# #x0640 #x0641 #x0642 #x0643 #x0644 #x0645 #x0646 #x0647
|
||||
#| #o35x |# #x0648 #x0649 #x064A #x064B #x064C #x064D #x064E #x064F
|
||||
#| #o36x |# #x0650 #x0651 #x0652 #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
|
||||
#| #o37x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF)
|
||||
|
||||
(define-8-bit-charset :iso-8859-7
|
||||
#| #o00x |# #x0000 #x0001 #x0002 #x0003 #x0004 #x0005 #x0006 #x0007
|
||||
#| #o01x |# #x0008 #x0009 #x000A #x000B #x000C #x000A #x000E #x000F
|
||||
#| #o02x |# #x0010 #x0011 #x0012 #x0013 #x0014 #x0015 #x0016 #x0017
|
||||
#| #o03x |# #x0018 #x0019 #x001A #x001B #x001C #x001D #x001E #x001F
|
||||
#| #o04x |# #x0020 #x0021 #x0022 #x0023 #x0024 #x0025 #x0026 #x0027
|
||||
#| #o05x |# #x0028 #x0029 #x002A #x002B #x002C #x002D #x002E #x002F
|
||||
#| #o06x |# #x0030 #x0031 #x0032 #x0033 #x0034 #x0035 #x0036 #x0037
|
||||
#| #o07x |# #x0038 #x0039 #x003A #x003B #x003C #x003D #x003E #x003F
|
||||
#| #o10x |# #x0040 #x0041 #x0042 #x0043 #x0044 #x0045 #x0046 #x0047
|
||||
#| #o11x |# #x0048 #x0049 #x004A #x004B #x004C #x004D #x004E #x004F
|
||||
#| #o12x |# #x0050 #x0051 #x0052 #x0053 #x0054 #x0055 #x0056 #x0057
|
||||
#| #o13x |# #x0058 #x0059 #x005A #x005B #x005C #x005D #x005E #x005F
|
||||
#| #o14x |# #x0060 #x0061 #x0062 #x0063 #x0064 #x0065 #x0066 #x0067
|
||||
#| #o15x |# #x0068 #x0069 #x006A #x006B #x006C #x006D #x006E #x006F
|
||||
#| #o16x |# #x0070 #x0071 #x0072 #x0073 #x0074 #x0075 #x0076 #x0077
|
||||
#| #o17x |# #x0078 #x0079 #x007A #x007B #x007C #x007D #x007E #x007F
|
||||
#| #o20x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
|
||||
#| #o21x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
|
||||
#| #o22x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
|
||||
#| #o23x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
|
||||
#| #o24x |# #x00A0 #x02BD #x02BC #x00A3 #xFFFF #xFFFF #x00A6 #x00A7
|
||||
#| #o25x |# #x00A8 #x00A9 #xFFFF #x00AB #x00AC #x00AD #xFFFF #x2015
|
||||
#| #o26x |# #x00B0 #x00B1 #x00B2 #x00B3 #x0384 #x0385 #x0386 #x00B7
|
||||
#| #o27x |# #x0388 #x0389 #x038A #x00BB #x038C #x00BD #x038E #x038F
|
||||
#| #o30x |# #x0390 #x0391 #x0392 #x0393 #x0394 #x0395 #x0396 #x0397
|
||||
#| #o31x |# #x0398 #x0399 #x039A #x039B #x039C #x039D #x039E #x039F
|
||||
#| #o32x |# #x03A0 #x03A1 #xFFFF #x03A3 #x03A4 #x03A5 #x03A6 #x03A7
|
||||
#| #o33x |# #x03A8 #x03A9 #x03AA #x03AB #x03AC #x03AD #x03AE #x03AF
|
||||
#| #o34x |# #x03B0 #x03B1 #x03B2 #x03B3 #x03B4 #x03B5 #x03B6 #x03B7
|
||||
#| #o35x |# #x03B8 #x03B9 #x03BA #x03BB #x03BC #x03BD #x03BE #x03BF
|
||||
#| #o36x |# #x03C0 #x03C1 #x03C2 #x03C3 #x03C4 #x03C5 #x03C6 #x03C7
|
||||
#| #o37x |# #x03C8 #x03C9 #x03CA #x03CB #x03CC #x03CD #x03CE #xFFFF)
|
||||
|
||||
(define-8-bit-charset :iso-8859-8
|
||||
#| #o00x |# #x0000 #x0001 #x0002 #x0003 #x0004 #x0005 #x0006 #x0007
|
||||
#| #o01x |# #x0008 #x0009 #x000A #x000B #x000C #x000A #x000E #x000F
|
||||
#| #o02x |# #x0010 #x0011 #x0012 #x0013 #x0014 #x0015 #x0016 #x0017
|
||||
#| #o03x |# #x0018 #x0019 #x001A #x001B #x001C #x001D #x001E #x001F
|
||||
#| #o04x |# #x0020 #x0021 #x0022 #x0023 #x0024 #x0025 #x0026 #x0027
|
||||
#| #o05x |# #x0028 #x0029 #x002A #x002B #x002C #x002D #x002E #x002F
|
||||
#| #o06x |# #x0030 #x0031 #x0032 #x0033 #x0034 #x0035 #x0036 #x0037
|
||||
#| #o07x |# #x0038 #x0039 #x003A #x003B #x003C #x003D #x003E #x003F
|
||||
#| #o10x |# #x0040 #x0041 #x0042 #x0043 #x0044 #x0045 #x0046 #x0047
|
||||
#| #o11x |# #x0048 #x0049 #x004A #x004B #x004C #x004D #x004E #x004F
|
||||
#| #o12x |# #x0050 #x0051 #x0052 #x0053 #x0054 #x0055 #x0056 #x0057
|
||||
#| #o13x |# #x0058 #x0059 #x005A #x005B #x005C #x005D #x005E #x005F
|
||||
#| #o14x |# #x0060 #x0061 #x0062 #x0063 #x0064 #x0065 #x0066 #x0067
|
||||
#| #o15x |# #x0068 #x0069 #x006A #x006B #x006C #x006D #x006E #x006F
|
||||
#| #o16x |# #x0070 #x0071 #x0072 #x0073 #x0074 #x0075 #x0076 #x0077
|
||||
#| #o17x |# #x0078 #x0079 #x007A #x007B #x007C #x007D #x007E #x007F
|
||||
#| #o20x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
|
||||
#| #o21x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
|
||||
#| #o22x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
|
||||
#| #o23x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
|
||||
#| #o24x |# #x00A0 #xFFFF #x00A2 #x00A3 #x00A4 #x00A5 #x00A6 #x00A7
|
||||
#| #o25x |# #x00A8 #x00A9 #x00D7 #x00AB #x00AC #x00AD #x00AE #x203E
|
||||
#| #o26x |# #x00B0 #x00B1 #x00B2 #x00B3 #x00B4 #x00B5 #x00B6 #x00B7
|
||||
#| #o27x |# #x00B8 #x00B9 #x00F7 #x00BB #x00BC #x00BD #x00BE #xFFFF
|
||||
#| #o30x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
|
||||
#| #o31x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
|
||||
#| #o32x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
|
||||
#| #o33x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #x2017
|
||||
#| #o34x |# #x05D0 #x05D1 #x05D2 #x05D3 #x05D4 #x05D5 #x05D6 #x05D7
|
||||
#| #o35x |# #x05D8 #x05D9 #x05DA #x05DB #x05DC #x05DD #x05DE #x05DF
|
||||
#| #o36x |# #x05E0 #x05E1 #x05E2 #x05E3 #x05E4 #x05E5 #x05E6 #x05E7
|
||||
#| #o37x |# #x05E8 #x05E9 #x05EA #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF)
|
||||
|
||||
(define-8-bit-charset :iso-8859-9
|
||||
#| #o00x |# #x0000 #x0001 #x0002 #x0003 #x0004 #x0005 #x0006 #x0007
|
||||
#| #o01x |# #x0008 #x0009 #x000A #x000B #x000C #x000A #x000E #x000F
|
||||
#| #o02x |# #x0010 #x0011 #x0012 #x0013 #x0014 #x0015 #x0016 #x0017
|
||||
#| #o03x |# #x0018 #x0019 #x001A #x001B #x001C #x001D #x001E #x001F
|
||||
#| #o04x |# #x0020 #x0021 #x0022 #x0023 #x0024 #x0025 #x0026 #x0027
|
||||
#| #o05x |# #x0028 #x0029 #x002A #x002B #x002C #x002D #x002E #x002F
|
||||
#| #o06x |# #x0030 #x0031 #x0032 #x0033 #x0034 #x0035 #x0036 #x0037
|
||||
#| #o07x |# #x0038 #x0039 #x003A #x003B #x003C #x003D #x003E #x003F
|
||||
#| #o10x |# #x0040 #x0041 #x0042 #x0043 #x0044 #x0045 #x0046 #x0047
|
||||
#| #o11x |# #x0048 #x0049 #x004A #x004B #x004C #x004D #x004E #x004F
|
||||
#| #o12x |# #x0050 #x0051 #x0052 #x0053 #x0054 #x0055 #x0056 #x0057
|
||||
#| #o13x |# #x0058 #x0059 #x005A #x005B #x005C #x005D #x005E #x005F
|
||||
#| #o14x |# #x0060 #x0061 #x0062 #x0063 #x0064 #x0065 #x0066 #x0067
|
||||
#| #o15x |# #x0068 #x0069 #x006A #x006B #x006C #x006D #x006E #x006F
|
||||
#| #o16x |# #x0070 #x0071 #x0072 #x0073 #x0074 #x0075 #x0076 #x0077
|
||||
#| #o17x |# #x0078 #x0079 #x007A #x007B #x007C #x007D #x007E #x007F
|
||||
#| #o20x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
|
||||
#| #o21x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
|
||||
#| #o22x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
|
||||
#| #o23x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
|
||||
#| #o24x |# #x00A0 #x00A1 #x00A2 #x00A3 #x00A4 #x00A5 #x00A6 #x00A7
|
||||
#| #o25x |# #x00A8 #x00A9 #x00AA #x00AB #x00AC #x00AD #x00AE #x00AF
|
||||
#| #o26x |# #x00B0 #x00B1 #x00B2 #x00B3 #x00B4 #x00B5 #x00B6 #x00B7
|
||||
#| #o27x |# #x00B8 #x00B9 #x00BA #x00BB #x00BC #x00BD #x00BE #x00BF
|
||||
#| #o30x |# #x00C0 #x00C1 #x00C2 #x00C3 #x00C4 #x00C5 #x00C6 #x00C7
|
||||
#| #o31x |# #x00C8 #x00C9 #x00CA #x00CB #x00CC #x00CD #x00CE #x00CF
|
||||
#| #o32x |# #x011E #x00D1 #x00D2 #x00D3 #x00D4 #x00D5 #x00D6 #x00D7
|
||||
#| #o33x |# #x00D8 #x00D9 #x00DA #x00DB #x00DC #x0130 #x015E #x00DF
|
||||
#| #o34x |# #x00E0 #x00E1 #x00E2 #x00E3 #x00E4 #x00E5 #x00E6 #x00E7
|
||||
#| #o35x |# #x00E8 #x00E9 #x00EA #x00EB #x00EC #x00ED #x00EE #x00EF
|
||||
#| #o36x |# #x011F #x00F1 #x00F2 #x00F3 #x00F4 #x00F5 #x00F6 #x00F7
|
||||
#| #o37x |# #x00F8 #x00F9 #x00FA #x00FB #x00FC #x0131 #x015F #x00FF)
|
||||
|
||||
(define-8-bit-charset :iso-8859-14
|
||||
#| #o00x |# #x0000 #x0001 #x0002 #x0003 #x0004 #x0005 #x0006 #x0007
|
||||
#| #o01x |# #x0008 #x0009 #x000A #x000B #x000C #x000A #x000E #x000F
|
||||
#| #o02x |# #x0010 #x0011 #x0012 #x0013 #x0014 #x0015 #x0016 #x0017
|
||||
#| #o03x |# #x0018 #x0019 #x001A #x001B #x001C #x001D #x001E #x001F
|
||||
#| #o04x |# #x0020 #x0021 #x0022 #x0023 #x0024 #x0025 #x0026 #x0027
|
||||
#| #o05x |# #x0028 #x0029 #x002A #x002B #x002C #x002D #x002E #x002F
|
||||
#| #o06x |# #x0030 #x0031 #x0032 #x0033 #x0034 #x0035 #x0036 #x0037
|
||||
#| #o07x |# #x0038 #x0039 #x003A #x003B #x003C #x003D #x003E #x003F
|
||||
#| #o10x |# #x0040 #x0041 #x0042 #x0043 #x0044 #x0045 #x0046 #x0047
|
||||
#| #o11x |# #x0048 #x0049 #x004A #x004B #x004C #x004D #x004E #x004F
|
||||
#| #o12x |# #x0050 #x0051 #x0052 #x0053 #x0054 #x0055 #x0056 #x0057
|
||||
#| #o13x |# #x0058 #x0059 #x005A #x005B #x005C #x005D #x005E #x005F
|
||||
#| #o14x |# #x0060 #x0061 #x0062 #x0063 #x0064 #x0065 #x0066 #x0067
|
||||
#| #o15x |# #x0068 #x0069 #x006A #x006B #x006C #x006D #x006E #x006F
|
||||
#| #o16x |# #x0070 #x0071 #x0072 #x0073 #x0074 #x0075 #x0076 #x0077
|
||||
#| #o17x |# #x0078 #x0079 #x007A #x007B #x007C #x007D #x007E #x007F
|
||||
#| #o20x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
|
||||
#| #o21x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
|
||||
#| #o22x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
|
||||
#| #o23x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
|
||||
#| #o24x |# #x00A0 #x1E02 #x1E03 #x00A3 #x010A #x010B #x1E0A #x00A7
|
||||
#| #o25x |# #x1E80 #x00A9 #x1E82 #x1E0B #x1EF2 #x00AD #x00AE #x0178
|
||||
#| #o26x |# #x1E1E #x1E1F #x0120 #x0121 #x1E40 #x1E41 #x00B6 #x1E56
|
||||
#| #o27x |# #x1E81 #x1E57 #x1E83 #x1E60 #x1EF3 #x1E84 #x1E85 #x1E61
|
||||
#| #o30x |# #x00C0 #x00C1 #x00C2 #x00C3 #x00C4 #x00C5 #x00C6 #x00C7
|
||||
#| #o31x |# #x00C8 #x00C9 #x00CA #x00CB #x00CC #x00CD #x00CE #x00CF
|
||||
#| #o32x |# #x0174 #x00D1 #x00D2 #x00D3 #x00D4 #x00D5 #x00D6 #x1E6A
|
||||
#| #o33x |# #x00D8 #x00D9 #x00DA #x00DB #x00DC #x00DD #x0176 #x00DF
|
||||
#| #o34x |# #x00E0 #x00E1 #x00E2 #x00E3 #x00E4 #x00E5 #x00E6 #x00E7
|
||||
#| #o35x |# #x00E8 #x00E9 #x00EA #x00EB #x00EC #x00ED #x00EE #x00EF
|
||||
#| #o36x |# #x0175 #x00F1 #x00F2 #x00F3 #x00F4 #x00F5 #x00F6 #x1E6B
|
||||
#| #o37x |# #x00F8 #x00F9 #x00FA #x00FB #x00FC #x00FD #x0177 #x00FF)
|
||||
|
||||
(define-8-bit-charset :iso-8859-15
|
||||
#| #o00x |# #x0000 #x0001 #x0002 #x0003 #x0004 #x0005 #x0006 #x0007
|
||||
#| #o01x |# #x0008 #x0009 #x000A #x000B #x000C #x000A #x000E #x000F
|
||||
#| #o02x |# #x0010 #x0011 #x0012 #x0013 #x0014 #x0015 #x0016 #x0017
|
||||
#| #o03x |# #x0018 #x0019 #x001A #x001B #x001C #x001D #x001E #x001F
|
||||
#| #o04x |# #x0020 #x0021 #x0022 #x0023 #x0024 #x0025 #x0026 #x0027
|
||||
#| #o05x |# #x0028 #x0029 #x002A #x002B #x002C #x002D #x002E #x002F
|
||||
#| #o06x |# #x0030 #x0031 #x0032 #x0033 #x0034 #x0035 #x0036 #x0037
|
||||
#| #o07x |# #x0038 #x0039 #x003A #x003B #x003C #x003D #x003E #x003F
|
||||
#| #o10x |# #x0040 #x0041 #x0042 #x0043 #x0044 #x0045 #x0046 #x0047
|
||||
#| #o11x |# #x0048 #x0049 #x004A #x004B #x004C #x004D #x004E #x004F
|
||||
#| #o12x |# #x0050 #x0051 #x0052 #x0053 #x0054 #x0055 #x0056 #x0057
|
||||
#| #o13x |# #x0058 #x0059 #x005A #x005B #x005C #x005D #x005E #x005F
|
||||
#| #o14x |# #x0060 #x0061 #x0062 #x0063 #x0064 #x0065 #x0066 #x0067
|
||||
#| #o15x |# #x0068 #x0069 #x006A #x006B #x006C #x006D #x006E #x006F
|
||||
#| #o16x |# #x0070 #x0071 #x0072 #x0073 #x0074 #x0075 #x0076 #x0077
|
||||
#| #o17x |# #x0078 #x0079 #x007A #x007B #x007C #x007D #x007E #x007F
|
||||
#| #o20x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
|
||||
#| #o21x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
|
||||
#| #o22x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
|
||||
#| #o23x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
|
||||
#| #o24x |# #x00A0 #x00A1 #x00A2 #x00A3 #x20AC #x00A5 #x0160 #x00A7
|
||||
#| #o25x |# #x0161 #x00A9 #x00AA #x00AB #x00AC #x00AD #x00AE #x00AF
|
||||
#| #o26x |# #x00B0 #x00B1 #x00B2 #x00B3 #x017D #x00B5 #x00B6 #x00B7
|
||||
#| #o27x |# #x017E #x00B9 #x00BA #x00BB #x0152 #x0153 #x0178 #x00BF
|
||||
#| #o30x |# #x00C0 #x00C1 #x00C2 #x00C3 #x00C4 #x00C5 #x00C6 #x00C7
|
||||
#| #o31x |# #x00C8 #x00C9 #x00CA #x00CB #x00CC #x00CD #x00CE #x00CF
|
||||
#| #o32x |# #x00D0 #x00D1 #x00D2 #x00D3 #x00D4 #x00D5 #x00D6 #x00D7
|
||||
#| #o33x |# #x00D8 #x00D9 #x00DA #x00DB #x00DC #x00DD #x00DE #x00DF
|
||||
#| #o34x |# #x00E0 #x00E1 #x00E2 #x00E3 #x00E4 #x00E5 #x00E6 #x00E7
|
||||
#| #o35x |# #x00E8 #x00E9 #x00EA #x00EB #x00EC #x00ED #x00EE #x00EF
|
||||
#| #o36x |# #x00F0 #x00F1 #x00F2 #x00F3 #x00F4 #x00F5 #x00F6 #x00F7
|
||||
#| #o37x |# #x00F8 #x00F9 #x00FA #x00FB #x00FC #x00FD #x00FE #x00FF)
|
||||
|
||||
(define-8-bit-charset :koi8-r
|
||||
#| #o00x |# #x0000 #x0001 #x0002 #x0003 #x0004 #x0005 #x0006 #x0007
|
||||
#| #o01x |# #x0008 #x0009 #x000A #x000B #x000C #x000A #x000E #x000F
|
||||
#| #o02x |# #x0010 #x0011 #x0012 #x0013 #x0014 #x0015 #x0016 #x0017
|
||||
#| #o03x |# #x0018 #x0019 #x001A #x001B #x001C #x001D #x001E #x001F
|
||||
#| #o04x |# #x0020 #x0021 #x0022 #x0023 #x0024 #x0025 #x0026 #x0027
|
||||
#| #o05x |# #x0028 #x0029 #x002A #x002B #x002C #x002D #x002E #x002F
|
||||
#| #o06x |# #x0030 #x0031 #x0032 #x0033 #x0034 #x0035 #x0036 #x0037
|
||||
#| #o07x |# #x0038 #x0039 #x003A #x003B #x003C #x003D #x003E #x003F
|
||||
#| #o10x |# #x0040 #x0041 #x0042 #x0043 #x0044 #x0045 #x0046 #x0047
|
||||
#| #o11x |# #x0048 #x0049 #x004A #x004B #x004C #x004D #x004E #x004F
|
||||
#| #o12x |# #x0050 #x0051 #x0052 #x0053 #x0054 #x0055 #x0056 #x0057
|
||||
#| #o13x |# #x0058 #x0059 #x005A #x005B #x005C #x005D #x005E #x005F
|
||||
#| #o14x |# #x0060 #x0061 #x0062 #x0063 #x0064 #x0065 #x0066 #x0067
|
||||
#| #o15x |# #x0068 #x0069 #x006A #x006B #x006C #x006D #x006E #x006F
|
||||
#| #o16x |# #x0070 #x0071 #x0072 #x0073 #x0074 #x0075 #x0076 #x0077
|
||||
#| #o17x |# #x0078 #x0079 #x007A #x007B #x007C #x007D #x007E #x007F
|
||||
#| #o20x |# #x2500 #x2502 #x250C #x2510 #x2514 #x2518 #x251C #x2524
|
||||
#| #o21x |# #x252C #x2534 #x253C #x2580 #x2584 #x2588 #x258C #x2590
|
||||
#| #o22x |# #x2591 #x2592 #x2593 #x2320 #x25A0 #x2219 #x221A #x2248
|
||||
#| #o23x |# #x2264 #x2265 #x00A0 #x2321 #x00B0 #x00B2 #x00B7 #x00F7
|
||||
#| #o24x |# #x2550 #x2551 #x2552 #x0451 #x2553 #x2554 #x2555 #x2556
|
||||
#| #o25x |# #x2557 #x2558 #x2559 #x255A #x255B #x255C #x255D #x255E
|
||||
#| #o26x |# #x255F #x2560 #x2561 #x0401 #x2562 #x2563 #x2564 #x2565
|
||||
#| #o27x |# #x2566 #x2567 #x2568 #x2569 #x256A #x256B #x256C #x00A9
|
||||
#| #o30x |# #x044E #x0430 #x0431 #x0446 #x0434 #x0435 #x0444 #x0433
|
||||
#| #o31x |# #x0445 #x0438 #x0439 #x043A #x043B #x043C #x043D #x043E
|
||||
#| #o32x |# #x043F #x044F #x0440 #x0441 #x0442 #x0443 #x0436 #x0432
|
||||
#| #o33x |# #x044C #x044B #x0437 #x0448 #x044D #x0449 #x0447 #x044A
|
||||
#| #o34x |# #x042E #x0410 #x0411 #x0426 #x0414 #x0415 #x0424 #x0413
|
||||
#| #o35x |# #x0425 #x0418 #x0419 #x041A #x041B #x041C #x041D #x041E
|
||||
#| #o36x |# #x041F #x042F #x0420 #x0421 #x0422 #x0423 #x0416 #x0412
|
||||
#| #o37x |# #x042C #x042B #x0417 #x0428 #x042D #x0429 #x0427 #x042A)
|
||||
)
|
||||
|
||||
347
xml/encodings.lisp
Normal file
347
xml/encodings.lisp
Normal file
@ -0,0 +1,347 @@
|
||||
(in-package :encoding)
|
||||
|
||||
;;;; ---------------------------------------------------------------------------
|
||||
;;;; Encoding names
|
||||
;;;;
|
||||
|
||||
(defvar *names* (make-hash-table :test #'eq))
|
||||
|
||||
(defun canon-name (string)
|
||||
(with-output-to-string (bag)
|
||||
(map nil (lambda (ch)
|
||||
(cond ((char= ch #\_) (write-char #\- bag))
|
||||
(t (write-char (char-upcase ch) bag))))
|
||||
string)))
|
||||
|
||||
(defun canon-name-2 (string)
|
||||
(with-output-to-string (bag)
|
||||
(map nil (lambda (ch)
|
||||
(cond ((char= ch #\_))
|
||||
((char= ch #\-))
|
||||
(t (write-char (char-upcase ch) bag))))
|
||||
string)))
|
||||
|
||||
(defmethod encoding-names ((encoding symbol))
|
||||
(gethash encoding *names*))
|
||||
|
||||
(defmethod (setf encoding-names) (new-value (encoding symbol))
|
||||
(setf (gethash encoding *names*) new-value))
|
||||
|
||||
(defun add-name (encoding name)
|
||||
(pushnew (canon-name name) (encoding-names encoding) :test #'string=))
|
||||
|
||||
(defun resolve-name (string)
|
||||
(cond ((symbolp string)
|
||||
string)
|
||||
(t
|
||||
(setq string (canon-name string))
|
||||
(or
|
||||
(block nil
|
||||
(maphash (lambda (x y)
|
||||
(when (member string y :test #'string=)
|
||||
(return x)))
|
||||
*names*)
|
||||
nil)
|
||||
(block nil
|
||||
(maphash (lambda (x y)
|
||||
(when (member string y
|
||||
:test #'(lambda (x y)
|
||||
(string= (canon-name-2 x)
|
||||
(canon-name-2 y))))
|
||||
(return x)))
|
||||
*names*)
|
||||
nil)))))
|
||||
|
||||
;;;; ---------------------------------------------------------------------------
|
||||
;;;; Encodings
|
||||
;;;;
|
||||
|
||||
(defvar *encodings* (make-hash-table :test #'eq))
|
||||
|
||||
(defmacro define-encoding (name init-form)
|
||||
`(progn
|
||||
(setf (gethash ',name *encodings*)
|
||||
(list nil (lambda () ,init-form)))
|
||||
',name))
|
||||
|
||||
(defun find-encoding (name)
|
||||
(let ((x (gethash (resolve-name name) *encodings*)))
|
||||
(and x
|
||||
(or (first x)
|
||||
(setf (first x) (funcall (second x)))))))
|
||||
|
||||
(defclass encoding () ())
|
||||
|
||||
(defclass simple-8-bit-encoding (encoding)
|
||||
((table :initarg :table)))
|
||||
|
||||
(defun make-simple-8-bit-encoding (&key charset)
|
||||
(make-instance 'simple-8-bit-encoding
|
||||
:table (coerce (to-unicode-table charset) '(simple-array (unsigned-byte 16) (256)))))
|
||||
|
||||
;;;;;;;
|
||||
|
||||
(defmacro fx-op (op &rest xs)
|
||||
`(the fixnum (,op ,@(mapcar (lambda (x) `(the fixnum ,x)) xs))))
|
||||
(defmacro fx-pred (op &rest xs)
|
||||
`(,op ,@(mapcar (lambda (x) `(the fixnum ,x)) xs)))
|
||||
|
||||
(defmacro %+ (&rest xs) `(fx-op + ,@xs))
|
||||
(defmacro %- (&rest xs) `(fx-op - ,@xs))
|
||||
(defmacro %* (&rest xs) `(fx-op * ,@xs))
|
||||
(defmacro %/ (&rest xs) `(fx-op floor ,@xs))
|
||||
(defmacro %and (&rest xs) `(fx-op logand ,@xs))
|
||||
(defmacro %ior (&rest xs) `(fx-op logior ,@xs))
|
||||
(defmacro %xor (&rest xs) `(fx-op logxor ,@xs))
|
||||
(defmacro %ash (&rest xs) `(fx-op ash ,@xs))
|
||||
(defmacro %mod (&rest xs) `(fx-op mod ,@xs))
|
||||
|
||||
(defmacro %= (&rest xs) `(fx-pred = ,@xs))
|
||||
(defmacro %<= (&rest xs) `(fx-pred <= ,@xs))
|
||||
(defmacro %>= (&rest xs) `(fx-pred >= ,@xs))
|
||||
(defmacro %< (&rest xs) `(fx-pred < ,@xs))
|
||||
(defmacro %> (&rest xs) `(fx-pred > ,@xs))
|
||||
|
||||
(defmethod decode-sequence ((encoding (eql :utf-16-big-endian))
|
||||
in in-start in-end out out-start out-end eof?)
|
||||
;; -> new wptr, new rptr
|
||||
(let ((wptr out-start)
|
||||
(rptr in-start))
|
||||
(loop
|
||||
(when (%= wptr out-end)
|
||||
(return))
|
||||
(when (>= (%+ rptr 1) in-end)
|
||||
(return))
|
||||
(let ((hi (aref in rptr))
|
||||
(lo (aref in (%+ 1 rptr))))
|
||||
(setf rptr (%+ 2 rptr))
|
||||
(setf (aref out wptr) (logior (ash hi 8) lo))
|
||||
(setf wptr (%+ 1 wptr))))
|
||||
(values wptr rptr)))
|
||||
|
||||
(defmethod decode-sequence ((encoding (eql :utf-16-little-endian))
|
||||
in in-start in-end out out-start out-end eof?)
|
||||
;; -> new wptr, new rptr
|
||||
(let ((wptr out-start)
|
||||
(rptr in-start))
|
||||
(loop
|
||||
(when (%= wptr out-end)
|
||||
(return))
|
||||
(when (>= (%+ rptr 1) in-end)
|
||||
(return))
|
||||
(let ((lo (aref in (%+ 0 rptr)))
|
||||
(hi (aref in (%+ 1 rptr))))
|
||||
(setf rptr (%+ 2 rptr))
|
||||
(setf (aref out wptr) (logior (ash hi 8) lo))
|
||||
(setf wptr (%+ 1 wptr))))
|
||||
(values wptr rptr)))
|
||||
|
||||
(defmethod decode-sequence ((encoding (eql :utf-8))
|
||||
in in-start in-end out out-start out-end eof?)
|
||||
(declare (optimize (speed 3) (safety 0))
|
||||
(type (simple-array (unsigned-byte 8) (*)) in)
|
||||
(type (simple-array rune (*)) out)
|
||||
(type fixnum in-start in-end out-start out-end))
|
||||
(let ((wptr out-start)
|
||||
(rptr in-start)
|
||||
byte0)
|
||||
(macrolet ((put (x)
|
||||
`((lambda (x)
|
||||
(cond ((or (<= #xD800 x #xDBFF)
|
||||
(<= #xDC00 x #xDFFF))
|
||||
(error "Encoding UTF-16 in UTF-8? : #x~x." x)))
|
||||
'(unless (data-char-p x)
|
||||
(error "#x~x is not a data character." x))
|
||||
;;(fresh-line)
|
||||
;;(prin1 x) (princ "-> ")
|
||||
(cond ((%> x #xFFFF)
|
||||
(setf (aref out (%+ 0 wptr)) (%+ #xD7C0 (ash x -10))
|
||||
(aref out (%+ 1 wptr)) (%ior #xDC00 (%and x #x3FF)))
|
||||
(setf wptr (%+ wptr 2)))
|
||||
(t
|
||||
(setf (aref out wptr) x)
|
||||
(setf wptr (%+ wptr 1)))))
|
||||
,x))
|
||||
(put1 (x)
|
||||
`(progn
|
||||
(setf (aref out wptr) ,x)
|
||||
(setf wptr (%+ wptr 1)))))
|
||||
(loop
|
||||
(when (%= (+ wptr 1) out-end) (return))
|
||||
(when (%>= rptr in-end) (return))
|
||||
(setq byte0 (aref in rptr))
|
||||
(cond ((= byte0 #x0D)
|
||||
;; CR handling
|
||||
;; we need to know the following character
|
||||
(cond ((>= (%+ rptr 1) in-end)
|
||||
;; no characters in buffer
|
||||
(cond (eof?
|
||||
;; at EOF, pass it as NL
|
||||
(put #x0A)
|
||||
(setf rptr (%+ rptr 1)))
|
||||
(t
|
||||
;; demand more characters
|
||||
(return))))
|
||||
((= (aref in (%+ rptr 1)) #x0A)
|
||||
;; we see CR NL, so forget this CR and the next NL will be
|
||||
;; inserted literally
|
||||
(setf rptr (%+ rptr 1)))
|
||||
(t
|
||||
;; singleton CR, pass it as NL
|
||||
(put #x0A)
|
||||
(setf rptr (%+ rptr 1)))))
|
||||
|
||||
((%<= #|#b00000000|# byte0 #b01111111)
|
||||
(put1 byte0)
|
||||
(setf rptr (%+ rptr 1)))
|
||||
|
||||
((%<= #|#b10000000|# byte0 #b10111111)
|
||||
(error "Corrupted UTF-8 input (initial byte was #b~8,'0B)" byte0)
|
||||
(setf rptr (%+ rptr 1)))
|
||||
|
||||
((%<= #|#b11000000|# byte0 #b11011111)
|
||||
(cond ((< (%+ rptr 2) in-end)
|
||||
(put
|
||||
(dpb (ldb (byte 5 0) byte0) (byte 5 6)
|
||||
(dpb (ldb (byte 6 0) (aref in (%+ rptr 1))) (byte 6 0)
|
||||
0)))
|
||||
(setf rptr (%+ rptr 2)))
|
||||
(t
|
||||
(return))))
|
||||
|
||||
((%<= #|#b11100000|# byte0 #b11101111)
|
||||
(cond ((< (%+ rptr 3) in-end)
|
||||
(put
|
||||
(dpb (ldb (byte 4 0) byte0) (byte 4 12)
|
||||
(dpb (ldb (byte 6 0) (aref in (%+ 1 rptr))) (byte 6 6)
|
||||
(dpb (ldb (byte 6 0) (aref in (%+ 2 rptr))) (byte 6 0)
|
||||
0))))
|
||||
(setf rptr (%+ rptr 3)))
|
||||
(t
|
||||
(return))))
|
||||
|
||||
((%<= #|#b11110000|# byte0 #b11110111)
|
||||
(cond ((< (%+ rptr 4) in-end)
|
||||
(put
|
||||
(dpb (ldb (byte 3 0) byte0) (byte 3 18)
|
||||
(dpb (ldb (byte 6 0) (aref in (%+ 1 rptr))) (byte 6 12)
|
||||
(dpb (ldb (byte 6 0) (aref in (%+ 2 rptr))) (byte 6 6)
|
||||
(dpb (ldb (byte 6 0) (aref in (%+ 3 rptr))) (byte 6 0)
|
||||
0)))))
|
||||
(setf rptr (%+ rptr 4)))
|
||||
(t
|
||||
(return))))
|
||||
|
||||
((%<= #|#b11111000|# byte0 #b11111011)
|
||||
(cond ((< (%+ rptr 5) in-end)
|
||||
(put
|
||||
(dpb (ldb (byte 2 0) byte0) (byte 2 24)
|
||||
(dpb (ldb (byte 6 0) (aref in (%+ 1 rptr))) (byte 6 18)
|
||||
(dpb (ldb (byte 6 0) (aref in (%+ 2 rptr))) (byte 6 12)
|
||||
(dpb (ldb (byte 6 0) (aref in (%+ 3 rptr))) (byte 6 6)
|
||||
(dpb (ldb (byte 6 0) (aref in (%+ 4 rptr))) (byte 6 0)
|
||||
0))))))
|
||||
(setf rptr (%+ rptr 5)))
|
||||
(t
|
||||
(return))))
|
||||
|
||||
((%<= #|#b11111100|# byte0 #b11111101)
|
||||
(cond ((< (%+ rptr 6) in-end)
|
||||
(put
|
||||
(dpb (ldb (byte 1 0) byte0) (byte 1 30)
|
||||
(dpb (ldb (byte 6 0) (aref in (%+ 1 rptr))) (byte 6 24)
|
||||
(dpb (ldb (byte 6 0) (aref in (%+ 2 rptr))) (byte 6 18)
|
||||
(dpb (ldb (byte 6 0) (aref in (%+ 3 rptr))) (byte 6 12)
|
||||
(dpb (ldb (byte 6 0) (aref in (%+ 4 rptr))) (byte 6 6)
|
||||
(dpb (ldb (byte 6 0) (aref in (%+ 5 rptr))) (byte 6 0)
|
||||
0)))))))
|
||||
(setf rptr (%+ rptr 6)))
|
||||
(t
|
||||
(return))))
|
||||
|
||||
(t
|
||||
(error "Corrupted UTF-8 input (initial byte was #b~8,'0B)" byte0)) ) ))
|
||||
(values wptr rptr)) )
|
||||
|
||||
(defmethod encoding-p ((object (eql :utf-16-little-endian))) t)
|
||||
(defmethod encoding-p ((object (eql :utf-16-big-endian))) t)
|
||||
(defmethod encoding-p ((object (eql :utf-8))) t)
|
||||
|
||||
(defmethod encoding-p ((object encoding)) t)
|
||||
|
||||
(defmethod decode-sequence ((encoding simple-8-bit-encoding)
|
||||
in in-start in-end
|
||||
out out-start out-end
|
||||
eof?)
|
||||
(declare (optimize (speed 3) (safety 0))
|
||||
(type (simple-array (unsigned-byte 8) (*)) in)
|
||||
(type (simple-array rune (*)) out)
|
||||
(type fixnum in-start in-end out-start out-end))
|
||||
(let ((wptr out-start)
|
||||
(rptr in-start)
|
||||
(byte 0)
|
||||
(table (slot-value encoding 'table)))
|
||||
(declare (type fixnum wptr rptr)
|
||||
(type (unsigned-byte 8) byte)
|
||||
(type (simple-array (unsigned-byte 16) (*)) table))
|
||||
(loop
|
||||
(when (%= wptr out-end) (return))
|
||||
(when (%>= rptr in-end) (return))
|
||||
(setq byte (aref in rptr))
|
||||
(cond ((= byte #x0D)
|
||||
;; CR handling
|
||||
;; we need to know the following character
|
||||
(cond ((>= (%+ rptr 1) in-end)
|
||||
;; no characters in buffer
|
||||
(cond (eof?
|
||||
;; at EOF, pass it as NL
|
||||
(setf (aref out wptr) #x0A)
|
||||
(setf wptr (%+ wptr 1))
|
||||
(setf rptr (%+ rptr 1)))
|
||||
(t
|
||||
;; demand more characters
|
||||
(return))))
|
||||
((= (aref in (%+ rptr 1)) #x0A)
|
||||
;; we see CR NL, so forget this CR and the next NL will be
|
||||
;; inserted literally
|
||||
(setf rptr (%+ rptr 1)))
|
||||
(t
|
||||
;; singleton CR, pass it as NL
|
||||
(setf (aref out wptr) #x0A)
|
||||
(setf wptr (%+ wptr 1))
|
||||
(setf rptr (%+ rptr 1)))))
|
||||
|
||||
(t
|
||||
(setf (aref out wptr) (aref table byte))
|
||||
(setf wptr (%+ wptr 1))
|
||||
(setf rptr (%+ rptr 1))) ))
|
||||
(values wptr rptr)))
|
||||
|
||||
;;;; ---------------------------------------------------------------------------
|
||||
;;;; Character sets
|
||||
;;;;
|
||||
|
||||
(defvar *charsets* (make-hash-table :test #'eq))
|
||||
|
||||
(defclass 8-bit-charset ()
|
||||
((name :initarg :name)
|
||||
(to-unicode-table
|
||||
:initarg :to-unicode-table
|
||||
:reader to-unicode-table)))
|
||||
|
||||
(defmacro define-8-bit-charset (name &rest codes)
|
||||
(assert (= 256 (length codes)))
|
||||
`(progn
|
||||
(setf (gethash ',name *charsets*)
|
||||
(make-instance '8-bit-charset
|
||||
:name ',name
|
||||
:to-unicode-table
|
||||
',(make-array 256
|
||||
:element-type '(unsigned-byte 16)
|
||||
:initial-contents codes)))
|
||||
',name))
|
||||
|
||||
(defun find-charset (name)
|
||||
(or (gethash name *charsets*)
|
||||
(error "There is no character set named ~S." name)))
|
||||
|
||||
41
xml/package.lisp
Normal file
41
xml/package.lisp
Normal file
@ -0,0 +1,41 @@
|
||||
(in-package :cl-user)
|
||||
|
||||
(defpackage :Encoding
|
||||
(:use :glisp)
|
||||
(:export
|
||||
#:find-encoding
|
||||
#:decode-sequence))
|
||||
|
||||
(defpackage :XML
|
||||
(:use
|
||||
:glisp
|
||||
:encoding)
|
||||
|
||||
(:Export
|
||||
;; xstreams
|
||||
#:make-xstream
|
||||
#:make-rod-xstream
|
||||
#:close-xstream
|
||||
#:read-rune
|
||||
#:peek-rune
|
||||
#:unread-rune
|
||||
#:fread-rune
|
||||
#:fpeek-rune
|
||||
#:xstream-position
|
||||
#:xstream-line-number
|
||||
#:xstream-column-number
|
||||
#:xstream-plist
|
||||
#:xstream-encoding
|
||||
|
||||
;; xstream controller protocol
|
||||
#:read-octects
|
||||
#:xstream/close
|
||||
|
||||
#:attribute-namespace-uri
|
||||
#:attribute-local-name
|
||||
#:attribute-qname
|
||||
#:attribute-value
|
||||
|
||||
#:parse-file
|
||||
#:parse-stream
|
||||
#:parse-string) )
|
||||
110
xml/recoder.lisp
Normal file
110
xml/recoder.lisp
Normal file
@ -0,0 +1,110 @@
|
||||
(in-package :cxml)
|
||||
|
||||
(defclass recoder ()
|
||||
((recoder :initarg :recoder :accessor recoder)
|
||||
(chained-handler :initarg :chained-handler :accessor chained-handler)))
|
||||
|
||||
(defun make-recoder (chained-handler &optional (recoder-fn #'rod-string))
|
||||
(make-instance 'recoder
|
||||
:recoder recoder-fn
|
||||
:chained-handler chained-handler))
|
||||
|
||||
(macrolet ((%string (rod)
|
||||
`(let ((rod ,rod))
|
||||
(if (typep rod '(or rod string))
|
||||
(funcall (recoder handler) rod)
|
||||
rod)))
|
||||
(defwrapper (name (&rest args) &rest forms)
|
||||
`(defmethod ,name ((handler recoder) ,@args)
|
||||
(,name (chained-handler handler) ,@forms))))
|
||||
(defwrapper sax:start-document ())
|
||||
|
||||
(defwrapper sax:start-element
|
||||
(namespace-uri local-name qname attributes)
|
||||
(%string namespace-uri)
|
||||
(%string local-name)
|
||||
(%string qname)
|
||||
(mapcar (lambda (attr)
|
||||
(sax:make-attribute
|
||||
:namespace-uri (%string (sax:attribute-namespace-uri attr))
|
||||
:local-name (%string (sax:attribute-local-name attr))
|
||||
:qname (%string (sax:attribute-qname attr))
|
||||
:value (%string (sax:attribute-value attr))
|
||||
:specified-p (sax:attribute-specified-p attr)))
|
||||
attributes))
|
||||
|
||||
(defwrapper sax:start-prefix-mapping (prefix uri)
|
||||
(%string prefix)
|
||||
(%string uri))
|
||||
|
||||
(defwrapper sax:characters (data)
|
||||
(%string data))
|
||||
|
||||
(defwrapper sax:processing-instruction (target data)
|
||||
(%string target)
|
||||
(%string data))
|
||||
|
||||
(defwrapper sax:end-prefix-mapping (prefix)
|
||||
(%string prefix))
|
||||
|
||||
(defwrapper sax:end-element (namespace-uri local-name qname)
|
||||
(%string namespace-uri)
|
||||
(%string local-name)
|
||||
(%string qname))
|
||||
|
||||
(defwrapper sax:end-document ())
|
||||
|
||||
(defwrapper sax:comment (data)
|
||||
(%string data))
|
||||
|
||||
(defwrapper sax:start-cdata ())
|
||||
|
||||
(defwrapper sax:end-cdata ())
|
||||
|
||||
(defwrapper sax:start-dtd (name public-id system-id)
|
||||
(%string name)
|
||||
(%string public-id)
|
||||
(%string system-id))
|
||||
|
||||
(defwrapper sax:end-dtd ())
|
||||
|
||||
(defwrapper sax:unparsed-entity-declaration
|
||||
(name public-id system-id notation-name)
|
||||
(%string name)
|
||||
(%string public-id)
|
||||
(%string system-id)
|
||||
(%string notation-name))
|
||||
|
||||
(defwrapper sax:external-entity-declaration
|
||||
(kind name public-id system-id)
|
||||
(%string kind)
|
||||
(%string name)
|
||||
(%string public-id)
|
||||
(%string system-id))
|
||||
|
||||
(defwrapper sax:internal-entity-declaration
|
||||
(kind name value)
|
||||
kind
|
||||
(%string name)
|
||||
(%string value))
|
||||
|
||||
(defwrapper sax:notation-declaration
|
||||
(name public-id system-id)
|
||||
(%string name)
|
||||
(%string public-id)
|
||||
(%string system-id))
|
||||
|
||||
(defwrapper sax:element-declaration (name model)
|
||||
(%string name)
|
||||
model)
|
||||
|
||||
(defwrapper sax:attribute-declaration
|
||||
(element-name attribute-name type default)
|
||||
(%string element-name)
|
||||
(%string attribute-name)
|
||||
(%string type)
|
||||
(%string default))
|
||||
|
||||
(defwrapper sax:entity-resolver
|
||||
(resolver)
|
||||
resolver))
|
||||
227
xml/sax-handler.lisp
Normal file
227
xml/sax-handler.lisp
Normal file
@ -0,0 +1,227 @@
|
||||
;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: SAX; readtable: glisp; Encoding: utf-8; -*-
|
||||
;;; ---------------------------------------------------------------------------
|
||||
;;; Title: A SAX2-like API for the xml parser
|
||||
;;; Created: 2003-06-30
|
||||
;;; Author: Henrik Motakef <hmot@henrik-motakef.de>
|
||||
;;; License: BSD
|
||||
;;; ---------------------------------------------------------------------------
|
||||
;;; <20> copyright 2003 by Henrik Motakef
|
||||
|
||||
;;; Redistribution and use in source and binary forms, with or without
|
||||
;;; modification, are permitted provided that the following conditions are
|
||||
;;; met:
|
||||
;;;
|
||||
;;; 1. Redistributions of source code must retain the above copyright
|
||||
;;; notice, this list of conditions and the following disclaimer.
|
||||
;;;
|
||||
;;; 2. Redistributions in binary form must reproduce the above copyright
|
||||
;;; notice, this list of conditions and the following disclaimer in the
|
||||
;;; documentation and/or other materials provided with the distribution
|
||||
;;;
|
||||
;;; THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED
|
||||
;;; WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
|
||||
;;; MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
|
||||
;;; IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
|
||||
;;; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
|
||||
;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
|
||||
;;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
|
||||
;;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
|
||||
;;; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING
|
||||
;;; IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
;;; POSSIBILITY OF SUCH DAMAGE.
|
||||
|
||||
;;; TODO/ Open Questions:
|
||||
|
||||
;; o Should there be a predefined "handler" class, or even several
|
||||
;; (like Java SAX' ContentHandler, DTDHandler, LexicalHandler etc? I
|
||||
;; don't really see why.
|
||||
;; o Missing stuff from Java SAX2:
|
||||
;; * ignorable-whitespace
|
||||
;; * document-locator/(setf document-locator)
|
||||
;; (probably implies a handler class with an appropriate slot)
|
||||
;; * skipped-entity
|
||||
;; * notation-declaration
|
||||
;; * unparsed-entity-declaration
|
||||
;; * The whole ErrorHandler class, this is better handled using
|
||||
;; conditions (but isn't yet)
|
||||
;; * The LexicalHandler (start-cdata etc) would be nice
|
||||
;; * The DeclHandler interface (element-decl, attribute-decl...)
|
||||
;; is useful, but the Java interface sucks.
|
||||
;; o Despite all the namespace-uri etc arguments, namespaces are not
|
||||
;; really supported yet, the xml parser always passes nil. This will
|
||||
;; hopefully change Real Soon Now, and I didn't want to have to
|
||||
;; rewrite the interface then
|
||||
|
||||
(defpackage :sax
|
||||
(:use :common-lisp)
|
||||
(:export #:*namespace-processing*
|
||||
#:*include-xmlns-attributes*
|
||||
#:*use-xmlns-namespace*
|
||||
|
||||
#:start-document
|
||||
#:start-prefix-mapping
|
||||
#:start-element
|
||||
#:characters
|
||||
#:processing-instruction
|
||||
#:end-element
|
||||
#:end-prefix-mapping
|
||||
#:end-document
|
||||
#:comment
|
||||
#:start-cdata
|
||||
#:end-cdata))
|
||||
|
||||
(in-package :sax)
|
||||
|
||||
;; The http://xml.org/sax/features/namespaces property
|
||||
(defvar *namespace-processing* t
|
||||
"If non-nil (the default), namespace processing is enabled.
|
||||
|
||||
See also `start-element' and `end-element' for a detailed description
|
||||
of the consequences of modifying this variable, and
|
||||
`*include-xmlns-attributes*' and `*use-xmlns-namespace*' for further
|
||||
related options.")
|
||||
|
||||
;; The http://xml.org/sax/features/namespace-prefixes property.
|
||||
(defvar *include-xmlns-attributes* nil
|
||||
"If non-nil, namespace declarations are reported as normal
|
||||
attributes.
|
||||
|
||||
This variable has no effect unless `*namespace-processing*' is
|
||||
non-nil.
|
||||
|
||||
See also `*use-xmlns-namespace*', and `start-element' for a detailed
|
||||
description of the consequences of setting this variable.")
|
||||
|
||||
(defvar *use-xmlns-namespace* nil
|
||||
"If this variable is nil (the default), attributes with a name like
|
||||
'xmlns:x' are not considered to be in a namespace, following the
|
||||
'Namespaces in XML' specification.
|
||||
|
||||
If it is non-nil, such attributes are considered to be in a namespace
|
||||
with the URI 'http://www.w3.org/2000/xmlns/', following an
|
||||
incompatible change silently introduced in the errata to that spec,
|
||||
and adopted by some W3C standards.
|
||||
|
||||
For example, an attribute like xmlns:ex='http://example.com' would be
|
||||
reported like this:
|
||||
|
||||
*use-xmlns-namespace*: nil
|
||||
namespace-uri: nil
|
||||
local-name: nil
|
||||
qname: #\"xmlns:ex\"
|
||||
|
||||
*use-xmlns-namespace*: t
|
||||
namespace-uri: #\"http://www.w3.org/2000/xmlns/\"
|
||||
local-name: #\"ex\"
|
||||
qname: #\"xmlns:ex\"
|
||||
|
||||
Setting this variable has no effect unless both
|
||||
`*namespace-processing*' and `*include-xmlns-attributes*' are non-nil.")
|
||||
|
||||
(defgeneric start-document (handler)
|
||||
(:documentation "Called at the beginning of the parsing process,
|
||||
before any element, processing instruction or comment is reported.
|
||||
|
||||
Handlers that need to maintain internal state may use this to perform
|
||||
any neccessary initializations.")
|
||||
(:method ((handler t)) nil))
|
||||
|
||||
;; How should attributes be represented?
|
||||
;; Currently its just a (name . value) alist, but this isn't too
|
||||
;; useful wrt namespaced attributes. Probably a struct.
|
||||
(defgeneric start-element (handler namespace-uri local-name qname attributes)
|
||||
(:documentation "Called to report the beginning of an element.
|
||||
|
||||
There will always be a corresponding call to end-element, even in the
|
||||
case of an empty element (i.e. <foo/>).
|
||||
|
||||
If the value of *namespaces* is non-nil, namespace-uri, local-name and
|
||||
qname are rods. If it is nil, namespace-uri and local-name are always
|
||||
nil, and it is not an error if the qname is not a well-formed
|
||||
qualified element name (for example, if it contains more than one
|
||||
colon).
|
||||
|
||||
The attributes parameter is a list (in arbitrary order) of instances
|
||||
of the `attribute' structure class. The for their namespace-uri and
|
||||
local-name properties, the same rules as for the element name
|
||||
apply. Additionally, namespace-declaring attributes (those whose name
|
||||
is \"xmlns\" or starts with \"xmlns:\") are only included if
|
||||
*namespace-prefixes* is non-nil.")
|
||||
(:method ((handler t) namespace-uri local-name qname attributes) nil))
|
||||
|
||||
(defgeneric start-prefix-mapping (handler prefix uri)
|
||||
(:documentation "Called when the scope of a new prefix -> namespace-uri mapping begins.
|
||||
|
||||
This will always be called immediatly before the `start-element' event
|
||||
for the element on which the namespaces are declared.
|
||||
|
||||
Clients don't usually have to implement this except under special
|
||||
circumstances, for example when they have to deal with qualified names
|
||||
in textual content. The parser will handle namespaces of elements and
|
||||
attributes on its own.")
|
||||
(:method ((handler t) prefix uri) nil))
|
||||
|
||||
(defgeneric characters (handler data)
|
||||
(:documentation "Called for textual element content.
|
||||
|
||||
The data is passed as a rod, with all entity references resolved.
|
||||
It is possible that the character content of an element is reported
|
||||
via multiple subsequent calls to this generic function.")
|
||||
(:method ((handler t) data) nil))
|
||||
|
||||
(defgeneric processing-instruction (handler target data)
|
||||
(:documentation "Called when a processing instruction is read.
|
||||
|
||||
Both target and data are rods.")
|
||||
(:method ((handler t) target data) nil))
|
||||
|
||||
(defgeneric end-prefix-mapping (handler prefix)
|
||||
(:documentation "Called when a prefix -> namespace-uri mapping goes out of scope.
|
||||
|
||||
This will always be called immediatly after the `end-element' event
|
||||
for the element on which the namespace is declared. The order of the
|
||||
end-prefix-mapping events is otherwise not guaranteed.
|
||||
|
||||
Clients don't usually have to implement this except under special
|
||||
circumstances, for example when they have to deal with qualified names
|
||||
in textual content. The parser will handle namespaces of elements and
|
||||
attributes on its own.")
|
||||
(:method ((handler t) prefix) nil))
|
||||
|
||||
(defgeneric end-element (handler namespace-uri local-name qname)
|
||||
(:documentation "Called to report the end of an element.
|
||||
|
||||
See the documentation for `start-element' for a description of the
|
||||
parameters.")
|
||||
(:method ((handler t) namespace-uri local-name qname) nil))
|
||||
|
||||
(defgeneric end-document (handler)
|
||||
(:documentation "Called at the end of parsing a document.
|
||||
This is always the last function called in the parsing process.
|
||||
|
||||
In contrast to all of the other methods, the return value of this gf
|
||||
is significant, it will be returned by the parse-file/stream/string function.")
|
||||
(:method ((handler t)) nil))
|
||||
|
||||
;; LexicalHandler
|
||||
|
||||
(defgeneric comment (handler data)
|
||||
(:method ((handler t) data) nil))
|
||||
|
||||
(defgeneric start-cdata (handler)
|
||||
(:documentation "Called at the beginning of parsing a CDATA section.
|
||||
|
||||
Handlers only have to implement this if they are interested in the
|
||||
lexical structure of the parsed document. The content of the CDATA
|
||||
section is reported via the `characters' generic function like all
|
||||
other textual content.")
|
||||
(:method ((handler t)) nil))
|
||||
|
||||
(defgeneric end-cdata (handler)
|
||||
(:documentation "Called at the end of parsing a CDATA section.
|
||||
|
||||
Handlers only have to implement this if they are interested in the
|
||||
lexical structure of the parsed document. The content of the CDATA
|
||||
section is reported via the `characters' generic function like all
|
||||
other textual content.")
|
||||
(:method ((handler t)) nil))
|
||||
38
xml/sax-proxy.lisp
Normal file
38
xml/sax-proxy.lisp
Normal file
@ -0,0 +1,38 @@
|
||||
;;;; sax-proxy.lisp
|
||||
;;;;
|
||||
;;;; This file is part of the CXML parser, released under (L)LGPL.
|
||||
;;;; See file COPYING for details.
|
||||
;;;;
|
||||
;;;; Copyright (c) 2004 David Lichteblau
|
||||
;;;; Author: David Lichteblau
|
||||
|
||||
(in-package :cxml)
|
||||
|
||||
(defclass sax-proxy ()
|
||||
((chained-handler :initform nil
|
||||
:initarg :chained-handler
|
||||
:accessor proxy-chained-handler)))
|
||||
|
||||
(macrolet ((define-proxy-method (name (&rest args))
|
||||
`(defmethod ,name ((handler sax-proxy) ,@args)
|
||||
(,name (proxy-chained-handler handler) ,@args))))
|
||||
(define-proxy-method sax:start-document ())
|
||||
(define-proxy-method sax:start-element (uri lname qname attributes))
|
||||
(define-proxy-method sax:start-prefix-mapping (prefix uri))
|
||||
(define-proxy-method sax:characters (data))
|
||||
(define-proxy-method sax:processing-instruction (target data))
|
||||
(define-proxy-method sax:end-prefix-mapping (prefix))
|
||||
(define-proxy-method sax:end-element (namespace-uri local-name qname))
|
||||
(define-proxy-method sax:end-document ())
|
||||
(define-proxy-method sax:comment (data))
|
||||
(define-proxy-method sax:start-cdata ())
|
||||
(define-proxy-method sax:end-cdata ())
|
||||
(define-proxy-method sax:start-dtd (name public-id system-id))
|
||||
(define-proxy-method sax:end-dtd ())
|
||||
(define-proxy-method sax:unparsed-entity-declaration (name pub sys not))
|
||||
(define-proxy-method sax:external-entity-declaration (kind name pub sys))
|
||||
(define-proxy-method sax:internal-entity-declaration (kind name value))
|
||||
(define-proxy-method sax:notation-declaration (name public-id system-id))
|
||||
(define-proxy-method sax:element-declaration (name model))
|
||||
(define-proxy-method sax:attribute-declaration (elt attr type default))
|
||||
(define-proxy-method sax:entity-resolver (resolver)))
|
||||
37
xml/sax-tests/event-collecting-handler.lisp
Normal file
37
xml/sax-tests/event-collecting-handler.lisp
Normal file
@ -0,0 +1,37 @@
|
||||
(in-package :sax-tests)
|
||||
|
||||
(defclass event-collecting-handler ()
|
||||
((event-list :initform '() :accessor event-list)))
|
||||
|
||||
(defmethod start-document ((handler event-collecting-handler))
|
||||
(push (list :start-document) (event-list handler)))
|
||||
|
||||
(defmethod start-element ((handler event-collecting-handler) ns-uri local-name qname attrs)
|
||||
(push (list :start-element ns-uri local-name qname attrs)
|
||||
(event-list handler)))
|
||||
|
||||
(defmethod start-prefix-mapping ((handler event-collecting-handler) prefix uri)
|
||||
(push (list :start-prefix-mapping prefix uri)
|
||||
(event-list handler)))
|
||||
|
||||
(defmethod characters ((handler event-collecting-handler) data)
|
||||
(push (list :characters data)
|
||||
(event-list handler)))
|
||||
|
||||
(defmethod processing-instruction ((handler event-collecting-handler) target data)
|
||||
(push (list :processing-instruction target data)
|
||||
(event-list handler)))
|
||||
|
||||
(defmethod end-prefix-mapping ((handler event-collecting-handler) prefix)
|
||||
(push (list :end-prefix-mapping prefix)
|
||||
(event-list handler)))
|
||||
|
||||
(defmethod end-element ((handler event-collecting-handler) namespace-uri local-name qname)
|
||||
(push (list :end-element namespace-uri local-name qname)
|
||||
(event-list handler)))
|
||||
|
||||
(defmethod end-document ((handler event-collecting-handler))
|
||||
(push (list :end-document)
|
||||
(event-list handler))
|
||||
|
||||
(nreverse (event-list handler)))
|
||||
4
xml/sax-tests/package.lisp
Normal file
4
xml/sax-tests/package.lisp
Normal file
@ -0,0 +1,4 @@
|
||||
(defpackage :sax-tests
|
||||
(:use :cl :xml :sax :glisp :rt)
|
||||
(:export #:event-collecting-handler))
|
||||
|
||||
332
xml/sax-tests/tests.lisp
Normal file
332
xml/sax-tests/tests.lisp
Normal file
@ -0,0 +1,332 @@
|
||||
(in-package :sax-tests)
|
||||
|
||||
(defun first-start-element-event (string)
|
||||
(let ((events (xml:parse-string string (make-instance 'event-collecting-handler))))
|
||||
(find :start-element events :key #'car)))
|
||||
|
||||
|
||||
;;; Attribute handling
|
||||
|
||||
(deftest no-default-namespace-for-attributes
|
||||
(let* ((evt (first-start-element-event "<x xmlns='http://example.com' a='b'/>"))
|
||||
(attr (car (fifth evt))))
|
||||
(values
|
||||
(attribute-namespace-uri attr)
|
||||
(attribute-local-name attr)))
|
||||
nil nil)
|
||||
|
||||
(deftest attribute-uniqueness-1
|
||||
(handler-case
|
||||
(xml:parse-string "<x xmlns:a='http://example.com' xmlns:b='http://example.com' a:a='1' b:a='1'/>")
|
||||
(error () t)
|
||||
(:no-error (&rest junk)
|
||||
(declare (ignore junk))
|
||||
nil))
|
||||
t)
|
||||
|
||||
(deftest attribute-uniqueness-2
|
||||
(handler-case
|
||||
(xml:parse-string "<x xmlns:a='http://example.com' xmlns='http://example.com' a:a='1' a='1'/>")
|
||||
(error () nil)
|
||||
(:no-error (&rest junk)
|
||||
(declare (ignore junk))
|
||||
t))
|
||||
t)
|
||||
|
||||
(deftest attribute-uniqueness-3
|
||||
(let ((sax:*namespace-processing* nil))
|
||||
(handler-case
|
||||
(xml:parse-string "<x xmlns:a='http://example.com' xmlns:b='http://example.com' a:a='1' b:a='1'/>")
|
||||
(error () nil)
|
||||
(:no-error (&rest junk)
|
||||
(declare (ignore junk))
|
||||
t)))
|
||||
t)
|
||||
|
||||
;;; Namespace undeclaring
|
||||
|
||||
(deftest undeclare-default-namespace-1
|
||||
(let* ((evts (xml:parse-string "<x xmlns='http://example.com'><y xmlns='' a='1'/></x>"
|
||||
(make-instance 'event-collecting-handler)))
|
||||
(start-elt-events (remove :start-element evts :test (complement #'eql) :key #'car))
|
||||
(evt1 (first start-elt-events))
|
||||
(evt2 (second start-elt-events )))
|
||||
(values
|
||||
(rod= #"http://example.com" (second evt1))
|
||||
(second evt2)
|
||||
(third evt2)))
|
||||
t nil nil)
|
||||
|
||||
(deftest undeclare-other-namespace
|
||||
(handler-case
|
||||
(xml:parse-string "<x:x xmlns:x='http://example.com'><x:y xmlns:x='' a='1'/></x:x>")
|
||||
(error () t)
|
||||
(:no-error (&rest junk)
|
||||
(declare (ignore junk))
|
||||
nil))
|
||||
t)
|
||||
|
||||
|
||||
;;; Require names otherwise totally out of scope of the xmlns rec to be NcNames for no reason
|
||||
|
||||
(deftest pi-names-are-ncnames-when-namespace-processing-1
|
||||
(handler-case
|
||||
(xml:parse-string "<?a:b c?><x/>")
|
||||
(error () t)
|
||||
(:no-error (&rest junk)
|
||||
(declare (ignore junk))
|
||||
nil))
|
||||
t)
|
||||
|
||||
(deftest pi-names-are-ncnames-when-namespace-processing-2
|
||||
(let ((sax:*namespace-processing* nil))
|
||||
(handler-case
|
||||
(xml:parse-string "<?a:b c?><x/>")
|
||||
(error () nil)
|
||||
(:no-error (&rest junk)
|
||||
(declare (ignore junk))
|
||||
t)))
|
||||
t)
|
||||
|
||||
(deftest entity-names-are-ncnames-when-namespace-processing-1
|
||||
(handler-case
|
||||
(xml:parse-string "<!DOCTYPE x [ <!ENTITY y:z 'foo'> ]><x>&y:z;</x>")
|
||||
(error () t)
|
||||
(:no-error (&rest junk)
|
||||
(declare (ignore junk))
|
||||
nil))
|
||||
t)
|
||||
|
||||
(deftest entity-names-are-ncnames-when-namespace-processing-2
|
||||
(handler-case
|
||||
(xml:parse-string "<!DOCTYPE x [ <!ENTITY y:z 'foo'> ]><x/>")
|
||||
(error () t)
|
||||
(:no-error (&rest junk)
|
||||
(declare (ignore junk))
|
||||
nil))
|
||||
t)
|
||||
|
||||
(deftest entity-names-are-ncnames-when-namespace-processing-3
|
||||
(let ((sax:*namespace-processing* nil))
|
||||
(handler-case
|
||||
(xml:parse-string "<!DOCTYPE x [ <!ENTITY y:z 'foo'> ]><x>&y:z;</x>")
|
||||
(error () nil)
|
||||
(:no-error (&rest junk)
|
||||
(declare (ignore junk))
|
||||
t)))
|
||||
t)
|
||||
|
||||
(deftest entity-names-are-ncnames-when-namespace-processing-4
|
||||
(let ((sax:*namespace-processing* nil))
|
||||
(handler-case
|
||||
(xml:parse-string "<!DOCTYPE x [ <!ENTITY y:z 'foo'> ]><x/>")
|
||||
(error () nil)
|
||||
(:no-error (&rest junk)
|
||||
(declare (ignore junk))
|
||||
t)))
|
||||
t)
|
||||
|
||||
;;; Inclusion of xmlns attributes
|
||||
|
||||
(deftest xmlns-attr-include-1
|
||||
(let* ((sax:*namespace-processing* t)
|
||||
(sax:*include-xmlns-attributes* t)
|
||||
(evt (first-start-element-event "<x xmlns='http://example.com'/>"))
|
||||
(attrs (fifth evt)))
|
||||
(length attrs))
|
||||
1)
|
||||
|
||||
(deftest xmlns-attr-discard-1
|
||||
(let* ((sax:*namespace-processing* t)
|
||||
(sax:*include-xmlns-attributes* nil)
|
||||
(evt (first-start-element-event "<x xmlns='http://example.com'/>"))
|
||||
(attrs (fifth evt)))
|
||||
(length attrs))
|
||||
0)
|
||||
|
||||
;;; Namespace of xmlns attributes
|
||||
|
||||
(deftest xmlns-attr-ns-uri-1
|
||||
(let* ((sax:*namespace-processing* t)
|
||||
(sax:*include-xmlns-attributes* t)
|
||||
(sax:*use-xmlns-namespace* nil)
|
||||
(evt (first-start-element-event "<x xmlns='http://example.com'/>"))
|
||||
(attrs (fifth evt)))
|
||||
(attribute-namespace-uri (car attrs)))
|
||||
nil)
|
||||
|
||||
(deftest xmlns-attr-ns-uri-2
|
||||
(let* ((sax:*namespace-processing* t)
|
||||
(sax:*include-xmlns-attributes* t)
|
||||
(sax:*use-xmlns-namespace* nil)
|
||||
(evt (first-start-element-event "<x xmlns:foo='http://example.com'/>"))
|
||||
(attrs (fifth evt)))
|
||||
(attribute-namespace-uri (car attrs)))
|
||||
nil)
|
||||
|
||||
(deftest xmlns-attr-ns-uri-3
|
||||
(let* ((sax:*namespace-processing* t)
|
||||
(sax:*include-xmlns-attributes* t)
|
||||
(sax:*use-xmlns-namespace* t)
|
||||
(evt (first-start-element-event "<x xmlns='http://example.com'/>"))
|
||||
(attrs (fifth evt)))
|
||||
(attribute-namespace-uri (car attrs)))
|
||||
nil)
|
||||
|
||||
(deftest xmlns-attr-ns-uri-4
|
||||
(let* ((sax:*namespace-processing* t)
|
||||
(sax:*include-xmlns-attributes* t)
|
||||
(sax:*use-xmlns-namespace* t)
|
||||
(evt (first-start-element-event "<x xmlns:foo='http://example.com'/>"))
|
||||
(attrs (fifth evt)))
|
||||
(rod= #"http://www.w3.org/2000/xmlns/" (attribute-namespace-uri (car attrs))))
|
||||
t)
|
||||
|
||||
(deftest xmlns-attr-ns-local-name-1
|
||||
(let* ((sax:*namespace-processing* t)
|
||||
(sax:*include-xmlns-attributes* t)
|
||||
(sax:*use-xmlns-namespace* nil)
|
||||
(evt (first-start-element-event "<x xmlns='http://example.com'/>"))
|
||||
(attrs (fifth evt)))
|
||||
(attribute-local-name (car attrs)))
|
||||
nil)
|
||||
|
||||
(deftest xmlns-attr-ns-local-name-2
|
||||
(let* ((sax:*namespace-processing* t)
|
||||
(sax:*include-xmlns-attributes* t)
|
||||
(sax:*use-xmlns-namespace* nil)
|
||||
(evt (first-start-element-event "<x xmlns:foo='http://example.com'/>"))
|
||||
(attrs (fifth evt)))
|
||||
(attribute-local-name (car attrs)))
|
||||
nil)
|
||||
|
||||
(deftest xmlns-attr-ns-local-name-3
|
||||
(let* ((sax:*namespace-processing* t)
|
||||
(sax:*include-xmlns-attributes* t)
|
||||
(sax:*use-xmlns-namespace* t)
|
||||
(evt (first-start-element-event "<x xmlns='http://example.com'/>"))
|
||||
(attrs (fifth evt)))
|
||||
(attribute-local-name (car attrs)))
|
||||
nil)
|
||||
|
||||
(deftest xmlns-attr-ns-local-name-4
|
||||
(let* ((sax:*namespace-processing* t)
|
||||
(sax:*include-xmlns-attributes* t)
|
||||
(sax:*use-xmlns-namespace* t)
|
||||
(evt (first-start-element-event "<x xmlns:foo='http://example.com'/>"))
|
||||
(attrs (fifth evt)))
|
||||
(rod= #"foo" (attribute-local-name (car attrs))))
|
||||
t)
|
||||
|
||||
(deftest xmlns-attr-qname-1
|
||||
(let* ((sax:*namespace-processing* t)
|
||||
(sax:*include-xmlns-attributes* t)
|
||||
(sax:*use-xmlns-namespace* nil)
|
||||
(evt (first-start-element-event "<x xmlns='http://example.com'/>"))
|
||||
(attrs (fifth evt)))
|
||||
(rod= #"xmlns" (attribute-qname (car attrs))))
|
||||
t)
|
||||
|
||||
(deftest xmlns-attr-qname-2
|
||||
(let* ((sax:*namespace-processing* t)
|
||||
(sax:*include-xmlns-attributes* t)
|
||||
(sax:*use-xmlns-namespace* nil)
|
||||
(evt (first-start-element-event "<x xmlns:foo='http://example.com'/>"))
|
||||
(attrs (fifth evt)))
|
||||
(rod= #"xmlns:foo" (attribute-qname (car attrs))))
|
||||
t)
|
||||
|
||||
(deftest xmlns-attr-qname-4
|
||||
(let* ((sax:*namespace-processing* t)
|
||||
(sax:*include-xmlns-attributes* t)
|
||||
(sax:*use-xmlns-namespace* t)
|
||||
(evt (first-start-element-event "<x xmlns='http://example.com'/>"))
|
||||
(attrs (fifth evt)))
|
||||
(rod= #"xmlns" (attribute-qname (car attrs))))
|
||||
t)
|
||||
|
||||
(deftest xmlns-attr-qname-4
|
||||
(let* ((sax:*namespace-processing* t)
|
||||
(sax:*include-xmlns-attributes* t)
|
||||
(sax:*use-xmlns-namespace* t)
|
||||
(evt (first-start-element-event "<x xmlns:foo='http://example.com'/>"))
|
||||
(attrs (fifth evt)))
|
||||
(rod= #"xmlns:foo" (attribute-qname (car attrs))))
|
||||
t)
|
||||
|
||||
|
||||
;;; Predefined Namespaces
|
||||
|
||||
(deftest redefine-xml-namespace-1
|
||||
(handler-case
|
||||
(xml:parse-string "<x xmlns:xml='http://www.w3.org/XML/1998/namespace'/>")
|
||||
(error () nil)
|
||||
(:no-error (&rest junk)
|
||||
(declare (ignore junk))
|
||||
t))
|
||||
t)
|
||||
|
||||
(deftest redefine-xml-namespace-2
|
||||
(handler-case
|
||||
(xml:parse-string "<x xmlns:xml='http://example.com/wrong-uri'/>")
|
||||
(error () t)
|
||||
(:no-error (&rest junk)
|
||||
(declare (ignore junk))
|
||||
nil))
|
||||
t)
|
||||
|
||||
(deftest redefine-xml-namespace-3
|
||||
(handler-case
|
||||
(xml:parse-string "<x xmlns:wrong='http://www.w3.org/XML/1998/namespace'/>")
|
||||
(error () t)
|
||||
(:no-error (&rest junk)
|
||||
(declare (ignore junk))
|
||||
nil))
|
||||
t)
|
||||
|
||||
(deftest redefine-xml-namespace-4
|
||||
(handler-case
|
||||
(xml:parse-string "<x xmlns:wrong='http://www.w3.org/XML/1998/namespace'/>")
|
||||
(error () t)
|
||||
(:no-error (&rest junk)
|
||||
(declare (ignore junk))
|
||||
nil))
|
||||
t)
|
||||
|
||||
(deftest redefine-xmlns-namespace-1
|
||||
(handler-case
|
||||
(xml:parse-string "<x xmlns:xmlns='http://www.w3.org/2000/xmlns/'/>")
|
||||
(error () t)
|
||||
(:no-error (&rest junk)
|
||||
(declare (ignore junk))
|
||||
nil))
|
||||
t)
|
||||
|
||||
(deftest redefine-xmlns-namespace-2
|
||||
(handler-case
|
||||
(xml:parse-string "<x xmlns:xmlns='http://example.com/wrong-ns'/>")
|
||||
(error () t)
|
||||
(:no-error (&rest junk)
|
||||
(declare (ignore junk))
|
||||
nil))
|
||||
t)
|
||||
|
||||
(deftest redefine-xmlns-namespace-3
|
||||
(handler-case
|
||||
(xml:parse-string "<x xmlns:wrong='http://www.w3.org/2000/xmlns/'/>")
|
||||
(error () t)
|
||||
(:no-error (&rest junk)
|
||||
(declare (ignore junk))
|
||||
nil))
|
||||
t)
|
||||
|
||||
(deftest redefine-xmlns-namespace-4
|
||||
(handler-case
|
||||
(xml:parse-string "<x xmlns='http://www.w3.org/2000/xmlns/'/>")
|
||||
(error () t)
|
||||
(:no-error (&rest junk)
|
||||
(declare (ignore junk))
|
||||
nil))
|
||||
t)
|
||||
|
||||
|
||||
44
xml/split-sequence.lisp
Normal file
44
xml/split-sequence.lisp
Normal file
@ -0,0 +1,44 @@
|
||||
;;; This code was based on Arthur Lemmens' in
|
||||
;;; <URL:http://groups.google.com/groups?as_umsgid=39F36F1A.B8F19D20%40simplex.nl>;
|
||||
|
||||
(in-package :cxml)
|
||||
|
||||
(defun split-sequence-if (predicate seq &key (count nil) (remove-empty-subseqs nil) (from-end nil) (start 0) (end nil) (key nil key-supplied))
|
||||
(let ((len (length seq))
|
||||
(other-keys (when key-supplied
|
||||
(list :key key))))
|
||||
(unless end (setq end len))
|
||||
(if from-end
|
||||
(loop for right = end then left
|
||||
for left = (max (or (apply #'position-if predicate seq
|
||||
:end right
|
||||
:from-end t
|
||||
other-keys)
|
||||
-1)
|
||||
(1- start))
|
||||
unless (and (= right (1+ left))
|
||||
remove-empty-subseqs) ; empty subseq we don't want
|
||||
if (and count (>= nr-elts count))
|
||||
;; We can't take any more. Return now.
|
||||
return (values (nreverse subseqs) right)
|
||||
else
|
||||
collect (subseq seq (1+ left) right) into subseqs
|
||||
and sum 1 into nr-elts
|
||||
until (< left start)
|
||||
finally (return (values (nreverse subseqs) (1+ left))))
|
||||
(loop for left = start then (+ right 1)
|
||||
for right = (min (or (apply #'position-if predicate seq
|
||||
:start left
|
||||
other-keys)
|
||||
len)
|
||||
end)
|
||||
unless (and (= right left)
|
||||
remove-empty-subseqs) ; empty subseq we don't want
|
||||
if (and count (>= nr-elts count))
|
||||
;; We can't take any more. Return now.
|
||||
return (values subseqs left)
|
||||
else
|
||||
collect (subseq seq left right) into subseqs
|
||||
and sum 1 into nr-elts
|
||||
until (>= right end)
|
||||
finally (return (values subseqs right))))))
|
||||
35
xml/string-dom.lisp
Normal file
35
xml/string-dom.lisp
Normal file
@ -0,0 +1,35 @@
|
||||
(defpackage :string-dom
|
||||
(:use))
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(do-external-symbols (var :cdom)
|
||||
(let* ((home-package
|
||||
(if (member var '(cdom:data cdom:name cdom:value cdom:tag-name
|
||||
cdom:node-name cdom:node-value
|
||||
cdom:substring-data cdom:get-attribute))
|
||||
:string-dom
|
||||
:cdom))
|
||||
(symbol (intern (symbol-name var) home-package)))
|
||||
(import symbol :string-dom)
|
||||
(export (list symbol) :string-dom))))
|
||||
|
||||
(defpackage :string-dom-impl (:use :cl))
|
||||
(in-package :string-dom-impl)
|
||||
|
||||
(defun rod-to-string (frob)
|
||||
(if (null frob)
|
||||
nil
|
||||
(map 'string #'code-char frob)))
|
||||
|
||||
(defun string-dom:data (node) (rod-to-string (cdom:data node)))
|
||||
(defun string-dom:name (node) (rod-to-string (cdom:name node)))
|
||||
(defun string-dom:value (node) (rod-to-string (cdom:value node)))
|
||||
(defun string-dom:tag-name (node) (rod-to-string (cdom:tag-name node)))
|
||||
(defun string-dom:node-name (node) (rod-to-string (cdom:node-name node)))
|
||||
(defun string-dom:node-value (node) (rod-to-string (cdom:node-value node)))
|
||||
|
||||
(defun string-dom:substring-data (node offset count)
|
||||
(rod-to-string (cdom:substring-data node offset count)))
|
||||
|
||||
(defun string-dom:get-attribute (elt name)
|
||||
(rod-to-string (cdom:get-attribute elt name)))
|
||||
438
xml/unparse.lisp
Normal file
438
xml/unparse.lisp
Normal file
@ -0,0 +1,438 @@
|
||||
;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CXML; readtable: runes; Encoding: utf-8; -*-
|
||||
;;; ---------------------------------------------------------------------------
|
||||
;;; Title: Unparse XML
|
||||
;;; Title: (including support for canonic XML according to J.Clark)
|
||||
;;; Created: 1999-09-09
|
||||
;;; Author: Gilbert Baumann <unk6@rz.uni-karlsruhe.de>
|
||||
;;; Author: David Lichteblau <david@lichteblau.com>
|
||||
;;; License: LGPL (See file COPYING for details).
|
||||
;;; ---------------------------------------------------------------------------
|
||||
;;; © copyright 1999 by Gilbert Baumann
|
||||
|
||||
;;; This library is free software; you can redistribute it and/or
|
||||
;;; modify it under the terms of the GNU Library General Public
|
||||
;;; License as published by the Free Software Foundation; either
|
||||
;;; version 2 of the License, or (at your option) any later version.
|
||||
;;;
|
||||
;;; 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
|
||||
;;; Library General Public License for more details.
|
||||
;;;
|
||||
;;; You should have received a copy of the GNU Library General Public
|
||||
;;; License along with this library; if not, write to the
|
||||
;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
||||
;;; Boston, MA 02111-1307 USA.
|
||||
|
||||
(in-package :cxml)
|
||||
|
||||
;;
|
||||
;; | Canonical XML
|
||||
;; | =============
|
||||
;; |
|
||||
;; | This document defines a subset of XML called canonical XML. The
|
||||
;; | intended use of canonical XML is in testing XML processors, as a
|
||||
;; | representation of the result of parsing an XML document.
|
||||
;; |
|
||||
;; | Every well-formed XML document has a unique structurally equivalent
|
||||
;; | canonical XML document. Two structurally equivalent XML documents have
|
||||
;; | a byte-for-byte identical canonical XML document. Canonicalizing an
|
||||
;; | XML document requires only information that an XML processor is
|
||||
;; | required to make available to an application.
|
||||
;; |
|
||||
;; | A canonical XML document conforms to the following grammar:
|
||||
;; |
|
||||
;; | CanonXML ::= Pi* element Pi*
|
||||
;; | element ::= Stag (Datachar | Pi | element)* Etag
|
||||
;; | Stag ::= '<' Name Atts '>'
|
||||
;; | Etag ::= '</' Name '>'
|
||||
;; | Pi ::= '<?' Name ' ' (((Char - S) Char*)? - (Char* '?>' Char*)) '?>'
|
||||
;; | Atts ::= (' ' Name '=' '"' Datachar* '"')*
|
||||
;; | Datachar ::= '&' | '<' | '>' | '"'
|
||||
;; | | '	'| ' '| ' '
|
||||
;; | | (Char - ('&' | '<' | '>' | '"' | #x9 | #xA | #xD))
|
||||
;; | Name ::= (see XML spec)
|
||||
;; | Char ::= (see XML spec)
|
||||
;; | S ::= (see XML spec)
|
||||
;; |
|
||||
;; | Attributes are in lexicographical order (in Unicode bit order).
|
||||
;; |
|
||||
;; | A canonical XML document is encoded in UTF-8.
|
||||
;; |
|
||||
;; | Ignorable white space is considered significant and is treated
|
||||
;; | equivalently to data.
|
||||
;;
|
||||
;; -- James Clark (jjc@jclark.com)
|
||||
|
||||
|
||||
;;;; SINK: a rune output "stream"
|
||||
|
||||
(defclass sink ()
|
||||
((high-surrogate :initform nil)
|
||||
(column :initform 0 :accessor column)
|
||||
(width :initform 79 :initarg :width :accessor width)
|
||||
(canonical :initform t :initarg :canonical :accessor canonical)
|
||||
(indentation :initform nil :initarg :indentation :accessor indentation)
|
||||
(current-indentation :initform 0 :accessor current-indentation)
|
||||
(notations :initform (make-buffer :element-type t) :accessor notations)
|
||||
(name-for-dtd :accessor name-for-dtd)
|
||||
(previous-notation :initform nil :accessor previous-notation)
|
||||
(stack :initform nil :accessor stack)))
|
||||
|
||||
(defmethod initialize-instance :after ((instance sink) &key)
|
||||
(when (eq (canonical instance) t)
|
||||
(setf (canonical instance) 1))
|
||||
(unless (member (canonical instance) '(nil 1 2))
|
||||
(error "Invalid canonical form: ~A" (canonical instance)))
|
||||
(when (and (canonical instance) (indentation instance))
|
||||
(error "Cannot indent XML in canonical mode")))
|
||||
|
||||
;; WRITE-OCTET als generisch zu machen ist vielleicht nicht die schnellste
|
||||
;; Loesung, aber die einfachste.
|
||||
(defgeneric write-octet (octet sink))
|
||||
|
||||
(defun make-buffer (&key (element-type '(unsigned-byte 8)))
|
||||
(make-array 1
|
||||
:element-type element-type
|
||||
:adjustable t
|
||||
:fill-pointer 0))
|
||||
|
||||
(defmethod write-octet :after (octet sink)
|
||||
(with-slots (column) sink
|
||||
(setf column (if (eql octet 10) 0 (1+ column)))))
|
||||
|
||||
|
||||
;; vector (octet) sinks
|
||||
|
||||
(defclass vector-sink (sink)
|
||||
((target-vector :initform (make-buffer))))
|
||||
|
||||
(defun make-octet-vector-sink (&rest initargs)
|
||||
(apply #'make-instance 'vector-sink initargs))
|
||||
|
||||
(defmethod write-octet (octet (sink vector-sink))
|
||||
(let ((target-vector (slot-value sink 'target-vector)))
|
||||
(vector-push-extend octet target-vector (length target-vector))))
|
||||
|
||||
(defmethod sax:end-document ((sink vector-sink))
|
||||
(slot-value sink 'target-vector))
|
||||
|
||||
|
||||
;; character stream sinks
|
||||
|
||||
(defclass character-stream-sink (sink)
|
||||
((target-stream :initarg :target-stream)))
|
||||
|
||||
(defun make-character-stream-sink (character-stream &rest initargs)
|
||||
(apply #'make-instance 'character-stream-sink
|
||||
:target-stream character-stream
|
||||
initargs))
|
||||
|
||||
(defmethod write-octet (octet (sink character-stream-sink))
|
||||
(write-char (code-char octet) (slot-value sink 'target-stream)))
|
||||
|
||||
(defmethod sax:end-document ((sink character-stream-sink))
|
||||
(slot-value sink 'target-stream))
|
||||
|
||||
|
||||
;; octet stream sinks
|
||||
|
||||
(defclass octet-stream-sink (sink)
|
||||
((target-stream :initarg :target-stream)))
|
||||
|
||||
(defun make-octet-stream-sink (octet-stream &rest initargs)
|
||||
(apply #'make-instance 'octet-stream-sink
|
||||
:target-stream octet-stream
|
||||
initargs))
|
||||
|
||||
(defmethod write-octet (octet (sink octet-stream-sink))
|
||||
(write-byte octet (slot-value sink 'target-stream)))
|
||||
|
||||
(defmethod sax:end-document ((sink octet-stream-sink))
|
||||
(slot-value sink 'target-stream))
|
||||
|
||||
|
||||
;;;; doctype and notations
|
||||
|
||||
(defmethod sax:start-dtd ((sink sink) name public-id system-id)
|
||||
(declare (ignore public-id system-id))
|
||||
(setf (name-for-dtd sink) name))
|
||||
|
||||
(defmethod sax:notation-declaration ((sink sink) name public-id system-id)
|
||||
(when (and (canonical sink) (>= (canonical sink) 2))
|
||||
(let ((prev (previous-notation sink)))
|
||||
(cond
|
||||
(prev
|
||||
(unless (rod< prev name)
|
||||
(error "misordered notations; cannot unparse canonically")))
|
||||
(t
|
||||
;; need a doctype declaration
|
||||
(write-rod #"<!DOCTYPE " sink)
|
||||
(write-rod (name-for-dtd sink) sink)
|
||||
(write-rod #" [" sink)
|
||||
(write-rune #/U+000A sink)))
|
||||
(setf (previous-notation sink) name))
|
||||
(write-rod #"<!NOTATION " sink)
|
||||
(write-rod name sink)
|
||||
(cond
|
||||
((zerop (length public-id))
|
||||
(write-rod #" SYSTEM '" sink)
|
||||
(write-rod system-id sink)
|
||||
(write-rune #/' sink))
|
||||
((zerop (length system-id))
|
||||
(write-rod #" PUBLIC '" sink)
|
||||
(write-rod public-id sink)
|
||||
(write-rune #/' sink))
|
||||
(t
|
||||
(write-rod #" PUBLIC '" sink)
|
||||
(write-rod public-id sink)
|
||||
(write-rod #"' '" sink)
|
||||
(write-rod system-id sink)
|
||||
(write-rune #/' sink)))
|
||||
(write-rune #/> sink)
|
||||
(write-rune #/U+000A sink)))
|
||||
|
||||
(defmethod sax:end-dtd ((sink sink))
|
||||
(when (previous-notation sink)
|
||||
(write-rod #"]>" sink)
|
||||
(write-rune #/U+000A sink)))
|
||||
|
||||
|
||||
;;;; elements
|
||||
|
||||
(defun sink-fresh-line (sink)
|
||||
(unless (zerop (column sink))
|
||||
(write-rune-0 10 sink)
|
||||
(indent sink)))
|
||||
|
||||
(defmethod sax:start-element
|
||||
((sink sink) namespace-uri local-name qname attributes)
|
||||
(declare (ignore namespace-uri local-name))
|
||||
(when (stack sink)
|
||||
(incf (cdr (first (stack sink)))))
|
||||
(push (cons qname 0) (stack sink))
|
||||
(when (indentation sink)
|
||||
(sink-fresh-line sink)
|
||||
(start-indentation-block sink))
|
||||
(write-rune #/< sink)
|
||||
(write-rod qname sink)
|
||||
(let ((atts (sort (copy-list attributes) #'rod< :key #'sax:attribute-qname)))
|
||||
(dolist (a atts)
|
||||
(write-rune #/space sink)
|
||||
(write-rod (sax:attribute-qname a) sink)
|
||||
(write-rune #/= sink)
|
||||
(write-rune #/\" sink)
|
||||
(map nil (lambda (c) (unparse-datachar c sink)) (sax:attribute-value a))
|
||||
(write-rune #/\" sink)))
|
||||
(write-rod '#.(string-rod ">") sink))
|
||||
|
||||
(defmethod sax:end-element
|
||||
((sink sink) namespace-uri local-name qname)
|
||||
(declare (ignore namespace-uri local-name))
|
||||
(let ((cons (pop (stack sink))))
|
||||
(unless (consp cons)
|
||||
(error "output does not nest: not in an element"))
|
||||
(unless (rod= (car cons) qname)
|
||||
(error "output does not nest: expected ~A but got ~A"
|
||||
(rod qname) (rod (car cons))))
|
||||
(when (indentation sink)
|
||||
(end-indentation-block sink)
|
||||
(unless (zerop (cdr cons))
|
||||
(sink-fresh-line sink))))
|
||||
(write-rod '#.(string-rod "</") sink)
|
||||
(write-rod qname sink)
|
||||
(write-rod '#.(string-rod ">") sink))
|
||||
|
||||
(defmethod sax:processing-instruction ((sink sink) target data)
|
||||
(unless (rod-equal target '#.(string-rod "xml"))
|
||||
(write-rod '#.(string-rod "<?") sink)
|
||||
(write-rod target sink)
|
||||
(write-rune #/space sink)
|
||||
(write-rod data sink)
|
||||
(write-rod '#.(string-rod "?>") sink)))
|
||||
|
||||
(defmethod sax:start-cdata ((sink sink))
|
||||
(push :cdata (stack sink)))
|
||||
|
||||
(defmethod sax:characters ((sink sink) data)
|
||||
(cond
|
||||
((and (eq (car (stack sink)) :cdata)
|
||||
(not (canonical sink))
|
||||
(not (search #"]]" data)))
|
||||
(when (indentation sink)
|
||||
(sink-fresh-line sink))
|
||||
(write-rod #"<![CDATA[" sink)
|
||||
;; XXX signal error if body is unprintable?
|
||||
(map nil (lambda (c) (write-rune c sink)) data)
|
||||
(write-rod #"]]>" sink))
|
||||
(t
|
||||
(if (indentation sink)
|
||||
(unparse-indented-text data sink)
|
||||
(map nil (if (canonical sink)
|
||||
(lambda (c) (unparse-datachar c sink))
|
||||
(lambda (c) (unparse-datachar-readable c sink)))
|
||||
data)))))
|
||||
|
||||
(defmethod sax:end-cdata ((sink sink))
|
||||
(unless (eq (pop (stack sink)) :cdata)
|
||||
(error "output does not nest: not in a cdata section")))
|
||||
|
||||
(defun indent (sink)
|
||||
(dotimes (x (current-indentation sink))
|
||||
(write-rune-0 32 sink)))
|
||||
|
||||
(defun start-indentation-block (sink)
|
||||
(incf (current-indentation sink) (indentation sink)))
|
||||
|
||||
(defun end-indentation-block (sink)
|
||||
(decf (current-indentation sink) (indentation sink)))
|
||||
|
||||
(defun unparse-indented-text (data sink)
|
||||
(flet ((whitespacep (x)
|
||||
(or (rune= x #/U+000A) (rune= x #/U+0020))))
|
||||
(let* ((n (length data))
|
||||
(pos (position-if-not #'whitespacep data))
|
||||
(need-whitespace-p nil))
|
||||
(cond
|
||||
((zerop n))
|
||||
(pos
|
||||
(sink-fresh-line sink)
|
||||
(while (< pos n)
|
||||
(let* ((w (or (position-if #'whitespacep data :start (1+ pos)) n))
|
||||
(next (or (position-if-not #'whitespacep data :start w) n)))
|
||||
(when need-whitespace-p
|
||||
(if (< (+ (column sink) w (- pos)) (width sink))
|
||||
(write-rune-0 32 sink)
|
||||
(sink-fresh-line sink)))
|
||||
(loop
|
||||
for i from pos below w do
|
||||
(unparse-datachar-readable (elt data i) sink))
|
||||
(setf need-whitespace-p (< w n))
|
||||
(setf pos next))))
|
||||
(t
|
||||
(write-rune-0 32 sink))))))
|
||||
|
||||
(defun unparse-datachar (c sink)
|
||||
(cond ((rune= c #/&) (write-rod '#.(string-rod "&") sink))
|
||||
((rune= c #/<) (write-rod '#.(string-rod "<") sink))
|
||||
((rune= c #/>) (write-rod '#.(string-rod ">") sink))
|
||||
((rune= c #/\") (write-rod '#.(string-rod """) sink))
|
||||
((rune= c #/U+0009) (write-rod '#.(string-rod "	") sink))
|
||||
((rune= c #/U+000A) (write-rod '#.(string-rod " ") sink))
|
||||
((rune= c #/U+000D) (write-rod '#.(string-rod " ") sink))
|
||||
(t
|
||||
(write-rune c sink))))
|
||||
|
||||
(defun unparse-datachar-readable (c sink)
|
||||
(cond ((rune= c #/&) (write-rod '#.(string-rod "&") sink))
|
||||
((rune= c #/<) (write-rod '#.(string-rod "<") sink))
|
||||
((rune= c #/>) (write-rod '#.(string-rod ">") sink))
|
||||
((rune= c #/\") (write-rod '#.(string-rod """) sink))
|
||||
(t
|
||||
(write-rune c sink))))
|
||||
|
||||
|
||||
;;;; UTF-8 output for SINKs
|
||||
|
||||
(defun write-rod (rod sink)
|
||||
(map nil (lambda (c) (write-rune c sink)) rod))
|
||||
|
||||
(defun write-rune (rune sink)
|
||||
(let ((code (rune-code rune)))
|
||||
(with-slots (high-surrogate) sink
|
||||
(cond
|
||||
((<= #xD800 code #xDBFF)
|
||||
(setf high-surrogate code))
|
||||
((<= #xDC00 code #xDFFF)
|
||||
(let ((q (logior (ash (- high-surrogate #xD7C0) 10)
|
||||
(- code #xDC00))))
|
||||
(write-rune-0 q sink))
|
||||
(setf high-surrogate nil))
|
||||
(t
|
||||
(write-rune-0 code sink))))))
|
||||
|
||||
(defun write-rune-0 (code sink)
|
||||
(labels ((wr (x)
|
||||
(write-octet x sink)))
|
||||
(cond ((<= #x00000000 code #x0000007F)
|
||||
(wr code))
|
||||
((<= #x00000080 code #x000007FF)
|
||||
(wr (logior #b11000000 (ldb (byte 5 6) code)))
|
||||
(wr (logior #b10000000 (ldb (byte 6 0) code))))
|
||||
((<= #x00000800 code #x0000FFFF)
|
||||
(wr (logior #b11100000 (ldb (byte 4 12) code)))
|
||||
(wr (logior #b10000000 (ldb (byte 6 6) code)))
|
||||
(wr (logior #b10000000 (ldb (byte 6 0) code))))
|
||||
((<= #x00010000 code #x001FFFFF)
|
||||
(wr (logior #b11110000 (ldb (byte 3 18) code)))
|
||||
(wr (logior #b10000000 (ldb (byte 6 12) code)))
|
||||
(wr (logior #b10000000 (ldb (byte 6 6) code)))
|
||||
(wr (logior #b10000000 (ldb (byte 6 0) code))))
|
||||
((<= #x00200000 code #x03FFFFFF)
|
||||
(wr (logior #b11111000 (ldb (byte 2 24) code)))
|
||||
(wr (logior #b10000000 (ldb (byte 6 18) code)))
|
||||
(wr (logior #b10000000 (ldb (byte 6 12) code)))
|
||||
(wr (logior #b10000000 (ldb (byte 6 6) code)))
|
||||
(wr (logior #b10000000 (ldb (byte 6 0) code))))
|
||||
((<= #x04000000 code #x7FFFFFFF)
|
||||
(wr (logior #b11111100 (ldb (byte 1 30) code)))
|
||||
(wr (logior #b10000000 (ldb (byte 6 24) code)))
|
||||
(wr (logior #b10000000 (ldb (byte 6 18) code)))
|
||||
(wr (logior #b10000000 (ldb (byte 6 12) code)))
|
||||
(wr (logior #b10000000 (ldb (byte 6 6) code)))
|
||||
(wr (logior #b10000000 (ldb (byte 6 0) code)))))))
|
||||
|
||||
|
||||
;;;; convenience functions for DOMless XML serialization
|
||||
|
||||
(defvar *current-element*)
|
||||
(defvar *sink*)
|
||||
|
||||
(defmacro with-xml-output (sink &body body)
|
||||
`(invoke-with-xml-output (lambda () ,@body) ,sink))
|
||||
|
||||
(defun invoke-with-xml-output (fn sink)
|
||||
(let ((*sink* sink)
|
||||
(*current-element* nil))
|
||||
(sax:start-document *sink*)
|
||||
(funcall fn)
|
||||
(sax:end-document *sink*)))
|
||||
|
||||
(defmacro with-element (qname &body body)
|
||||
;; XXX Statt qname soll man in zukunft auch mal (lname uri) angeben koennen.
|
||||
;; Hat aber Zeit bis DOM 2.
|
||||
(when (listp qname)
|
||||
(destructuring-bind (n) qname
|
||||
(setf qname n)))
|
||||
`(invoke-with-element (lambda () ,@body) ,qname))
|
||||
|
||||
(defun maybe-emit-start-tag ()
|
||||
(when *current-element*
|
||||
;; starting child node, need to emit opening tag of parent first:
|
||||
(destructuring-bind (qname &rest attributes) *current-element*
|
||||
(sax:start-element *sink* nil nil qname (reverse attributes)))
|
||||
(setf *current-element* nil)))
|
||||
|
||||
(defun invoke-with-element (fn qname)
|
||||
(maybe-emit-start-tag)
|
||||
(let ((*current-element* (list qname)))
|
||||
(multiple-value-prog1
|
||||
(funcall fn)
|
||||
(maybe-emit-start-tag)
|
||||
(sax:end-element *sink* nil nil qname))))
|
||||
|
||||
(defun attribute (name value)
|
||||
(push (sax:make-attribute :qname name :value value)
|
||||
(cdr *current-element*))
|
||||
value)
|
||||
|
||||
(defun cdata (data)
|
||||
(sax:start-cdata *sink*)
|
||||
(sax:characters *sink* data)
|
||||
(sax:end-cdata *sink*)
|
||||
data)
|
||||
|
||||
(defun text (data)
|
||||
(maybe-emit-start-tag)
|
||||
(sax:characters *sink* data)
|
||||
data)
|
||||
172
xml/xml-canonic.lisp
Normal file
172
xml/xml-canonic.lisp
Normal file
@ -0,0 +1,172 @@
|
||||
;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: XML; readtable: glisp; Encoding: utf-8; -*-
|
||||
;;; ---------------------------------------------------------------------------
|
||||
;;; Title: Dump canonic XML according to J.Clark
|
||||
;;; Created: 1999-09-09
|
||||
;;; Author: Gilbert Baumann <unk6@rz.uni-karlsruhe.de>
|
||||
;;; License: LGPL (See file COPYING for details).
|
||||
;;; ---------------------------------------------------------------------------
|
||||
;;; © copyright 1999 by Gilbert Baumann
|
||||
|
||||
;;; This library is free software; you can redistribute it and/or
|
||||
;;; modify it under the terms of the GNU Library General Public
|
||||
;;; License as published by the Free Software Foundation; either
|
||||
;;; version 2 of the License, or (at your option) any later version.
|
||||
;;;
|
||||
;;; 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
|
||||
;;; Library General Public License for more details.
|
||||
;;;
|
||||
;;; You should have received a copy of the GNU Library General Public
|
||||
;;; License along with this library; if not, write to the
|
||||
;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
||||
;;; Boston, MA 02111-1307 USA.
|
||||
|
||||
(in-package :xml)
|
||||
|
||||
;;
|
||||
;; | Canonical XML
|
||||
;; | =============
|
||||
;; |
|
||||
;; | This document defines a subset of XML called canonical XML. The
|
||||
;; | intended use of canonical XML is in testing XML processors, as a
|
||||
;; | representation of the result of parsing an XML document.
|
||||
;; |
|
||||
;; | Every well-formed XML document has a unique structurally equivalent
|
||||
;; | canonical XML document. Two structurally equivalent XML documents have
|
||||
;; | a byte-for-byte identical canonical XML document. Canonicalizing an
|
||||
;; | XML document requires only information that an XML processor is
|
||||
;; | required to make available to an application.
|
||||
;; |
|
||||
;; | A canonical XML document conforms to the following grammar:
|
||||
;; |
|
||||
;; | CanonXML ::= Pi* element Pi*
|
||||
;; | element ::= Stag (Datachar | Pi | element)* Etag
|
||||
;; | Stag ::= '<' Name Atts '>'
|
||||
;; | Etag ::= '</' Name '>'
|
||||
;; | Pi ::= '<?' Name ' ' (((Char - S) Char*)? - (Char* '?>' Char*)) '?>'
|
||||
;; | Atts ::= (' ' Name '=' '"' Datachar* '"')*
|
||||
;; | Datachar ::= '&' | '<' | '>' | '"'
|
||||
;; | | '	'| ' '| ' '
|
||||
;; | | (Char - ('&' | '<' | '>' | '"' | #x9 | #xA | #xD))
|
||||
;; | Name ::= (see XML spec)
|
||||
;; | Char ::= (see XML spec)
|
||||
;; | S ::= (see XML spec)
|
||||
;; |
|
||||
;; | Attributes are in lexicographical order (in Unicode bit order).
|
||||
;; |
|
||||
;; | A canonical XML document is encoded in UTF-8.
|
||||
;; |
|
||||
;; | Ignorable white space is considered significant and is treated
|
||||
;; | equivalently to data.
|
||||
;;
|
||||
;; -- James Clark (jjc@jclark.com)
|
||||
|
||||
(defvar *quux*) ;!!!BIG HACK!!!
|
||||
|
||||
(defun unparse-document (doc sink)
|
||||
(mapc (rcurry #'unparse-node sink) (dom:child-nodes doc)))
|
||||
|
||||
(defun unparse-node (node sink)
|
||||
(cond ((dom:element-p node)
|
||||
(write-rune #/< sink)
|
||||
(write-rod (dom:tag-name node) sink)
|
||||
;; atts
|
||||
(let ((atts (sort (copy-list (dom:items (dom:attributes node)))
|
||||
#'rod< :key #'dom:name)))
|
||||
(dolist (a atts)
|
||||
(write-rune #/space sink)
|
||||
(write-rod (dom:name a) sink)
|
||||
(write-rune #/= sink)
|
||||
(write-rune #/\" sink)
|
||||
(let ((*quux* nil))
|
||||
(map nil (lambda (c) (unparse-datachar c sink)) (dom:value a)))
|
||||
(write-rune #/\" sink)))
|
||||
(write-rod '#.(string-rod ">") sink)
|
||||
(dolist (k (dom:child-nodes node))
|
||||
(unparse-node k sink))
|
||||
(write-rod '#.(string-rod "</") sink)
|
||||
(write-rod (dom:tag-name node) sink)
|
||||
(write-rod '#.(string-rod ">") sink))
|
||||
((dom:processing-instruction-p node)
|
||||
(unless (rod-equal (dom:target node) '#.(string-rod "xml"))
|
||||
(write-rod '#.(string-rod "<?") sink)
|
||||
(write-rod (dom:target node) sink)
|
||||
(write-rune #/space sink)
|
||||
(write-rod (dom:data node) sink)
|
||||
(write-rod '#.(string-rod "?>") sink) ))
|
||||
((dom:text-node-p node)
|
||||
(let ((*quux* nil))
|
||||
(map nil (lambda (c) (unparse-datachar c sink))
|
||||
(dom:data node))))
|
||||
(t
|
||||
(error "Oops in unparse: ~S." node))))
|
||||
|
||||
(defun unparse-datachar (c sink)
|
||||
(cond ((rune= c #/&) (write-rod '#.(string-rod "&") sink))
|
||||
((rune= c #/<) (write-rod '#.(string-rod "<") sink))
|
||||
((rune= c #/>) (write-rod '#.(string-rod ">") sink))
|
||||
((rune= c #/\") (write-rod '#.(string-rod """) sink))
|
||||
((rune= c #/U+0009) (write-rod '#.(string-rod "	") sink))
|
||||
((rune= c #/U+000A) (write-rod '#.(string-rod " ") sink))
|
||||
((rune= c #/U+000D) (write-rod '#.(string-rod " ") sink))
|
||||
(t
|
||||
(write-rune c sink))))
|
||||
|
||||
(defun write-rod (rod sink)
|
||||
(let ((*quux* nil))
|
||||
(map nil (lambda (c) (write-rune c sink)) rod)))
|
||||
|
||||
(defun write-rune (rune sink)
|
||||
(cond ((<= #xD800 rune #xDBFF)
|
||||
(setf *quux* rune))
|
||||
((<= #xDC00 rune #xDFFF)
|
||||
(let ((q (logior (ash (- *quux* #xD7C0) 10) (- rune #xDC00))))
|
||||
(write-rune-0 q sink))
|
||||
(setf *quux* nil))
|
||||
(t
|
||||
(write-rune-0 rune sink))))
|
||||
|
||||
(defun write-rune-0 (rune sink)
|
||||
(labels ((wr (x)
|
||||
(write-char (code-char x) sink)))
|
||||
(cond ((<= #x00000000 rune #x0000007F)
|
||||
(wr rune))
|
||||
((<= #x00000080 rune #x000007FF)
|
||||
(wr (logior #b11000000 (ldb (byte 5 6) rune)))
|
||||
(wr (logior #b10000000 (ldb (byte 6 0) rune))))
|
||||
((<= #x00000800 rune #x0000FFFF)
|
||||
(wr (logior #b11100000 (ldb (byte 4 12) rune)))
|
||||
(wr (logior #b10000000 (ldb (byte 6 6) rune)))
|
||||
(wr (logior #b10000000 (ldb (byte 6 0) rune))))
|
||||
((<= #x00010000 rune #x001FFFFF)
|
||||
(wr (logior #b11110000 (ldb (byte 3 18) rune)))
|
||||
(wr (logior #b10000000 (ldb (byte 6 12) rune)))
|
||||
(wr (logior #b10000000 (ldb (byte 6 6) rune)))
|
||||
(wr (logior #b10000000 (ldb (byte 6 0) rune))))
|
||||
((<= #x00200000 rune #x03FFFFFF)
|
||||
(wr (logior #b11111000 (ldb (byte 2 24) rune)))
|
||||
(wr (logior #b10000000 (ldb (byte 6 18) rune)))
|
||||
(wr (logior #b10000000 (ldb (byte 6 12) rune)))
|
||||
(wr (logior #b10000000 (ldb (byte 6 6) rune)))
|
||||
(wr (logior #b10000000 (ldb (byte 6 0) rune))))
|
||||
((<= #x04000000 rune #x7FFFFFFF)
|
||||
(wr (logior #b11111100 (ldb (byte 1 30) rune)))
|
||||
(wr (logior #b10000000 (ldb (byte 6 24) rune)))
|
||||
(wr (logior #b10000000 (ldb (byte 6 18) rune)))
|
||||
(wr (logior #b10000000 (ldb (byte 6 12) rune)))
|
||||
(wr (logior #b10000000 (ldb (byte 6 6) rune)))
|
||||
(wr (logior #b10000000 (ldb (byte 6 0) rune)))))))
|
||||
|
||||
(defun rod< (rod1 rod2)
|
||||
(do ((i 0 (+ i 1)))
|
||||
(nil)
|
||||
(cond ((= i (length rod1))
|
||||
(return t))
|
||||
((= i (length rod2))
|
||||
(return nil))
|
||||
((< (aref rod1 i) (aref rod2 i))
|
||||
(return t))
|
||||
((> (aref rod1 i) (aref rod2 i))
|
||||
(return nil)))))
|
||||
|
||||
218
xml/xml-name-rune-p.lisp
Normal file
218
xml/xml-name-rune-p.lisp
Normal file
@ -0,0 +1,218 @@
|
||||
;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: XML; readtable: glisp; Encoding: utf-8; -*-
|
||||
|
||||
(in-package :xml)
|
||||
|
||||
#.(funcall
|
||||
(compile
|
||||
nil
|
||||
'(lambda ()
|
||||
(let ((*max* #xD800))
|
||||
(labels
|
||||
((name-start-rune-p (rune)
|
||||
(or (letter-rune-p rune)
|
||||
(= #.(char-code #\_) rune)
|
||||
(= #.(char-code #\:) rune)))
|
||||
|
||||
(name-rune-p (rune)
|
||||
(or (letter-rune-p rune)
|
||||
(digit-rune-p* rune)
|
||||
(= rune #.(char-code #\.))
|
||||
(= rune #.(char-code #\-))
|
||||
(= rune #.(char-code #\_))
|
||||
(= rune #.(char-code #\:))
|
||||
(combining-rune-p rune)
|
||||
(extender-rune-p rune)))
|
||||
|
||||
(letter-rune-p (rune)
|
||||
(or (base-rune-p rune)
|
||||
(ideographic-rune-p rune)))
|
||||
|
||||
(digit-rune-p* (rune)
|
||||
(or (<= 48 rune 57)
|
||||
(<= 1632 rune 1641)
|
||||
(<= 1776 rune 1785)
|
||||
(<= 2406 rune 2415)
|
||||
(<= 2534 rune 2543)
|
||||
(<= 2662 rune 2671)
|
||||
(<= 2790 rune 2799)
|
||||
(<= 2918 rune 2927)
|
||||
(<= 3047 rune 3055)
|
||||
(<= 3174 rune 3183)
|
||||
(<= 3302 rune 3311)
|
||||
(<= 3430 rune 3439)
|
||||
(<= 3664 rune 3673)
|
||||
(<= 3792 rune 3801)
|
||||
(<= 3872 rune 3881)))
|
||||
|
||||
|
||||
(combining-rune-p (rune)
|
||||
(or (<= 768 rune 837)
|
||||
(<= 864 rune 865)
|
||||
(<= 1155 rune 1158)
|
||||
(<= 1425 rune 1441)
|
||||
(<= 1443 rune 1465)
|
||||
(<= 1467 rune 1469)
|
||||
(= 1471 rune)
|
||||
(<= 1473 rune 1474)
|
||||
(= 1476 rune)
|
||||
(<= 1611 rune 1618)
|
||||
(= 1648 rune)
|
||||
(<= 1750 rune 1756)
|
||||
(<= 1757 rune 1759)
|
||||
(<= 1760 rune 1764)
|
||||
(<= 1767 rune 1768)
|
||||
(<= 1770 rune 1773)
|
||||
(<= 2305 rune 2307)
|
||||
(= 2364 rune)
|
||||
(<= 2366 rune 2380)
|
||||
(= 2381 rune)
|
||||
(<= 2385 rune 2388)
|
||||
(<= 2402 rune 2403)
|
||||
(<= 2433 rune 2435)
|
||||
(= 2492 rune)
|
||||
(= 2494 rune)
|
||||
(= 2495 rune)
|
||||
(<= 2496 rune 2500)
|
||||
(<= 2503 rune 2504)
|
||||
(<= 2507 rune 2509)
|
||||
(= 2519 rune)
|
||||
(<= 2530 rune 2531)
|
||||
(= 2562 rune)
|
||||
(= 2620 rune)
|
||||
(= 2622 rune)
|
||||
(= 2623 rune)
|
||||
(<= 2624 rune 2626)
|
||||
(<= 2631 rune 2632)
|
||||
(<= 2635 rune 2637)
|
||||
(<= 2672 rune 2673)
|
||||
(<= 2689 rune 2691)
|
||||
(= 2748 rune)
|
||||
(<= 2750 rune 2757)
|
||||
(<= 2759 rune 2761)
|
||||
(<= 2763 rune 2765)
|
||||
(<= 2817 rune 2819)
|
||||
(= 2876 rune)
|
||||
(<= 2878 rune 2883)
|
||||
(<= 2887 rune 2888)
|
||||
(<= 2891 rune 2893)
|
||||
(<= 2902 rune 2903)
|
||||
(<= 2946 rune 2947)
|
||||
(<= 3006 rune 3010)
|
||||
(<= 3014 rune 3016)
|
||||
(<= 3018 rune 3021)
|
||||
(= 3031 rune)
|
||||
(<= 3073 rune 3075)
|
||||
(<= 3134 rune 3140)
|
||||
(<= 3142 rune 3144)
|
||||
(<= 3146 rune 3149)
|
||||
(<= 3157 rune 3158)
|
||||
(<= 3202 rune 3203)
|
||||
(<= 3262 rune 3268)
|
||||
(<= 3270 rune 3272)
|
||||
(<= 3274 rune 3277)
|
||||
(<= 3285 rune 3286)
|
||||
(<= 3330 rune 3331)
|
||||
(<= 3390 rune 3395)
|
||||
(<= 3398 rune 3400)
|
||||
(<= 3402 rune 3405)
|
||||
(= 3415 rune)
|
||||
(= 3633 rune)
|
||||
(<= 3636 rune 3642)
|
||||
(<= 3655 rune 3662)
|
||||
(= 3761 rune)
|
||||
(<= 3764 rune 3769)
|
||||
(<= 3771 rune 3772)
|
||||
(<= 3784 rune 3789)
|
||||
(<= 3864 rune 3865)
|
||||
(= 3893 rune)
|
||||
(= 3895 rune)
|
||||
(= 3897 rune)
|
||||
(= 3902 rune)
|
||||
(= 3903 rune)
|
||||
(<= 3953 rune 3972)
|
||||
(<= 3974 rune 3979)
|
||||
(<= 3984 rune 3989)
|
||||
(= 3991 rune)
|
||||
(<= 3993 rune 4013)
|
||||
(<= 4017 rune 4023)
|
||||
(= 4025 rune)
|
||||
(<= 8400 rune 8412)
|
||||
(= 8417 rune)
|
||||
(<= 12330 rune 12335)
|
||||
(= 12441 rune)
|
||||
(= 12442 rune)))
|
||||
|
||||
(extender-rune-p (rune)
|
||||
(or
|
||||
(= 183 rune)
|
||||
(= 720 rune)
|
||||
(= 721 rune)
|
||||
(= 903 rune)
|
||||
(= 1600 rune)
|
||||
(= 3654 rune)
|
||||
(= 3782 rune)
|
||||
(= 12293 rune)
|
||||
(<= 12337 rune 12341)
|
||||
(<= 12445 rune 12446)
|
||||
(<= 12540 rune 12542)))
|
||||
|
||||
(base-rune-p (rune)
|
||||
(or
|
||||
(<= 65 rune 90) (<= 97 rune 122) (<= 192 rune 214) (<= 216 rune 246) (<= 248 rune 255) (<= 256 rune 305)
|
||||
(<= 308 rune 318) (<= 321 rune 328) (<= 330 rune 382) (<= 384 rune 451) (<= 461 rune 496) (<= 500 rune 501)
|
||||
(<= 506 rune 535) (<= 592 rune 680) (<= 699 rune 705) (= 902 rune) (<= 904 rune 906) (= 908 rune)
|
||||
(<= 910 rune 929) (<= 931 rune 974) (<= 976 rune 982) (= 986 rune) (= 988 rune) (= 990 rune) (= 992 rune)
|
||||
(<= 994 rune 1011) (<= 1025 rune 1036) (<= 1038 rune 1103) (<= 1105 rune 1116) (<= 1118 rune 1153)
|
||||
(<= 1168 rune 1220) (<= 1223 rune 1224) (<= 1227 rune 1228) (<= 1232 rune 1259) (<= 1262 rune 1269)
|
||||
(<= 1272 rune 1273) (<= 1329 rune 1366) (= 1369 rune) (<= 1377 rune 1414) (<= 1488 rune 1514)
|
||||
(<= 1520 rune 1522) (<= 1569 rune 1594) (<= 1601 rune 1610) (<= 1649 rune 1719) (<= 1722 rune 1726)
|
||||
(<= 1728 rune 1742) (<= 1744 rune 1747) (= 1749 rune) (<= 1765 rune 1766) (<= 2309 rune 2361) (= 2365 rune)
|
||||
(<= 2392 rune 2401) (<= 2437 rune 2444) (<= 2447 rune 2448) (<= 2451 rune 2472) (<= 2474 rune 2480)
|
||||
(= 2482 rune) (<= 2486 rune 2489) (<= 2524 rune 2525) (<= 2527 rune 2529) (<= 2544 rune 2545)
|
||||
(<= 2565 rune 2570) (<= 2575 rune 2576) (<= 2579 rune 2600) (<= 2602 rune 2608) (<= 2610 rune 2611)
|
||||
(<= 2613 rune 2614) (<= 2616 rune 2617) (<= 2649 rune 2652) (= 2654 rune) (<= 2674 rune 2676)
|
||||
(<= 2693 rune 2699) (= 2701 rune) (<= 2703 rune 2705) (<= 2707 rune 2728) (<= 2730 rune 2736)
|
||||
(<= 2738 rune 2739) (<= 2741 rune 2745) (= 2749 rune) (= 2784 rune) (<= 2821 rune 2828) (<= 2831 rune 2832)
|
||||
(<= 2835 rune 2856) (<= 2858 rune 2864) (<= 2866 rune 2867) (<= 2870 rune 2873) (= 2877 rune)
|
||||
(<= 2908 rune 2909) (<= 2911 rune 2913) (<= 2949 rune 2954) (<= 2958 rune 2960) (<= 2962 rune 2965)
|
||||
(<= 2969 rune 2970) (= 2972 rune) (<= 2974 rune 2975) (<= 2979 rune 2980) (<= 2984 rune 2986)
|
||||
(<= 2990 rune 2997) (<= 2999 rune 3001) (<= 3077 rune 3084) (<= 3086 rune 3088) (<= 3090 rune 3112)
|
||||
(<= 3114 rune 3123) (<= 3125 rune 3129) (<= 3168 rune 3169) (<= 3205 rune 3212) (<= 3214 rune 3216)
|
||||
(<= 3218 rune 3240) (<= 3242 rune 3251) (<= 3253 rune 3257) (= 3294 rune) (<= 3296 rune 3297)
|
||||
(<= 3333 rune 3340) (<= 3342 rune 3344) (<= 3346 rune 3368) (<= 3370 rune 3385) (<= 3424 rune 3425)
|
||||
(<= 3585 rune 3630) (= 3632 rune) (<= 3634 rune 3635) (<= 3648 rune 3653) (<= 3713 rune 3714) (= 3716 rune)
|
||||
(<= 3719 rune 3720) (= 3722 rune) (= 3725 rune) (<= 3732 rune 3735) (<= 3737 rune 3743) (<= 3745 rune 3747)
|
||||
(= 3749 rune) (= 3751 rune) (<= 3754 rune 3755) (<= 3757 rune 3758) (= 3760 rune) (<= 3762 rune 3763) (= 3773 rune)
|
||||
(<= 3776 rune 3780) (<= 3904 rune 3911) (<= 3913 rune 3945) (<= 4256 rune 4293) (<= 4304 rune 4342)
|
||||
(= 4352 rune) (<= 4354 rune 4355) (<= 4357 rune 4359) (= 4361 rune) (<= 4363 rune 4364) (<= 4366 rune 4370)
|
||||
(= 4412 rune) (= 4414 rune) (= 4416 rune) (= 4428 rune) (= 4430 rune) (= 4432 rune) (<= 4436 rune 4437) (= 4441 rune)
|
||||
(<= 4447 rune 4449) (= 4451 rune) (= 4453 rune) (= 4455 rune) (= 4457 rune) (<= 4461 rune 4462) (<= 4466 rune 4467)
|
||||
(= 4469 rune) (= 4510 rune) (= 4520 rune) (= 4523 rune) (<= 4526 rune 4527) (<= 4535 rune 4536) (= 4538 rune)
|
||||
(<= 4540 rune 4546) (= 4587 rune) (= 4592 rune) (= 4601 rune) (<= 7680 rune 7835) (<= 7840 rune 7929)
|
||||
(<= 7936 rune 7957) (<= 7960 rune 7965) (<= 7968 rune 8005) (<= 8008 rune 8013) (<= 8016 rune 8023)
|
||||
(= 8025 rune) (= 8027 rune) (= 8029 rune) (<= 8031 rune 8061) (<= 8064 rune 8116) (<= 8118 rune 8124) (= 8126 rune)
|
||||
(<= 8130 rune 8132) (<= 8134 rune 8140) (<= 8144 rune 8147) (<= 8150 rune 8155) (<= 8160 rune 8172)
|
||||
(<= 8178 rune 8180) (<= 8182 rune 8188) (= 8486 rune) (<= 8490 rune 8491) (= 8494 rune) (<= 8576 rune 8578)
|
||||
(<= 12353 rune 12436) (<= 12449 rune 12538) (<= 12549 rune 12588) (<= 44032 rune 55203)))
|
||||
|
||||
(ideographic-rune-p (rune)
|
||||
(or (<= 19968 rune 40869) (= 12295 rune) (<= 12321 rune 12329)))
|
||||
|
||||
|
||||
(predicate-to-bv (p)
|
||||
(let ((r (make-array *max* :element-type 'bit :initial-element 0)))
|
||||
(dotimes (i #x10000 r)
|
||||
(when (funcall p i)
|
||||
(setf (aref r i) 1))))) )
|
||||
|
||||
`(progn
|
||||
(DEFSUBST NAME-RUNE-P (RUNE)
|
||||
(AND (<= 0 RUNE ,*max*)
|
||||
(LOCALLY (DECLARE (OPTIMIZE (SAFETY 0) (SPEED 3)))
|
||||
(= 1 (SBIT ',(predicate-to-bv #'name-rune-p)
|
||||
(THE FIXNUM RUNE))))))
|
||||
(DEFSUBST NAME-START-RUNE-P (RUNE)
|
||||
(AND (<= 0 RUNE ,*MAX*)
|
||||
(LOCALLY (DECLARE (OPTIMIZE (SAFETY 0) (SPEED 3)))
|
||||
(= 1 (SBIT ',(predicate-to-bv #'name-start-rune-p)
|
||||
(THE FIXNUM RUNE)))))))) ))))
|
||||
2824
xml/xml-parse.lisp
Normal file
2824
xml/xml-parse.lisp
Normal file
File diff suppressed because it is too large
Load Diff
370
xml/xml-stream.lisp
Normal file
370
xml/xml-stream.lisp
Normal file
@ -0,0 +1,370 @@
|
||||
;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: XML; readtable: glisp; Encoding: utf-8; -*-
|
||||
;;; ---------------------------------------------------------------------------
|
||||
;;; Title: Fast streams
|
||||
;;; Created: 1999-07-17
|
||||
;;; Author: Gilbert Baumann <unk6@rz.uni-karlsruhe.de>
|
||||
;;; License: LGPL (See file COPYING for details).
|
||||
;;; ---------------------------------------------------------------------------
|
||||
;;; © copyright 1999 by Gilbert Baumann
|
||||
|
||||
;;; This library is free software; you can redistribute it and/or
|
||||
;;; modify it under the terms of the GNU Library General Public
|
||||
;;; License as published by the Free Software Foundation; either
|
||||
;;; version 2 of the License, or (at your option) any later version.
|
||||
;;;
|
||||
;;; 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
|
||||
;;; Library General Public License for more details.
|
||||
;;;
|
||||
;;; You should have received a copy of the GNU Library General Public
|
||||
;;; License along with this library; if not, write to the
|
||||
;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
||||
;;; Boston, MA 02111-1307 USA.
|
||||
|
||||
(in-package :xml)
|
||||
|
||||
;;; API
|
||||
;;
|
||||
;; MAKE-XSTREAM cl-stream &key name speed initial-speed [function]
|
||||
;; MAKE-ROD-XSTREAM rod &key name [function]
|
||||
;; CLOSE-XSTREAM xstream [function]
|
||||
;; READ-RUNE xstream [macro]
|
||||
;; PEEK-RUNE xstream [macro]
|
||||
;; FREAD-RUNE xstream [function]
|
||||
;; FPEEK-RUNE xstream [function]
|
||||
;; XSTREAM-POSITION xstream [function]
|
||||
;; XSTREAM-LINE-NUMBER xstream [function]
|
||||
;; XSTREAM-COLUMN-NUMBER xstream [function]
|
||||
;; XSTREAM-PLIST xstream [accessor]
|
||||
;; XSTREAM-ENCODING xstream [accessor] <-- be careful here. [*]
|
||||
|
||||
;; [*] swichting the encoding on the fly is only possible when the
|
||||
;; stream's buffer is empty; therefore to be able to switch the
|
||||
;; encoding, while some runes are already read, set the stream's speed
|
||||
;; to 1 initially (via the initial-speed argument for MAKE-XSTREAM)
|
||||
;; and later set it to full speed. (The encoding of the runes
|
||||
;; sequence, you fetch off with READ-RUNE is always UTF-16 though).
|
||||
|
||||
;; An encoding is simply something, which provides the DECODE-SEQUENCE
|
||||
;; method.
|
||||
|
||||
;;; Controller protocol
|
||||
;;
|
||||
;; READ-OCTECTS sequence os-stream start end -> first-non-written
|
||||
;; XSTREAM/CLOSE os-stream
|
||||
;;
|
||||
|
||||
(eval-when (eval compile load)
|
||||
(defparameter *fast* '(optimize (speed 3) (safety 0)))
|
||||
;;(defparameter *fast* '(optimize (speed 2) (safety 3)))
|
||||
)
|
||||
|
||||
;; Let us first define fast fixnum arithmetric get rid of type
|
||||
;; checks. (After all we know what we do here).
|
||||
|
||||
(defmacro fx-op (op &rest xs)
|
||||
`(the fixnum (,op ,@(mapcar (lambda (x) `(the fixnum ,x)) xs))))
|
||||
(defmacro fx-pred (op &rest xs)
|
||||
`(,op ,@(mapcar (lambda (x) `(the fixnum ,x)) xs)))
|
||||
|
||||
(defmacro %+ (&rest xs) `(fx-op + ,@xs))
|
||||
(defmacro %- (&rest xs) `(fx-op - ,@xs))
|
||||
(defmacro %* (&rest xs) `(fx-op * ,@xs))
|
||||
(defmacro %/ (&rest xs) `(fx-op floor ,@xs))
|
||||
(defmacro %and (&rest xs) `(fx-op logand ,@xs))
|
||||
(defmacro %ior (&rest xs) `(fx-op logior ,@xs))
|
||||
(defmacro %xor (&rest xs) `(fx-op logxor ,@xs))
|
||||
(defmacro %ash (&rest xs) `(fx-op ash ,@xs))
|
||||
(defmacro %mod (&rest xs) `(fx-op mod ,@xs))
|
||||
|
||||
(defmacro %= (&rest xs) `(fx-pred = ,@xs))
|
||||
(defmacro %<= (&rest xs) `(fx-pred <= ,@xs))
|
||||
(defmacro %>= (&rest xs) `(fx-pred >= ,@xs))
|
||||
(defmacro %< (&rest xs) `(fx-pred < ,@xs))
|
||||
(defmacro %> (&rest xs) `(fx-pred > ,@xs))
|
||||
|
||||
(deftype buffer-index ()
|
||||
`(unsigned-byte ,(integer-length array-total-size-limit)))
|
||||
|
||||
(deftype buffer-byte ()
|
||||
`(unsigned-byte 16))
|
||||
|
||||
(deftype octet ()
|
||||
`(unsigned-byte 8))
|
||||
|
||||
;; The usage of a special marker for EOF is experimental and
|
||||
;; considered unhygenic.
|
||||
|
||||
(defconstant +end+ #xFFFF
|
||||
"Special marker inserted into stream buffers to indicate end of buffered data.")
|
||||
|
||||
(defvar +null-buffer+ (make-array 0 :element-type 'buffer-byte))
|
||||
(defvar +null-octet-buffer+ (make-array 0 :element-type 'octet))
|
||||
|
||||
(defstruct (xstream
|
||||
(:constructor make-xstream/low)
|
||||
(:copier nil)
|
||||
(:print-function print-xstream))
|
||||
|
||||
;;; Read buffer
|
||||
|
||||
;; the buffer itself
|
||||
(buffer +null-buffer+
|
||||
:type (simple-array buffer-byte (*)))
|
||||
;; points to the next element of `buffer' containing the next rune
|
||||
;; about to be read.
|
||||
(read-ptr 0 :type buffer-index)
|
||||
;; points to the first element of `buffer' not containing a rune to
|
||||
;; be read.
|
||||
(fill-ptr 0 :type buffer-index)
|
||||
|
||||
;;; OS buffer
|
||||
|
||||
;; a scratch pad for READ-SEQUENCE
|
||||
(os-buffer +null-octet-buffer+
|
||||
:type (simple-array octet (*)))
|
||||
|
||||
;; `os-left-start', `os-left-end' designate a region of os-buffer,
|
||||
;; which still contains some undecoded data. This is needed because
|
||||
;; of the DECODE-SEQUENCE protocol
|
||||
(os-left-start 0 :type buffer-index)
|
||||
(os-left-end 0 :type buffer-index)
|
||||
|
||||
;; How much to read each time
|
||||
(speed 0 :type buffer-index)
|
||||
|
||||
;; Some stream object obeying to a certain protcol
|
||||
os-stream
|
||||
|
||||
;; The external format
|
||||
;; (some object offering the ENCODING protocol)
|
||||
(encoding :utf-8)
|
||||
|
||||
;;A STREAM-NAME object
|
||||
(name nil)
|
||||
|
||||
;; a plist a struct keeps the hack away
|
||||
(plist nil)
|
||||
|
||||
;; Stream Position
|
||||
(line-number 1 :type integer) ;current line number
|
||||
(line-start 0 :type integer) ;stream position the current line starts at
|
||||
(buffer-start 0 :type integer) ;stream position the current buffer starts at
|
||||
|
||||
;; There is no need to maintain a column counter for each character
|
||||
;; read, since we can easily compute it from `line-start' and
|
||||
;; `buffer-start'.
|
||||
)
|
||||
|
||||
(defmacro read-rune (input)
|
||||
"Read a single rune off the xstream `input'. In case of end of file :EOF
|
||||
is returned."
|
||||
`((lambda (input)
|
||||
(declare (type xstream input)
|
||||
#.*fast*)
|
||||
(let ((rp (xstream-read-ptr input)))
|
||||
(declare (type buffer-index rp))
|
||||
(let ((ch (aref (the (simple-array buffer-byte (*)) (xstream-buffer input))
|
||||
rp)))
|
||||
(declare (type buffer-byte ch))
|
||||
(setf (xstream-read-ptr input) (%+ rp 1))
|
||||
(cond ((%= ch +end+)
|
||||
(the (or (member :eof) rune)
|
||||
(xstream-underflow input)))
|
||||
((%= ch #x000A) ;line break
|
||||
(account-for-line-break input)
|
||||
(code-rune ch))
|
||||
(t
|
||||
(code-rune ch))))))
|
||||
,input))
|
||||
|
||||
(defmacro peek-rune (input)
|
||||
"Peek a single rune off the xstream `input'. In case of end of file :EOF
|
||||
is returned."
|
||||
`((lambda (input)
|
||||
(declare (type xstream input)
|
||||
#.*fast*)
|
||||
(let ((rp (xstream-read-ptr input)))
|
||||
(declare (type buffer-index rp))
|
||||
(let ((ch (aref (the (simple-array buffer-byte (*)) (xstream-buffer input))
|
||||
rp)))
|
||||
(declare (type buffer-byte ch))
|
||||
(cond ((%= ch +end+)
|
||||
(prog1
|
||||
(the (or (member :eof) rune) (xstream-underflow input))
|
||||
(setf (xstream-read-ptr input) 0)))
|
||||
(t
|
||||
(code-rune ch))))))
|
||||
,input))
|
||||
|
||||
(defmacro consume-rune (input)
|
||||
"Like READ-RUNE, but does not actually return the read rune."
|
||||
`((lambda (input)
|
||||
(declare (type xstream input)
|
||||
#.*fast*)
|
||||
(let ((rp (xstream-read-ptr input)))
|
||||
(declare (type buffer-index rp))
|
||||
(let ((ch (aref (the (simple-array buffer-byte (*)) (xstream-buffer input))
|
||||
rp)))
|
||||
(declare (type buffer-byte ch))
|
||||
(setf (xstream-read-ptr input) (%+ rp 1))
|
||||
(when (%= ch +end+)
|
||||
(xstream-underflow input))
|
||||
(when (%= ch #x000A) ;line break
|
||||
(account-for-line-break input) )))
|
||||
nil)
|
||||
,input))
|
||||
|
||||
(defsubst unread-rune (rune input)
|
||||
"Unread the last recently read rune; if there wasn't such a rune, you
|
||||
deserve to loose."
|
||||
(declare (ignore rune))
|
||||
(decf (xstream-read-ptr input))
|
||||
(when (%= (peek-rune input) #x000A) ;was it a line break?
|
||||
(unaccount-for-line-break input)))
|
||||
|
||||
(defun fread-rune (input)
|
||||
(read-rune input))
|
||||
|
||||
(defun fpeek-rune (input)
|
||||
(peek-rune input))
|
||||
|
||||
;;; Line counting
|
||||
|
||||
(defun account-for-line-break (input)
|
||||
(declare (type xstream input))
|
||||
(incf (xstream-line-number input))
|
||||
(setf (xstream-line-start input)
|
||||
(+ (xstream-buffer-start input) (xstream-read-ptr input))))
|
||||
|
||||
(defun unaccount-for-line-break (input)
|
||||
;; incomplete!
|
||||
;; We better use a traditional lookahead technique or forbid unread-rune.
|
||||
(decf (xstream-line-number input)))
|
||||
|
||||
;; User API:
|
||||
|
||||
(defun xstream-position (input)
|
||||
(+ (xstream-buffer-start input) (xstream-read-ptr input)))
|
||||
|
||||
;; xstream-line-number is structure accessor
|
||||
|
||||
(defun xstream-column-number (input)
|
||||
(+ (- (xstream-position input)
|
||||
(xstream-line-start input))
|
||||
1))
|
||||
|
||||
;;; Underflow
|
||||
|
||||
;;(defun read-runes (sequence input))
|
||||
|
||||
(defun xstream-underflow (input)
|
||||
(declare (type xstream input))
|
||||
;; we are about to fill new data into the buffer, so we need to
|
||||
;; adjust buffer-start.
|
||||
(incf (xstream-buffer-start input)
|
||||
(- (xstream-fill-ptr input) 0))
|
||||
(let (n m)
|
||||
;; when there is something left in the os-buffer, we move it to
|
||||
;; the start of the buffer.
|
||||
(setf m (- (xstream-os-left-end input) (xstream-os-left-start input)))
|
||||
(unless (zerop m)
|
||||
(replace (xstream-os-buffer input) (xstream-os-buffer input)
|
||||
:start1 0 :end1 m
|
||||
:start2 (xstream-os-left-start input)
|
||||
:end2 (xstream-os-left-end input))
|
||||
;; then we take care that the buffer is large enough to carry at
|
||||
;; least 100 bytes (a random number)
|
||||
(unless (>= (length (xstream-os-buffer input)) 100)
|
||||
(error "You lost")
|
||||
;; todo: enlarge buffer
|
||||
))
|
||||
(setf n
|
||||
(read-octets (xstream-os-buffer input) (xstream-os-stream input)
|
||||
m (min (1- (length (xstream-os-buffer input)))
|
||||
(+ m (xstream-speed input)))))
|
||||
(cond ((%= n 0)
|
||||
(setf (xstream-read-ptr input) 0
|
||||
(xstream-fill-ptr input) n)
|
||||
(setf (aref (xstream-buffer input) (xstream-fill-ptr input)) +end+)
|
||||
:eof)
|
||||
(t
|
||||
(multiple-value-bind (fnw fnr)
|
||||
(decode-sequence (xstream-encoding input)
|
||||
(xstream-os-buffer input) 0 n
|
||||
(xstream-buffer input) 0 (1- (length (xstream-buffer input)))
|
||||
(= n m))
|
||||
(setf (xstream-os-left-start input) fnr
|
||||
(xstream-os-left-end input) n
|
||||
(xstream-read-ptr input) 0
|
||||
(xstream-fill-ptr input) fnw)
|
||||
(setf (aref (xstream-buffer input) (xstream-fill-ptr input)) +end+)
|
||||
(read-rune input))))))
|
||||
|
||||
;;; constructor
|
||||
|
||||
(defun make-xstream (os-stream &key name (speed 8192) (initial-speed speed))
|
||||
(let ()
|
||||
(multiple-value-bind (encoding preread) (figure-encoding os-stream)
|
||||
(let ((osbuf (make-array speed :element-type '(unsigned-byte 8))))
|
||||
(replace osbuf preread)
|
||||
(make-xstream/low
|
||||
:buffer (let ((r (make-array speed :element-type 'buffer-byte)))
|
||||
(setf (%rune r 0) #xFFFF)
|
||||
r)
|
||||
:read-ptr 0
|
||||
:fill-ptr 0
|
||||
:os-buffer osbuf
|
||||
:speed initial-speed
|
||||
:os-stream os-stream
|
||||
:os-left-start 0
|
||||
:os-left-end (length preread)
|
||||
:encoding encoding
|
||||
:name name)))))
|
||||
|
||||
(defmethod figure-encoding ((stream glisp:gstream))
|
||||
;; For HTML iso-8859-1 is the default
|
||||
(values (xml::find-encoding :iso-8859-1) nil))
|
||||
|
||||
(defun make-rod-xstream (string &key name)
|
||||
(let ((n (length string)))
|
||||
(let ((buffer (make-array (1+ n) :element-type 'buffer-byte)))
|
||||
(declare (type (simple-array buffer-byte (*)) buffer))
|
||||
;; copy the rod
|
||||
(do ((i (1- n) (- i 1)))
|
||||
((< i 0))
|
||||
(declare (type fixnum i))
|
||||
(setf (aref buffer i) (rune-code (%rune string i))))
|
||||
(setf (aref buffer n) +end+)
|
||||
;;
|
||||
(make-xstream/low :buffer buffer
|
||||
:read-ptr 0
|
||||
:fill-ptr n
|
||||
;; :os-buffer nil
|
||||
:speed 1
|
||||
:os-stream nil
|
||||
:name name))))
|
||||
|
||||
;;; misc
|
||||
|
||||
(defun close-xstream (input)
|
||||
(xstream/close (xstream-os-stream input)))
|
||||
|
||||
;;; controller implementations
|
||||
|
||||
(defmethod read-octets (sequence (stream stream) start end)
|
||||
(#+CLISP lisp:read-byte-sequence
|
||||
#-CLISP read-sequence
|
||||
sequence stream :start start :end end))
|
||||
|
||||
(defmethod read-octets (sequence (stream null) start end)
|
||||
(declare (ignore sequence start end))
|
||||
0)
|
||||
|
||||
(defmethod xstream/close ((stream stream))
|
||||
(close stream))
|
||||
|
||||
(defmethod xstream/close ((stream null))
|
||||
nil)
|
||||
|
||||
118
xml/xmls-compat.lisp
Normal file
118
xml/xmls-compat.lisp
Normal file
@ -0,0 +1,118 @@
|
||||
;;;; xml-compat.lisp -- XMLS-compatible data structures
|
||||
;;;;
|
||||
;;;; This file is part of the CXML parser, released under (L)LGPL.
|
||||
;;;; See file COPYING for details.
|
||||
;;;;
|
||||
;;;; Copyright (c) 2004 headcraft GmbH
|
||||
;;;; Author: David Lichteblau
|
||||
|
||||
(defpackage cxml-xmls
|
||||
(:use :cl)
|
||||
(:export #:make-node #:node-name #:node-attrs #:node-children
|
||||
#:make-xmls-builder #:map-node))
|
||||
|
||||
(in-package :cxml-xmls)
|
||||
|
||||
|
||||
;;;; Knoten
|
||||
|
||||
;; XXX Wie namespaces in xmls funktionieren nsollen verstehe ich noch nicht so
|
||||
;; ganz. Daher verzichte ich vorerst auf NODE-NS und verwende durchweg QNAMEs.
|
||||
(defun make-node (&key name attrs children)
|
||||
`(,name ,attrs ,@children))
|
||||
|
||||
(defun node-name (node)
|
||||
(car node))
|
||||
|
||||
(defun (setf node-name) (newval node)
|
||||
(setf (car node) newval))
|
||||
|
||||
(defun node-attrs (node)
|
||||
(cadr node))
|
||||
|
||||
(defun (setf node-attrs) (newval node)
|
||||
(setf (cadr node) newval))
|
||||
|
||||
(defun node-children (node)
|
||||
(cddr node))
|
||||
|
||||
(defun (setf node-children) (newval node)
|
||||
(setf (cddr node) newval))
|
||||
|
||||
|
||||
;;;; SAX-Handler (Parser)
|
||||
|
||||
(defclass xmls-builder ()
|
||||
((element-stack :initform nil :accessor element-stack)
|
||||
(root :initform nil :accessor root)))
|
||||
|
||||
(defun make-xmls-builder ()
|
||||
(make-instance 'xmls-builder))
|
||||
|
||||
(defmethod sax:end-document ((handler xmls-builder))
|
||||
(root handler))
|
||||
|
||||
(defmethod sax:start-element
|
||||
((handler xmls-builder) namespace-uri local-name qname attributes)
|
||||
(declare (ignore namespace-uri local-name))
|
||||
(let* ((attributes
|
||||
(mapcar (lambda (attr)
|
||||
(list (sax:attribute-qname attr)
|
||||
(sax:attribute-value attr)))
|
||||
attributes))
|
||||
(node (make-node :name qname :attrs attributes))
|
||||
(parent (car (element-stack handler))))
|
||||
(if parent
|
||||
(push node (node-children parent))
|
||||
(setf (root handler) node))
|
||||
(push node (element-stack handler))))
|
||||
|
||||
(defmethod sax:end-element
|
||||
((handler xmls-builder) namespace-uri local-name qname)
|
||||
(declare (ignore namespace-uri local-name qname))
|
||||
(let ((node (pop (element-stack handler))))
|
||||
(setf (node-children node) (reverse (node-children node)))))
|
||||
|
||||
(defmethod sax:characters ((handler xmls-builder) data)
|
||||
(let* ((parent (car (element-stack handler)))
|
||||
(prev (car (node-children parent))))
|
||||
(if (stringp prev)
|
||||
;; um entities herum wird SAX:CHARACTERS mehrfach aufgerufen fuer
|
||||
;; den gleichen Textknoten. Hier muessen wir den bestehenden Knoten
|
||||
;; erweitern, sonst ist das Dokument nicht normalisiert.
|
||||
;; (XXX Oder sollte man besser den Parser entsprechend aendern?)
|
||||
(setf (car (node-children parent))
|
||||
(concatenate 'runes:rod prev data))
|
||||
(push data (node-children parent)))))
|
||||
|
||||
|
||||
;;;; SAX-Treiber (fuer Serialisierung)
|
||||
|
||||
(defun map-node
|
||||
(handler node
|
||||
&key (include-xmlns-attributes sax:*include-xmlns-attributes*))
|
||||
(sax:start-document handler)
|
||||
(labels ((walk (node)
|
||||
(let ((attlist
|
||||
(compute-attributes node include-xmlns-attributes))
|
||||
(qname (node-name node)))
|
||||
;; fixme: namespaces
|
||||
(sax:start-element handler nil nil qname attlist)
|
||||
(dolist (child (node-children node))
|
||||
(typecase child
|
||||
(list (walk child))
|
||||
(string (sax:characters handler child))))
|
||||
(sax:end-element handler nil nil qname))))
|
||||
(walk node))
|
||||
(sax:end-document handler))
|
||||
|
||||
(defun compute-attributes (node xmlnsp)
|
||||
(remove nil
|
||||
(mapcar (lambda (a)
|
||||
(destructuring-bind (name value) a
|
||||
(if (or xmlnsp (not (cxml::xmlns-attr-p name)))
|
||||
(sax:make-attribute :qname name
|
||||
:value value
|
||||
:specified-p t)
|
||||
nil)))
|
||||
(node-attrs node))))
|
||||
Reference in New Issue
Block a user