This is huge commit, but alas, couldn't really do without it.
--- /dev/null
+# Boring file regexps:
+~$
+^_darcs
+^\{arch\}
+^.arch-ids
+\#
+\.dfsl$
+\.ppcf$
+\.fasl$
+\.x86f$
+\.fas$
+\.lib$
+^public_html
--- /dev/null
+*.fasl
+*~
+\#*
+*.patch
--- /dev/null
+
+ACTA EST FABULA PLAUDITE
+
+Nikodemus Siivola
+Attila Lendvai
+Marco Baringer
+Robert Strandh
+Luis Oliveira
+Tobias C. Rittweiler
\ No newline at end of file
--- /dev/null
+Alexandria software and associated documentation are in the public
+domain:
+
+ Authors dedicate this work to public domain, for the benefit of the
+ public at large and to the detriment of the authors' heirs and
+ successors. Authors intends this dedication to be an overt act of
+ relinquishment in perpetuity of all present and future rights under
+ copyright law, whether vested or contingent, in the work. Authors
+ understands that such relinquishment of all rights includes the
+ relinquishment of all rights to enforce (by lawsuit or otherwise)
+ those copyrights in the work.
+
+ Authors recognize that, once placed in the public domain, the work
+ may be freely reproduced, distributed, transmitted, used, modified,
+ built upon, or otherwise exploited by anyone for any purpose,
+ commercial or non-commercial, and in any way, including by methods
+ that have not yet been invented or conceived.
+
+In those legislations where public domain dedications are not
+recognized or possible, Alexandria is distributed under the following
+terms and conditions:
+
+ Permission is hereby granted, free of charge, to any person
+ obtaining a copy of this software and associated documentation files
+ (the "Software"), to deal in the Software without restriction,
+ including without limitation the rights to use, copy, modify, merge,
+ publish, distribute, sublicense, and/or sell copies of the Software,
+ and to permit persons to whom the Software is furnished to do so,
+ subject to the following conditions:
+
+ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+ IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+ CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+ TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+ SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
--- /dev/null
+Alexandria is a collection of portable public domain utilities that
+meet the following constraints:
+
+ * Utilities, not extensions: Alexandria will not contain conceptual
+ extensions to Common Lisp, instead limiting itself to tools and
+ utilities that fit well within the framework of standard ANSI
+ Common Lisp. Test-frameworks, system definitions, logging
+ facilities, serialization layers, etc. are all outside the scope of
+ Alexandria as a library, though well within the scope of Alexandria
+ as a project.
+
+ * Conservative: Alexandria limits itself to what project members
+ consider conservative utilities. Alexandria does not and will not
+ include anaphoric constructs, loop-like binding macros, etc.
+
+ * Portable: Alexandria limits itself to portable parts of Common
+ Lisp. Even apparently conservative and useful functions remain
+ outside the scope of Alexandria if they cannot be implemented
+ portably. Portability is here defined as portable within a
+ conforming implementation: implementation bugs are not considered
+ portability issues.
+
+Homepage:
+
+ http://common-lisp.net/project/alexandria/
+
+Mailing lists:
+
+ http://lists.common-lisp.net/mailman/listinfo/alexandria-devel
+ http://lists.common-lisp.net/mailman/listinfo/alexandria-cvs
+
+Repository:
+
+ git://common-lisp.net/projects/alexandria/alexandria.git
+
+Documentation:
+
+ http://common-lisp.net/project/alexandria/draft/alexandria.html
+
+ (To build docs locally: cd doc && make html pdf info)
+
+Patches:
+
+ Patches are always welcome! Please send them to the mailing list as
+ attachments, generated by "git format-patch -1".
+
+ Patches should include a commit message that explains what's being
+ done and /why/, and when fixing a bug or adding a feature you should
+ also include a test-case.
+
+ Be advised though that right now new features are unlikely to be
+ accepted until 1.0 is officially out of the door.
--- /dev/null
+(defsystem alexandria-tests
+ :licence "Public Domain / 0-clause MIT"
+ :description "Tests for Alexandria, which is a collection of portable public domain utilities."
+ :author "Nikodemus Siivola <nikodemus@sb-studio.net>, and others."
+ :depends-on (:alexandria #+sbcl :sb-rt #-sbcl :rt)
+ :components ((:file "tests")))
+
+(defmethod perform ((o test-op) (c (eql (find-system :alexandria-tests))))
+ (flet ((run-tests (&rest args)
+ (apply (intern (string '#:run-tests) '#:alexandria-tests) args)))
+ (run-tests :compiled nil)
+ (run-tests :compiled t)))
--- /dev/null
+(defsystem :alexandria
+ :version "0.0.0"
+ :licence "Public Domain / 0-clause MIT"
+ :description "Alexandria is a collection of portable public domain utilities."
+ :author "Nikodemus Siivola <nikodemus@sb-studio.net>, and others."
+ :long-description
+ "Alexandria is a project and a library.
+
+As a project Alexandria's goal is to reduce duplication of effort and improve
+portability of Common Lisp code according to its own idiosyncratic and rather
+conservative aesthetic. What this actually means is open to debate, but each
+project member has a veto on all project activities, so a degree of
+conservativism is inevitable.
+
+As a library Alexandria is one of the means by which the project strives for
+its goals.
+
+Alexandria is a collection of portable public domain utilities that meet
+the following constraints:
+
+ * Utilities, not extensions: Alexandria will not contain conceptual
+ extensions to Common Lisp, instead limiting itself to tools and utilities
+ that fit well within the framework of standard ANSI Common Lisp.
+ Test-frameworks, system definitions, logging facilities, serialization
+ layers, etc. are all outside the scope of Alexandria as a library, though
+ well within the scope of Alexandria as a project.
+
+ * Conservative: Alexandria limits itself to what project members consider
+ conservative utilities. Alexandria does not and will not include anaphoric
+ constructs, loop-like binding macros, etc.
+
+ * Portable: Alexandria limits itself to portable parts of Common Lisp. Even
+ apparently conservative and useful functions remain outside the scope of
+ Alexandria if they cannot be implemented portably. Portability is here
+ defined as portable within a conforming implementation: implementation bugs
+ are not considered portability issues.
+
+ * Team player: Alexandria will not (initially, at least) subsume or provide
+ functionality for which good-quality special-purpose packages exist, like
+ split-sequence. Instead, third party packages such as that may be
+ \"blessed\"."
+ :components
+ ((:static-file "LICENCE")
+ (:static-file "tests.lisp")
+ (:file "package")
+ (:file "definitions" :depends-on ("package"))
+ (:file "binding" :depends-on ("package"))
+ (:file "strings" :depends-on ("package"))
+ (:file "conditions" :depends-on ("package"))
+ (:file "io" :depends-on ("package" "macros" "lists" "types"))
+ (:file "macros" :depends-on ("package" "strings" "symbols"))
+ (:file "hash-tables" :depends-on ("package" "macros"))
+ (:file "control-flow" :depends-on ("package" "definitions" "macros"))
+ (:file "symbols" :depends-on ("package"))
+ (:file "functions" :depends-on ("package" "symbols" "macros"))
+ (:file "lists" :depends-on ("package" "functions"))
+ (:file "types" :depends-on ("package" "symbols" "lists"))
+ (:file "arrays" :depends-on ("package" "types"))
+ (:file "sequences" :depends-on ("package" "lists" "types"))
+ (:file "numbers" :depends-on ("package" "sequences"))
+ (:file "features" :depends-on ("package" "control-flow"))))
+
+(defmethod operation-done-p ((o test-op) (c (eql (find-system :alexandria))))
+ nil)
+
+(defmethod perform ((o test-op) (c (eql (find-system :alexandria))))
+ (operate 'load-op :alexandria-tests)
+ (operate 'test-op :alexandria-tests))
--- /dev/null
+(in-package :alexandria)
+
+(defun copy-array (array &key (element-type (array-element-type array))
+ (fill-pointer (and (array-has-fill-pointer-p array)
+ (fill-pointer array)))
+ (adjustable (adjustable-array-p array)))
+ "Returns an undisplaced copy of ARRAY, with same fill-pointer and
+adjustability (if any) as the original, unless overridden by the keyword
+arguments."
+ (let* ((dimensions (array-dimensions array))
+ (new-array (make-array dimensions
+ :element-type element-type
+ :adjustable adjustable
+ :fill-pointer fill-pointer)))
+ (dotimes (i (array-total-size array))
+ (setf (row-major-aref new-array i)
+ (row-major-aref array i)))
+ new-array))
--- /dev/null
+(in-package :alexandria)
+
+(defmacro if-let (bindings &body (then-form &optional else-form))
+ "Creates new variable bindings, and conditionally executes either
+THEN-FORM or ELSE-FORM. ELSE-FORM defaults to NIL.
+
+BINDINGS must be either single binding of the form:
+
+ (variable initial-form)
+
+or a list of bindings of the form:
+
+ ((variable-1 initial-form-1)
+ (variable-2 initial-form-2)
+ ...
+ (variable-n initial-form-n))
+
+All initial-forms are executed sequentially in the specified order. Then all
+the variables are bound to the corresponding values.
+
+If all variables were bound to true values, the THEN-FORM is executed with the
+bindings in effect, otherwise the ELSE-FORM is executed with the bindings in
+effect."
+ (let* ((binding-list (if (and (consp bindings) (symbolp (car bindings)))
+ (list bindings)
+ bindings))
+ (variables (mapcar #'car binding-list)))
+ `(let ,binding-list
+ (if (and ,@variables)
+ ,then-form
+ ,else-form))))
+
+(defmacro when-let (bindings &body forms)
+ "Creates new variable bindings, and conditionally executes FORMS.
+
+BINDINGS must be either single binding of the form:
+
+ (variable initial-form)
+
+or a list of bindings of the form:
+
+ ((variable-1 initial-form-1)
+ (variable-2 initial-form-2)
+ ...
+ (variable-n initial-form-n))
+
+All initial-forms are executed sequentially in the specified order. Then all
+the variables are bound to the corresponding values.
+
+If all variables were bound to true values, then FORMS are executed as an
+implicit PROGN."
+ (let* ((binding-list (if (and (consp bindings) (symbolp (car bindings)))
+ (list bindings)
+ bindings))
+ (variables (mapcar #'car binding-list)))
+ `(let ,binding-list
+ (when (and ,@variables)
+ ,@forms))))
+
+(defmacro when-let* (bindings &body forms)
+ "Creates new variable bindings, and conditionally executes FORMS.
+
+BINDINGS must be either single binding of the form:
+
+ (variable initial-form)
+
+or a list of bindings of the form:
+
+ ((variable-1 initial-form-1)
+ (variable-2 initial-form-2)
+ ...
+ (variable-n initial-form-n))
+
+Each initial-form is executed in turn, and the variable bound to the
+corresponding value. Initial-form expressions can refer to variables
+previously bound by the WHEN-LET*.
+
+Execution of WHEN-LET* stops immediately if any initial-form evaluates to NIL.
+If all initial-forms evaluate to true, then FORMS are executed as an implicit
+PROGN."
+ (let ((binding-list (if (and (consp bindings) (symbolp (car bindings)))
+ (list bindings)
+ bindings)))
+ (labels ((bind (bindings forms)
+ (if bindings
+ `((let (,(car bindings))
+ (when ,(caar bindings)
+ ,@(bind (cdr bindings) forms))))
+ forms)))
+ `(let (,(car binding-list))
+ (when ,(caar binding-list)
+ ,@(bind (cdr binding-list) forms))))))
+
--- /dev/null
+(in-package :alexandria)
+
+(defun required-argument (&optional name)
+ "Signals an error for a missing argument of NAME. Intended for
+use as an initialization form for structure and class-slots, and
+a default value for required keyword arguments."
+ (error "Required argument ~@[~S ~]missing." name))
+
+(define-condition simple-style-warning (simple-warning style-warning)
+ ())
+
+(defun simple-style-warning (message &rest args)
+ (warn 'simple-style-warning :format-control message :format-arguments args))
+
+;; We don't specify a :report for simple-reader-error to let the
+;; underlying implementation report the line and column position for
+;; us. Unfortunately this way the message from simple-error is not
+;; displayed, unless there's special support for that in the
+;; implementation. But even then it's still inspectable from the
+;; debugger...
+(define-condition simple-reader-error
+ #-sbcl(simple-error reader-error)
+ #+sbcl(sb-int:simple-reader-error)
+ ())
+
+(defun simple-reader-error (stream message &rest args)
+ (error 'simple-reader-error
+ :stream stream
+ :format-control message
+ :format-arguments args))
+
+(define-condition simple-parse-error (simple-error parse-error)
+ ())
+
+(defun simple-parse-error (message &rest args)
+ (error 'simple-parse-error
+ :format-control message
+ :format-arguments args))
+
+(define-condition simple-program-error (simple-error program-error)
+ ())
+
+(defun simple-program-error (message &rest args)
+ (error 'simple-program-error
+ :format-control message
+ :format-arguments args))
+
+(defmacro ignore-some-conditions ((&rest conditions) &body body)
+ "Similar to CL:IGNORE-ERRORS but the (unevaluated) CONDITIONS
+list determines which specific conditions are to be ignored."
+ `(handler-case
+ (progn ,@body)
+ ,@(loop for condition in conditions collect
+ `(,condition (c) (values nil c)))))
+
+(defmacro unwind-protect-case ((&optional abort-flag) protected-form &body clauses)
+ "Like CL:UNWIND-PROTECT, but you can specify the circumstances that
+the cleanup CLAUSES are run.
+
+ clauses ::= (:NORMAL form*)* | (:ABORT form*)* | (:ALWAYS form*)*
+
+Clauses can be given in any order, and more than one clause can be
+given for each circumstance. The clauses whose denoted circumstance
+occured, are executed in the order the clauses appear.
+
+ABORT-FLAG is the name of a variable that will be bound to T in
+CLAUSES if the PROTECTED-FORM aborted preemptively, and to NIL
+otherwise.
+
+Examples:
+
+ (unwind-protect-case ()
+ (protected-form)
+ (:normal (format t \"This is only evaluated if PROTECTED-FORM executed normally.~%\"))
+ (:abort (format t \"This is only evaluated if PROTECTED-FORM aborted preemptively.~%\"))
+ (:always (format t \"This is evaluated in either case.~%\")))
+
+ (unwind-protect-case (aborted-p)
+ (protected-form)
+ (:always (perform-cleanup-if aborted-p)))
+"
+ (check-type abort-flag (or null symbol))
+ (let ((gflag (gensym "FLAG+")))
+ `(let ((,gflag t))
+ (unwind-protect (multiple-value-prog1 ,protected-form (setf ,gflag nil))
+ (let ,(and abort-flag `((,abort-flag ,gflag)))
+ ,@(loop for (cleanup-kind . forms) in clauses
+ collect (ecase cleanup-kind
+ (:normal `(when (not ,gflag) ,@forms))
+ (:abort `(when ,gflag ,@forms))
+ (:always `(progn ,@forms)))))))))
\ No newline at end of file
--- /dev/null
+(in-package :alexandria)
+
+(defun extract-function-name (spec)
+ "Useful for macros that want to mimic the functional interface for functions
+like #'eq and 'eq."
+ (if (and (consp spec)
+ (member (first spec) '(quote function)))
+ (second spec)
+ spec))
+
+(defun generate-switch-body (whole object clauses test key &optional default)
+ (with-gensyms (value)
+ (setf test (extract-function-name test))
+ (setf key (extract-function-name key))
+ (when (and (consp default)
+ (member (first default) '(error cerror)))
+ (setf default `(,@default "No keys match in SWITCH. Testing against ~S with ~S."
+ ,value ',test)))
+ `(let ((,value (,key ,object)))
+ (cond ,@(mapcar (lambda (clause)
+ (if (member (first clause) '(t otherwise))
+ (progn
+ (when default
+ (error "Multiple default clauses or illegal use of a default clause in ~S."
+ whole))
+ (setf default `(progn ,@(rest clause)))
+ '(()))
+ (destructuring-bind (key-form &body forms) clause
+ `((,test ,value ,key-form)
+ ,@forms))))
+ clauses)
+ (t ,default)))))
+
+(defmacro switch (&whole whole (object &key (test 'eql) (key 'identity))
+ &body clauses)
+ "Evaluates first matching clause, returning its values, or evaluates and
+returns the values of DEFAULT if no keys match."
+ (generate-switch-body whole object clauses test key))
+
+(defmacro eswitch (&whole whole (object &key (test 'eql) (key 'identity))
+ &body clauses)
+ "Like SWITCH, but signals an error if no key matches."
+ (generate-switch-body whole object clauses test key '(error)))
+
+(defmacro cswitch (&whole whole (object &key (test 'eql) (key 'identity))
+ &body clauses)
+ "Like SWITCH, but signals a continuable error if no key matches."
+ (generate-switch-body whole object clauses test key '(cerror "Return NIL from CSWITCH.")))
+
+(defmacro whichever (&rest possibilities &environment env)
+ "Evaluates exactly one of POSSIBILITIES, chosen at random."
+ (setf possibilities (mapcar (lambda (p) (macroexpand p env)) possibilities))
+ (if (every (lambda (p) (constantp p)) possibilities)
+ `(svref (load-time-value (vector ,@possibilities)) (random ,(length possibilities)))
+ (labels ((expand (possibilities position random-number)
+ (if (null (cdr possibilities))
+ (car possibilities)
+ (let* ((length (length possibilities))
+ (half (truncate length 2))
+ (second-half (nthcdr half possibilities))
+ (first-half (butlast possibilities (- length half))))
+ `(if (< ,random-number ,(+ position half))
+ ,(expand first-half position random-number)
+ ,(expand second-half (+ position half) random-number))))))
+ (with-gensyms (random-number)
+ (let ((length (length possibilities)))
+ `(let ((,random-number (random ,length)))
+ ,(expand possibilities 0 random-number)))))))
+
+(defmacro xor (&rest datums)
+ "Evaluates its arguments one at a time, from left to right. If more than one
+argument evaluates to a true value no further DATUMS are evaluated, and NIL is
+returned as both primary and secondary value. If exactly one argument
+evaluates to true, its value is returned as the primary value after all the
+arguments have been evaluated, and T is returned as the secondary value. If no
+arguments evaluate to true NIL is retuned as primary, and T as secondary
+value."
+ (with-gensyms (xor tmp true)
+ `(let (,tmp ,true)
+ (block ,xor
+ ,@(mapcar (lambda (datum)
+ `(if (setf ,tmp ,datum)
+ (if ,true
+ (return-from ,xor (values nil nil))
+ (setf ,true ,tmp))))
+ datums)
+ (return-from ,xor (values ,true t))))))
+
+(defmacro nth-value-or (nth-value &body forms)
+ "Evaluates FORM arguments one at a time, until the NTH-VALUE returned by one
+of the forms is true. It then returns all the values returned by evaluating
+that form. If none of the forms return a true nth value, this form returns
+NIL."
+ (once-only (nth-value)
+ (with-gensyms (values)
+ `(let ((,values (multiple-value-list ,(first forms))))
+ (if (nth ,nth-value ,values)
+ (values-list ,values)
+ ,(if (rest forms)
+ `(nth-value-or ,nth-value ,@(rest forms))
+ nil))))))
+
+(defmacro multiple-value-prog2 (first-form second-form &body forms)
+ "Evaluates FIRST-FORM, then SECOND-FORM, and then FORMS. Yields as its value
+all the value returned by SECOND-FORM."
+ `(progn ,first-form (multiple-value-prog1 ,second-form ,@forms)))
--- /dev/null
+(in-package :alexandria)
+
+(defun %reevaluate-constant (name value test)
+ (if (not (boundp name))
+ value
+ (let ((old (symbol-value name))
+ (new value))
+ (if (not (constantp name))
+ (prog1 new
+ (cerror "Try to redefine the variable as a constant."
+ "~@<~S is an already bound non-constant variable ~
+ whose value is ~S.~:@>" name old))
+ (if (funcall test old new)
+ old
+ (restart-case
+ (error "~@<~S is an already defined constant whose value ~
+ ~S is not equal to the provided initial value ~S ~
+ under ~S.~:@>" name old new test)
+ (ignore ()
+ :report "Retain the current value."
+ old)
+ (continue ()
+ :report "Try to redefine the constant."
+ new)))))))
+
+(defmacro define-constant (name initial-value &key (test ''eql) documentation)
+ "Ensures that the global variable named by NAME is a constant with a value
+that is equal under TEST to the result of evaluating INITIAL-VALUE. TEST is a
+/function designator/ that defaults to EQL. If DOCUMENTATION is given, it
+becomes the documentation string of the constant.
+
+Signals an error if NAME is already a bound non-constant variable.
+
+Signals an error if NAME is already a constant variable whose value is not
+equal under TEST to result of evaluating INITIAL-VALUE."
+ `(defconstant ,name (%reevaluate-constant ',name ,initial-value ,test)
+ ,@(when documentation `(,documentation))))
--- /dev/null
+alexandria
+include
+
--- /dev/null
+.PHONY: clean html pdf include clean-include clean-crap info doc
+
+doc: pdf html info clean-crap
+
+clean-include:
+ rm -rf include
+
+clean-crap:
+ rm -f *.aux *.cp *.fn *.fns *.ky *.log *.pg *.toc *.tp *.tps *.vr
+
+clean: clean-include
+ rm -f *.pdf *.html *.info
+
+include:
+ sbcl --no-userinit --eval '(require :asdf)' \
+ --eval '(let ((asdf:*central-registry* (list "../"))) (require :alexandria))' \
+ --load docstrings.lisp \
+ --eval '(sb-texinfo:generate-includes "include/" (list :alexandria) :base-package :alexandria)' \
+ --eval '(quit)'
+
+pdf: include
+ texi2pdf alexandria.texinfo
+
+html: include
+ makeinfo --html --no-split alexandria.texinfo
+
+info: include
+ makeinfo alexandria.texinfo
--- /dev/null
+\input texinfo @c -*-texinfo-*-
+@c %**start of header
+@setfilename alexandria.info
+@settitle Alexandria Manual
+@c %**end of header
+
+@settitle Alexandria Manual -- draft version
+
+@c for install-info
+@dircategory Software development
+@direntry
+* alexandria: Common Lisp utilities.
+@end direntry
+
+@copying
+Alexandria software and associated documentation are in the public
+domain:
+
+@quotation
+ Authors dedicate this work to public domain, for the benefit of the
+ public at large and to the detriment of the authors' heirs and
+ successors. Authors intends this dedication to be an overt act of
+ relinquishment in perpetuity of all present and future rights under
+ copyright law, whether vested or contingent, in the work. Authors
+ understands that such relinquishment of all rights includes the
+ relinquishment of all rights to enforce (by lawsuit or otherwise)
+ those copyrights in the work.
+
+ Authors recognize that, once placed in the public domain, the work
+ may be freely reproduced, distributed, transmitted, used, modified,
+ built upon, or otherwise exploited by anyone for any purpose,
+ commercial or non-commercial, and in any way, including by methods
+ that have not yet been invented or conceived.
+@end quotation
+
+In those legislations where public domain dedications are not
+recognized or possible, Alexandria is distributed under the following
+terms and conditions:
+
+@quotation
+ Permission is hereby granted, free of charge, to any person
+ obtaining a copy of this software and associated documentation files
+ (the "Software"), to deal in the Software without restriction,
+ including without limitation the rights to use, copy, modify, merge,
+ publish, distribute, sublicense, and/or sell copies of the Software,
+ and to permit persons to whom the Software is furnished to do so,
+ subject to the following conditions:
+
+ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+ IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+ CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+ TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+ SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+@end quotation
+@end copying
+
+@titlepage
+
+@title Alexandria Manual
+@subtitle draft version
+
+@c The following two commands start the copyright page.
+@page
+@vskip 0pt plus 1filll
+@insertcopying
+
+@end titlepage
+
+@contents
+
+@ifnottex
+
+@include include/ifnottex.texinfo
+
+@node Top
+@comment node-name, next, previous, up
+@top Alexandria
+
+@insertcopying
+
+@menu
+* Hash Tables::
+* Data and Control Flow::
+* Conses::
+* Sequences::
+* IO::
+* Macro Writing::
+* Symbols::
+* Arrays::
+* Types::
+* Numbers::
+@end menu
+
+@end ifnottex
+
+@node Hash Tables
+@comment node-name, next, previous, up
+@chapter Hash Tables
+
+@include include/macro-alexandria-ensure-gethash.texinfo
+@include include/fun-alexandria-copy-hash-table.texinfo
+@include include/fun-alexandria-maphash-keys.texinfo
+@include include/fun-alexandria-maphash-values.texinfo
+@include include/fun-alexandria-hash-table-keys.texinfo
+@include include/fun-alexandria-hash-table-values.texinfo
+@include include/fun-alexandria-hash-table-alist.texinfo
+@include include/fun-alexandria-hash-table-plist.texinfo
+@include include/fun-alexandria-alist-hash-table.texinfo
+@include include/fun-alexandria-plist-hash-table.texinfo
+
+@node Data and Control Flow
+@comment node-name, next, previous, up
+@chapter Data and Control Flow
+
+@include include/macro-alexandria-define-constant.texinfo
+@include include/macro-alexandria-destructuring-case.texinfo
+@include include/macro-alexandria-ensure-functionf.texinfo
+@include include/macro-alexandria-multiple-value-prog2.texinfo
+@include include/macro-alexandria-named-lambda.texinfo
+@include include/macro-alexandria-nth-value-or.texinfo
+@include include/macro-alexandria-if-let.texinfo
+@include include/macro-alexandria-when-let.texinfo
+@include include/macro-alexandria-when-let-star.texinfo
+@include include/macro-alexandria-switch.texinfo
+@include include/macro-alexandria-cswitch.texinfo
+@include include/macro-alexandria-eswitch.texinfo
+@include include/macro-alexandria-whichever.texinfo
+@include include/macro-alexandria-xor.texinfo
+
+@include include/fun-alexandria-disjoin.texinfo
+@include include/fun-alexandria-conjoin.texinfo
+@include include/fun-alexandria-compose.texinfo
+@include include/fun-alexandria-ensure-function.texinfo
+@include include/fun-alexandria-multiple-value-compose.texinfo
+@include include/fun-alexandria-curry.texinfo
+@include include/fun-alexandria-rcurry.texinfo
+
+@node Conses
+@comment node-name, next, previous, up
+@chapter Conses
+
+@include include/type-alexandria-proper-list.texinfo
+@include include/type-alexandria-circular-list.texinfo
+
+@include include/macro-alexandria-appendf.texinfo
+@include include/macro-alexandria-nconcf.texinfo
+@include include/macro-alexandria-remove-from-plistf.texinfo
+@include include/macro-alexandria-delete-from-plistf.texinfo
+@include include/macro-alexandria-reversef.texinfo
+@include include/macro-alexandria-nreversef.texinfo
+@include include/macro-alexandria-unionf.texinfo
+@include include/macro-alexandria-nunionf.texinfo
+
+@include include/macro-alexandria-doplist.texinfo
+
+@include include/fun-alexandria-circular-list-p.texinfo
+@include include/fun-alexandria-circular-tree-p.texinfo
+@include include/fun-alexandria-proper-list-p.texinfo
+
+@include include/fun-alexandria-alist-plist.texinfo
+@include include/fun-alexandria-plist-alist.texinfo
+@include include/fun-alexandria-circular-list.texinfo
+@include include/fun-alexandria-make-circular-list.texinfo
+@include include/fun-alexandria-ensure-car.texinfo
+@include include/fun-alexandria-ensure-cons.texinfo
+@include include/fun-alexandria-ensure-list.texinfo
+@include include/fun-alexandria-flatten.texinfo
+@include include/fun-alexandria-lastcar.texinfo
+@include include/fun-alexandria-setf-lastcar.texinfo
+@include include/fun-alexandria-proper-list-length.texinfo
+@include include/fun-alexandria-mappend.texinfo
+@include include/fun-alexandria-map-product.texinfo
+@include include/fun-alexandria-remove-from-plist.texinfo
+@include include/fun-alexandria-delete-from-plist.texinfo
+@include include/fun-alexandria-set-equal.texinfo
+@include include/fun-alexandria-setp.texinfo
+
+@node Sequences
+@comment node-name, next, previous, up
+@chapter Sequences
+
+@include include/type-alexandria-proper-sequence.texinfo
+
+@include include/macro-alexandria-deletef.texinfo
+@include include/macro-alexandria-removef.texinfo
+
+@include include/fun-alexandria-rotate.texinfo
+@include include/fun-alexandria-shuffle.texinfo
+@include include/fun-alexandria-random-elt.texinfo
+@include include/fun-alexandria-emptyp.texinfo
+@include include/fun-alexandria-sequence-of-length-p.texinfo
+@include include/fun-alexandria-length-equals.texinfo
+@include include/fun-alexandria-copy-sequence.texinfo
+@include include/fun-alexandria-first-elt.texinfo
+@include include/fun-alexandria-setf-first-elt.texinfo
+@include include/fun-alexandria-last-elt.texinfo
+@include include/fun-alexandria-setf-last-elt.texinfo
+@include include/fun-alexandria-starts-with.texinfo
+@include include/fun-alexandria-starts-with-subseq.texinfo
+@include include/fun-alexandria-ends-with.texinfo
+@include include/fun-alexandria-ends-with-subseq.texinfo
+@include include/fun-alexandria-map-combinations.texinfo
+@include include/fun-alexandria-map-derangements.texinfo
+@include include/fun-alexandria-map-permutations.texinfo
+
+@node IO
+@comment node-name, next, previous, up
+@chapter IO
+
+@include include/fun-alexandria-read-stream-content-into-string.texinfo
+@include include/fun-alexandria-read-file-into-string.texinfo
+@include include/fun-alexandria-read-stream-content-into-byte-vector.texinfo
+@include include/fun-alexandria-read-file-into-byte-vector.texinfo
+
+@node Macro Writing
+@comment node-name, next, previous, up
+@chapter Macro Writing
+
+@include include/macro-alexandria-once-only.texinfo
+@include include/macro-alexandria-with-gensyms.texinfo
+@include include/macro-alexandria-with-unique-names.texinfo
+@include include/fun-alexandria-featurep.texinfo
+@include include/fun-alexandria-parse-body.texinfo
+@include include/fun-alexandria-parse-ordinary-lambda-list.texinfo
+
+@node Symbols
+@comment node-name, next, previous, up
+@chapter Symbols
+
+@include include/fun-alexandria-ensure-symbol.texinfo
+@include include/fun-alexandria-format-symbol.texinfo
+@include include/fun-alexandria-make-keyword.texinfo
+@include include/fun-alexandria-make-gensym.texinfo
+@include include/fun-alexandria-make-gensym-list.texinfo
+@include include/fun-alexandria-symbolicate.texinfo
+
+@node Arrays
+@comment node-name, next, previous, up
+@chapter Arrays
+
+@include include/type-alexandria-array-index.texinfo
+@include include/type-alexandria-array-length.texinfo
+@include include/fun-alexandria-copy-array.texinfo
+
+@node Types
+@comment node-name, next, previous, up
+@chapter Types
+
+@include include/type-alexandria-string-designator.texinfo
+@include include/macro-alexandria-coercef.texinfo
+@include include/fun-alexandria-of-type.texinfo
+@include include/fun-alexandria-type-equals.texinfo
+
+@node Numbers
+@comment node-name, next, previous, up
+@chapter Numbers
+
+@include include/macro-alexandria-maxf.texinfo
+@include include/macro-alexandria-minf.texinfo
+
+@include include/fun-alexandria-binomial-coefficient.texinfo
+@include include/fun-alexandria-count-permutations.texinfo
+@include include/fun-alexandria-clamp.texinfo
+@include include/fun-alexandria-lerp.texinfo
+@include include/fun-alexandria-factorial.texinfo
+@include include/fun-alexandria-subfactorial.texinfo
+@include include/fun-alexandria-gaussian-random.texinfo
+@include include/fun-alexandria-iota.texinfo
+@include include/fun-alexandria-map-iota.texinfo
+@include include/fun-alexandria-mean.texinfo
+@include include/fun-alexandria-median.texinfo
+@include include/fun-alexandria-variance.texinfo
+@include include/fun-alexandria-standard-deviation.texinfo
+
+@bye
--- /dev/null
+;;; -*- lisp -*-
+
+;;;; A docstring extractor for the sbcl manual. Creates
+;;;; @include-ready documentation from the docstrings of exported
+;;;; symbols of specified packages.
+
+;;;; This software is part of the SBCL software system. SBCL is in the
+;;;; public domain and is provided with absolutely no warranty. See
+;;;; the COPYING file for more information.
+;;;;
+;;;; Written by Rudi Schlatte <rudi@constantly.at>, mangled
+;;;; by Nikodemus Siivola.
+
+;;;; TODO
+;;;; * Verbatim text
+;;;; * Quotations
+;;;; * Method documentation untested
+;;;; * Method sorting, somehow
+;;;; * Index for macros & constants?
+;;;; * This is getting complicated enough that tests would be good
+;;;; * Nesting (currently only nested itemizations work)
+;;;; * doc -> internal form -> texinfo (so that non-texinfo format are also
+;;;; easily generated)
+
+;;;; FIXME: The description below is no longer complete. This
+;;;; should possibly be turned into a contrib with proper documentation.
+
+;;;; Formatting heuristics (tweaked to format SAVE-LISP-AND-DIE sanely):
+;;;;
+;;;; Formats SYMBOL as @code{symbol}, or @var{symbol} if symbol is in
+;;;; the argument list of the defun / defmacro.
+;;;;
+;;;; Lines starting with * or - that are followed by intented lines
+;;;; are marked up with @itemize.
+;;;;
+;;;; Lines containing only a SYMBOL that are followed by indented
+;;;; lines are marked up as @table @code, with the SYMBOL as the item.
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (require 'sb-introspect))
+
+(defpackage :sb-texinfo
+ (:use :cl :sb-mop)
+ (:shadow #:documentation)
+ (:export #:generate-includes #:document-package)
+ (:documentation
+ "Tools to generate TexInfo documentation from docstrings."))
+
+(in-package :sb-texinfo)
+
+;;;; various specials and parameters
+
+(defvar *texinfo-output*)
+(defvar *texinfo-variables*)
+(defvar *documentation-package*)
+(defvar *base-package*)
+
+(defparameter *undocumented-packages* '(sb-pcl sb-int sb-kernel sb-sys sb-c))
+
+(defparameter *documentation-types*
+ '(compiler-macro
+ function
+ method-combination
+ setf
+ ;;structure ; also handled by `type'
+ type
+ variable)
+ "A list of symbols accepted as second argument of `documentation'")
+
+(defparameter *character-replacements*
+ '((#\* . "star") (#\/ . "slash") (#\+ . "plus")
+ (#\< . "lt") (#\> . "gt")
+ (#\= . "equals"))
+ "Characters and their replacement names that `alphanumize' uses. If
+the replacements contain any of the chars they're supposed to replace,
+you deserve to lose.")
+
+(defparameter *characters-to-drop* '(#\\ #\` #\')
+ "Characters that should be removed by `alphanumize'.")
+
+(defparameter *texinfo-escaped-chars* "@{}"
+ "Characters that must be escaped with #\@ for Texinfo.")
+
+(defparameter *itemize-start-characters* '(#\* #\-)
+ "Characters that might start an itemization in docstrings when
+ at the start of a line.")
+
+(defparameter *symbol-characters* "ABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890*:-+&#'"
+ "List of characters that make up symbols in a docstring.")
+
+(defparameter *symbol-delimiters* " ,.!?;")
+
+(defparameter *ordered-documentation-kinds*
+ '(package type structure condition class macro))
+
+;;;; utilities
+
+(defun flatten (list)
+ (cond ((null list)
+ nil)
+ ((consp (car list))
+ (nconc (flatten (car list)) (flatten (cdr list))))
+ ((null (cdr list))
+ (cons (car list) nil))
+ (t
+ (cons (car list) (flatten (cdr list))))))
+
+(defun whitespacep (char)
+ (find char #(#\tab #\space #\page)))
+
+(defun setf-name-p (name)
+ (or (symbolp name)
+ (and (listp name) (= 2 (length name)) (eq (car name) 'setf))))
+
+(defgeneric specializer-name (specializer))
+
+(defmethod specializer-name ((specializer eql-specializer))
+ (list 'eql (eql-specializer-object specializer)))
+
+(defmethod specializer-name ((specializer class))
+ (class-name specializer))
+
+(defun ensure-class-precedence-list (class)
+ (unless (class-finalized-p class)
+ (finalize-inheritance class))
+ (class-precedence-list class))
+
+(defun specialized-lambda-list (method)
+ ;; courtecy of AMOP p. 61
+ (let* ((specializers (method-specializers method))
+ (lambda-list (method-lambda-list method))
+ (n-required (length specializers)))
+ (append (mapcar (lambda (arg specializer)
+ (if (eq specializer (find-class 't))
+ arg
+ `(,arg ,(specializer-name specializer))))
+ (subseq lambda-list 0 n-required)
+ specializers)
+ (subseq lambda-list n-required))))
+
+(defun string-lines (string)
+ "Lines in STRING as a vector."
+ (coerce (with-input-from-string (s string)
+ (loop for line = (read-line s nil nil)
+ while line collect line))
+ 'vector))
+
+(defun indentation (line)
+ "Position of first non-SPACE character in LINE."
+ (position-if-not (lambda (c) (char= c #\Space)) line))
+
+(defun docstring (x doc-type)
+ (cl:documentation x doc-type))
+
+(defun flatten-to-string (list)
+ (format nil "~{~A~^-~}" (flatten list)))
+
+(defun alphanumize (original)
+ "Construct a string without characters like *`' that will f-star-ck
+up filename handling. See `*character-replacements*' and
+`*characters-to-drop*' for customization."
+ (let ((name (remove-if (lambda (x) (member x *characters-to-drop*))
+ (if (listp original)
+ (flatten-to-string original)
+ (string original))))
+ (chars-to-replace (mapcar #'car *character-replacements*)))
+ (flet ((replacement-delimiter (index)
+ (cond ((or (< index 0) (>= index (length name))) "")
+ ((alphanumericp (char name index)) "-")
+ (t ""))))
+ (loop for index = (position-if #'(lambda (x) (member x chars-to-replace))
+ name)
+ while index
+ do (setf name (concatenate 'string (subseq name 0 index)
+ (replacement-delimiter (1- index))
+ (cdr (assoc (aref name index)
+ *character-replacements*))
+ (replacement-delimiter (1+ index))
+ (subseq name (1+ index))))))
+ name))
+
+;;;; generating various names
+
+(defgeneric name (thing)
+ (:documentation "Name for a documented thing. Names are either
+symbols or lists of symbols."))
+
+(defmethod name ((symbol symbol))
+ symbol)
+
+(defmethod name ((cons cons))
+ cons)
+
+(defmethod name ((package package))
+ (short-package-name package))
+
+(defmethod name ((method method))
+ (list
+ (generic-function-name (method-generic-function method))
+ (method-qualifiers method)
+ (specialized-lambda-list method)))
+
+;;; Node names for DOCUMENTATION instances
+
+(defgeneric name-using-kind/name (kind name doc))
+
+(defmethod name-using-kind/name (kind (name string) doc)
+ (declare (ignore kind doc))
+ name)
+
+(defmethod name-using-kind/name (kind (name symbol) doc)
+ (declare (ignore kind))
+ (format nil "~@[~A:~]~A" (short-package-name (get-package doc)) name))
+
+(defmethod name-using-kind/name (kind (name list) doc)
+ (declare (ignore kind))
+ (assert (setf-name-p name))
+ (format nil "(setf ~@[~A:~]~A)" (short-package-name (get-package doc)) (second name)))
+
+(defmethod name-using-kind/name ((kind (eql 'method)) name doc)
+ (format nil "~A~{ ~A~} ~A"
+ (name-using-kind/name nil (first name) doc)
+ (second name)
+ (third name)))
+
+(defun node-name (doc)
+ "Returns TexInfo node name as a string for a DOCUMENTATION instance."
+ (let ((kind (get-kind doc)))
+ (format nil "~:(~A~) ~(~A~)" kind (name-using-kind/name kind (get-name doc) doc))))
+
+(defun short-package-name (package)
+ (unless (eq package *base-package*)
+ (car (sort (copy-list (cons (package-name package) (package-nicknames package)))
+ #'< :key #'length))))
+
+;;; Definition titles for DOCUMENTATION instances
+
+(defgeneric title-using-kind/name (kind name doc))
+
+(defmethod title-using-kind/name (kind (name string) doc)
+ (declare (ignore kind doc))
+ name)
+
+(defmethod title-using-kind/name (kind (name symbol) doc)
+ (declare (ignore kind))
+ (format nil "~@[~A:~]~A" (short-package-name (get-package doc)) name))
+
+(defmethod title-using-kind/name (kind (name list) doc)
+ (declare (ignore kind))
+ (assert (setf-name-p name))
+ (format nil "(setf ~@[~A:~]~A)" (short-package-name (get-package doc)) (second name)))
+
+(defmethod title-using-kind/name ((kind (eql 'method)) name doc)
+ (format nil "~{~A ~}~A"
+ (second name)
+ (title-using-kind/name nil (first name) doc)))
+
+(defun title-name (doc)
+ "Returns a string to be used as name of the definition."
+ (string-downcase (title-using-kind/name (get-kind doc) (get-name doc) doc)))
+
+(defun include-pathname (doc)
+ (let* ((kind (get-kind doc))
+ (name (nstring-downcase
+ (if (eq 'package kind)
+ (format nil "package-~A" (alphanumize (get-name doc)))
+ (format nil "~A-~A-~A"
+ (case (get-kind doc)
+ ((function generic-function) "fun")
+ (structure "struct")
+ (variable "var")
+ (otherwise (symbol-name (get-kind doc))))
+ (alphanumize (let ((*base-package* nil))
+ (short-package-name (get-package doc))))
+ (alphanumize (get-name doc)))))))
+ (make-pathname :name name :type "texinfo")))
+
+;;;; documentation class and related methods
+
+(defclass documentation ()
+ ((name :initarg :name :reader get-name)
+ (kind :initarg :kind :reader get-kind)
+ (string :initarg :string :reader get-string)
+ (children :initarg :children :initform nil :reader get-children)
+ (package :initform *documentation-package* :reader get-package)))
+
+(defmethod print-object ((documentation documentation) stream)
+ (print-unreadable-object (documentation stream :type t)
+ (princ (list (get-kind documentation) (get-name documentation)) stream)))
+
+(defgeneric make-documentation (x doc-type string))
+
+(defmethod make-documentation ((x package) doc-type string)
+ (declare (ignore doc-type))
+ (make-instance 'documentation
+ :name (name x)
+ :kind 'package
+ :string string))
+
+(defmethod make-documentation (x (doc-type (eql 'function)) string)
+ (declare (ignore doc-type))
+ (let* ((fdef (and (fboundp x) (fdefinition x)))
+ (name x)
+ (kind (cond ((and (symbolp x) (special-operator-p x))
+ 'special-operator)
+ ((and (symbolp x) (macro-function x))
+ 'macro)
+ ((typep fdef 'generic-function)
+ (assert (or (symbolp name) (setf-name-p name)))
+ 'generic-function)
+ (fdef
+ (assert (or (symbolp name) (setf-name-p name)))
+ 'function)))
+ (children (when (eq kind 'generic-function)
+ (collect-gf-documentation fdef))))
+ (make-instance 'documentation
+ :name (name x)
+ :string string
+ :kind kind
+ :children children)))
+
+(defmethod make-documentation ((x method) doc-type string)
+ (declare (ignore doc-type))
+ (make-instance 'documentation
+ :name (name x)
+ :kind 'method
+ :string string))
+
+(defmethod make-documentation (x (doc-type (eql 'type)) string)
+ (make-instance 'documentation
+ :name (name x)
+ :string string
+ :kind (etypecase (find-class x nil)
+ (structure-class 'structure)
+ (standard-class 'class)
+ (sb-pcl::condition-class 'condition)
+ ((or built-in-class null) 'type))))
+
+(defmethod make-documentation (x (doc-type (eql 'variable)) string)
+ (make-instance 'documentation
+ :name (name x)
+ :string string
+ :kind (if (constantp x)
+ 'constant
+ 'variable)))
+
+(defmethod make-documentation (x (doc-type (eql 'setf)) string)
+ (declare (ignore doc-type))
+ (make-instance 'documentation
+ :name (name x)
+ :kind 'setf-expander
+ :string string))
+
+(defmethod make-documentation (x doc-type string)
+ (make-instance 'documentation
+ :name (name x)
+ :kind doc-type
+ :string string))
+
+(defun maybe-documentation (x doc-type)
+ "Returns a DOCUMENTATION instance for X and DOC-TYPE, or NIL if
+there is no corresponding docstring."
+ (let ((docstring (docstring x doc-type)))
+ (when docstring
+ (make-documentation x doc-type docstring))))
+
+(defun lambda-list (doc)
+ (case (get-kind doc)
+ ((package constant variable type structure class condition nil)
+ nil)
+ (method
+ (third (get-name doc)))
+ (t
+ ;; KLUDGE: Eugh.
+ ;;
+ ;; believe it or not, the above comment was written before CSR
+ ;; came along and obfuscated this. (2005-07-04)
+ (when (symbolp (get-name doc))
+ (labels ((clean (x &key optional key)
+ (typecase x
+ (atom x)
+ ((cons (member &optional))
+ (cons (car x) (clean (cdr x) :optional t)))
+ ((cons (member &key))
+ (cons (car x) (clean (cdr x) :key t)))
+ ((cons (member &whole &environment))
+ ;; Skip these
+ (clean (cdr x) :optional optional :key key))
+ ((cons cons)
+ (cons
+ (cond (key (if (consp (caar x))
+ (caaar x)
+ (caar x)))
+ (optional (caar x))
+ (t (clean (car x))))
+ (clean (cdr x) :key key :optional optional)))
+ (cons
+ (cons
+ (cond ((or key optional) (car x))
+ (t (clean (car x))))
+ (clean (cdr x) :key key :optional optional))))))
+ (clean (sb-introspect:function-lambda-list (get-name doc))))))))
+
+(defun get-string-name (x)
+ (let ((name (get-name x)))
+ (cond ((symbolp name)
+ (symbol-name name))
+ ((and (consp name) (eq 'setf (car name)))
+ (symbol-name (second name)))
+ ((stringp name)
+ name)
+ (t
+ (error "Don't know which symbol to use for name ~S" name)))))
+
+(defun documentation< (x y)
+ (let ((p1 (position (get-kind x) *ordered-documentation-kinds*))
+ (p2 (position (get-kind y) *ordered-documentation-kinds*)))
+ (if (or (not (and p1 p2)) (= p1 p2))
+ (string< (get-string-name x) (get-string-name y))
+ (< p1 p2))))
+
+;;;; turning text into texinfo
+
+(defun escape-for-texinfo (string &optional downcasep)
+ "Return STRING with characters in *TEXINFO-ESCAPED-CHARS* escaped
+with #\@. Optionally downcase the result."
+ (let ((result (with-output-to-string (s)
+ (loop for char across string
+ when (find char *texinfo-escaped-chars*)
+ do (write-char #\@ s)
+ do (write-char char s)))))
+ (if downcasep (nstring-downcase result) result)))
+
+(defun empty-p (line-number lines)
+ (and (< -1 line-number (length lines))
+ (not (indentation (svref lines line-number)))))
+
+;;; line markups
+
+(defvar *not-symbols* '("ANSI" "CLHS"))
+
+(defun locate-symbols (line)
+ "Return a list of index pairs of symbol-like parts of LINE."
+ ;; This would be a good application for a regex ...
+ (let (result)
+ (flet ((grab (start end)
+ (unless (member (subseq line start end) '("ANSI" "CLHS"))
+ (push (list start end) result))))
+ (do ((begin nil)
+ (maybe-begin t)
+ (i 0 (1+ i)))
+ ((= i (length line))
+ ;; symbol at end of line
+ (when (and begin (or (> i (1+ begin))
+ (not (member (char line begin) '(#\A #\I)))))
+ (grab begin i))
+ (nreverse result))
+ (cond
+ ((and begin (find (char line i) *symbol-delimiters*))
+ ;; symbol end; remember it if it's not "A" or "I"
+ (when (or (> i (1+ begin)) (not (member (char line begin) '(#\A #\I))))
+ (grab begin i))
+ (setf begin nil
+ maybe-begin t))
+ ((and begin (not (find (char line i) *symbol-characters*)))
+ ;; Not a symbol: abort
+ (setf begin nil))
+ ((and maybe-begin (not begin) (find (char line i) *symbol-characters*))
+ ;; potential symbol begin at this position
+ (setf begin i
+ maybe-begin nil))
+ ((find (char line i) *symbol-delimiters*)
+ ;; potential symbol begin after this position
+ (setf maybe-begin t))
+ (t
+ ;; Not reading a symbol, not at potential start of symbol
+ (setf maybe-begin nil)))))))
+
+(defun texinfo-line (line)
+ "Format symbols in LINE texinfo-style: either as code or as
+variables if the symbol in question is contained in symbols
+*TEXINFO-VARIABLES*."
+ (with-output-to-string (result)
+ (let ((last 0))
+ (dolist (symbol/index (locate-symbols line))
+ (write-string (subseq line last (first symbol/index)) result)
+ (let ((symbol-name (apply #'subseq line symbol/index)))
+ (format result (if (member symbol-name *texinfo-variables*
+ :test #'string=)
+ "@var{~A}"
+ "@code{~A}")
+ (string-downcase symbol-name)))
+ (setf last (second symbol/index)))
+ (write-string (subseq line last) result))))
+
+;;; lisp sections
+
+(defun lisp-section-p (line line-number lines)
+ "Returns T if the given LINE looks like start of lisp code --
+ie. if it starts with whitespace followed by a paren or
+semicolon, and the previous line is empty"
+ (let ((offset (indentation line)))
+ (and offset
+ (plusp offset)
+ (find (find-if-not #'whitespacep line) "(;")
+ (empty-p (1- line-number) lines))))
+
+(defun collect-lisp-section (lines line-number)
+ (let ((lisp (loop for index = line-number then (1+ index)
+ for line = (and (< index (length lines)) (svref lines index))
+ while (indentation line)
+ collect line)))
+ (values (length lisp) `("@lisp" ,@lisp "@end lisp"))))
+
+;;; itemized sections
+
+(defun maybe-itemize-offset (line)
+ "Return NIL or the indentation offset if LINE looks like it starts
+an item in an itemization."
+ (let* ((offset (indentation line))
+ (char (when offset (char line offset))))
+ (and offset
+ (member char *itemize-start-characters* :test #'char=)
+ (char= #\Space (find-if-not (lambda (c) (char= c char))
+ line :start offset))
+ offset)))
+
+(defun collect-maybe-itemized-section (lines starting-line)
+ ;; Return index of next line to be processed outside
+ (let ((this-offset (maybe-itemize-offset (svref lines starting-line)))
+ (result nil)
+ (lines-consumed 0))
+ (loop for line-number from starting-line below (length lines)
+ for line = (svref lines line-number)
+ for indentation = (indentation line)
+ for offset = (maybe-itemize-offset line)
+ do (cond
+ ((not indentation)
+ ;; empty line -- inserts paragraph.
+ (push "" result)
+ (incf lines-consumed))
+ ((and offset (> indentation this-offset))
+ ;; nested itemization -- handle recursively
+ ;; FIXME: tables in itemizations go wrong
+ (multiple-value-bind (sub-lines-consumed sub-itemization)
+ (collect-maybe-itemized-section lines line-number)
+ (when sub-lines-consumed
+ (incf line-number (1- sub-lines-consumed)) ; +1 on next loop
+ (incf lines-consumed sub-lines-consumed)
+ (setf result (nconc (nreverse sub-itemization) result)))))
+ ((and offset (= indentation this-offset))
+ ;; start of new item
+ (push (format nil "@item ~A"
+ (texinfo-line (subseq line (1+ offset))))
+ result)
+ (incf lines-consumed))
+ ((and (not offset) (> indentation this-offset))
+ ;; continued item from previous line
+ (push (texinfo-line line) result)
+ (incf lines-consumed))
+ (t
+ ;; end of itemization
+ (loop-finish))))
+ ;; a single-line itemization isn't.
+ (if (> (count-if (lambda (line) (> (length line) 0)) result) 1)
+ (values lines-consumed `("@itemize" ,@(reverse result) "@end itemize"))
+ nil)))
+
+;;; table sections
+
+(defun tabulation-body-p (offset line-number lines)
+ (when (< line-number (length lines))
+ (let ((offset2 (indentation (svref lines line-number))))
+ (and offset2 (< offset offset2)))))
+
+(defun tabulation-p (offset line-number lines direction)
+ (let ((step (ecase direction
+ (:backwards (1- line-number))
+ (:forwards (1+ line-number)))))
+ (when (and (plusp line-number) (< line-number (length lines)))
+ (and (eql offset (indentation (svref lines line-number)))
+ (or (when (eq direction :backwards)
+ (empty-p step lines))
+ (tabulation-p offset step lines direction)
+ (tabulation-body-p offset step lines))))))
+
+(defun maybe-table-offset (line-number lines)
+ "Return NIL or the indentation offset if LINE looks like it starts
+an item in a tabulation. Ie, if it is (1) indented, (2) preceded by an
+empty line, another tabulation label, or a tabulation body, (3) and
+followed another tabulation label or a tabulation body."
+ (let* ((line (svref lines line-number))
+ (offset (indentation line))
+ (prev (1- line-number))
+ (next (1+ line-number)))
+ (when (and offset (plusp offset))
+ (and (or (empty-p prev lines)
+ (tabulation-body-p offset prev lines)
+ (tabulation-p offset prev lines :backwards))
+ (or (tabulation-body-p offset next lines)
+ (tabulation-p offset next lines :forwards))
+ offset))))
+
+;;; FIXME: This and itemization are very similar: could they share
+;;; some code, mayhap?
+
+(defun collect-maybe-table-section (lines starting-line)
+ ;; Return index of next line to be processed outside
+ (let ((this-offset (maybe-table-offset starting-line lines))
+ (result nil)
+ (lines-consumed 0))
+ (loop for line-number from starting-line below (length lines)
+ for line = (svref lines line-number)
+ for indentation = (indentation line)
+ for offset = (maybe-table-offset line-number lines)
+ do (cond
+ ((not indentation)
+ ;; empty line -- inserts paragraph.
+ (push "" result)
+ (incf lines-consumed))
+ ((and offset (= indentation this-offset))
+ ;; start of new item, or continuation of previous item
+ (if (and result (search "@item" (car result) :test #'char=))
+ (push (format nil "@itemx ~A" (texinfo-line line))
+ result)
+ (progn
+ (push "" result)
+ (push (format nil "@item ~A" (texinfo-line line))
+ result)))
+ (incf lines-consumed))
+ ((> indentation this-offset)
+ ;; continued item from previous line
+ (push (texinfo-line line) result)
+ (incf lines-consumed))
+ (t
+ ;; end of itemization
+ (loop-finish))))
+ ;; a single-line table isn't.
+ (if (> (count-if (lambda (line) (> (length line) 0)) result) 1)
+ (values lines-consumed
+ `("" "@table @emph" ,@(reverse result) "@end table" ""))
+ nil)))
+
+;;; section markup
+
+(defmacro with-maybe-section (index &rest forms)
+ `(multiple-value-bind (count collected) (progn ,@forms)
+ (when count
+ (dolist (line collected)
+ (write-line line *texinfo-output*))
+ (incf ,index (1- count)))))
+
+(defun write-texinfo-string (string &optional lambda-list)
+ "Try to guess as much formatting for a raw docstring as possible."
+ (let ((*texinfo-variables* (flatten lambda-list))
+ (lines (string-lines (escape-for-texinfo string nil))))
+ (loop for line-number from 0 below (length lines)
+ for line = (svref lines line-number)
+ do (cond
+ ((with-maybe-section line-number
+ (and (lisp-section-p line line-number lines)
+ (collect-lisp-section lines line-number))))
+ ((with-maybe-section line-number
+ (and (maybe-itemize-offset line)
+ (collect-maybe-itemized-section lines line-number))))
+ ((with-maybe-section line-number
+ (and (maybe-table-offset line-number lines)
+ (collect-maybe-table-section lines line-number))))
+ (t
+ (write-line (texinfo-line line) *texinfo-output*))))))
+
+;;;; texinfo formatting tools
+
+(defun hide-superclass-p (class-name super-name)
+ (let ((super-package (symbol-package super-name)))
+ (or
+ ;; KLUDGE: We assume that we don't want to advertise internal
+ ;; classes in CP-lists, unless the symbol we're documenting is
+ ;; internal as well.
+ (and (member super-package #.'(mapcar #'find-package *undocumented-packages*))
+ (not (eq super-package (symbol-package class-name))))
+ ;; KLUDGE: We don't generally want to advertise SIMPLE-ERROR or
+ ;; SIMPLE-CONDITION in the CPLs of conditions that inherit them
+ ;; simply as a matter of convenience. The assumption here is that
+ ;; the inheritance is incidental unless the name of the condition
+ ;; begins with SIMPLE-.
+ (and (member super-name '(simple-error simple-condition))
+ (let ((prefix "SIMPLE-"))
+ (mismatch prefix (string class-name) :end2 (length prefix)))
+ t ; don't return number from MISMATCH
+ ))))
+
+(defun hide-slot-p (symbol slot)
+ ;; FIXME: There is no pricipal reason to avoid the slot docs fo
+ ;; structures and conditions, but their DOCUMENTATION T doesn't
+ ;; currently work with them the way we'd like.
+ (not (and (typep (find-class symbol nil) 'standard-class)
+ (docstring slot t))))
+
+(defun texinfo-anchor (doc)
+ (format *texinfo-output* "@anchor{~A}~%" (node-name doc)))
+
+;;; KLUDGE: &AUX *PRINT-PRETTY* here means "no linebreaks please"
+(defun texinfo-begin (doc &aux *print-pretty*)
+ (let ((kind (get-kind doc)))
+ (format *texinfo-output* "@~A {~:(~A~)} ~({~A}~@[ ~{~A~^ ~}~]~)~%"
+ (case kind
+ ((package constant variable)
+ "defvr")
+ ((structure class condition type)
+ "deftp")
+ (t
+ "deffn"))
+ (map 'string (lambda (char) (if (eql char #\-) #\Space char)) (string kind))
+ (title-name doc)
+ ;; &foo would be amusingly bold in the pdf thanks to TeX/Texinfo
+ ;; interactions,so we escape the ampersand -- amusingly for TeX.
+ ;; sbcl.texinfo defines macros that expand @&key and friends to &key.
+ (mapcar (lambda (name)
+ (if (member name lambda-list-keywords)
+ (format nil "@~A" name)
+ name))
+ (lambda-list doc)))))
+
+(defun texinfo-index (doc)
+ (let ((title (title-name doc)))
+ (case (get-kind doc)
+ ((structure type class condition)
+ (format *texinfo-output* "@tindex ~A~%" title))
+ ((variable constant)
+ (format *texinfo-output* "@vindex ~A~%" title))
+ ((compiler-macro function method-combination macro generic-function)
+ (format *texinfo-output* "@findex ~A~%" title)))))
+
+(defun texinfo-inferred-body (doc)
+ (when (member (get-kind doc) '(class structure condition))
+ (let ((name (get-name doc)))
+ ;; class precedence list
+ (format *texinfo-output* "Class precedence list: @code{~(~{@lw{~A}~^, ~}~)}~%~%"
+ (remove-if (lambda (class) (hide-superclass-p name class))
+ (mapcar #'class-name (ensure-class-precedence-list (find-class name)))))
+ ;; slots
+ (let ((slots (remove-if (lambda (slot) (hide-slot-p name slot))
+ (class-direct-slots (find-class name)))))
+ (when slots
+ (format *texinfo-output* "Slots:~%@itemize~%")
+ (dolist (slot slots)
+ (format *texinfo-output*
+ "@item ~(@code{~A}~#[~:; --- ~]~
+ ~:{~2*~@[~2:*~A~P: ~{@code{@w{~S}}~^, ~}~]~:^; ~}~)~%~%"
+ (slot-definition-name slot)
+ (remove
+ nil
+ (mapcar
+ (lambda (name things)
+ (if things
+ (list name (length things) things)))
+ '("initarg" "reader" "writer")
+ (list
+ (slot-definition-initargs slot)
+ (slot-definition-readers slot)
+ (slot-definition-writers slot)))))
+ ;; FIXME: Would be neater to handler as children
+ (write-texinfo-string (docstring slot t)))
+ (format *texinfo-output* "@end itemize~%~%"))))))
+
+(defun texinfo-body (doc)
+ (write-texinfo-string (get-string doc)))
+
+(defun texinfo-end (doc)
+ (write-line (case (get-kind doc)
+ ((package variable constant) "@end defvr")
+ ((structure type class condition) "@end deftp")
+ (t "@end deffn"))
+ *texinfo-output*))
+
+(defun write-texinfo (doc)
+ "Writes TexInfo for a DOCUMENTATION instance to *TEXINFO-OUTPUT*."
+ (texinfo-anchor doc)
+ (texinfo-begin doc)
+ (texinfo-index doc)
+ (texinfo-inferred-body doc)
+ (texinfo-body doc)
+ (texinfo-end doc)
+ ;; FIXME: Children should be sorted one way or another
+ (mapc #'write-texinfo (get-children doc)))
+
+;;;; main logic
+
+(defun collect-gf-documentation (gf)
+ "Collects method documentation for the generic function GF"
+ (loop for method in (generic-function-methods gf)
+ for doc = (maybe-documentation method t)
+ when doc
+ collect doc))
+
+(defun collect-name-documentation (name)
+ (loop for type in *documentation-types*
+ for doc = (maybe-documentation name type)
+ when doc
+ collect doc))
+
+(defun collect-symbol-documentation (symbol)
+ "Collects all docs for a SYMBOL and (SETF SYMBOL), returns a list of
+the form DOC instances. See `*documentation-types*' for the possible
+values of doc-type."
+ (nconc (collect-name-documentation symbol)
+ (collect-name-documentation (list 'setf symbol))))
+
+(defun collect-documentation (package)
+ "Collects all documentation for all external symbols of the given
+package, as well as for the package itself."
+ (let* ((*documentation-package* (find-package package))
+ (docs nil))
+ (check-type package package)
+ (do-external-symbols (symbol package)
+ (setf docs (nconc (collect-symbol-documentation symbol) docs)))
+ (let ((doc (maybe-documentation *documentation-package* t)))
+ (when doc
+ (push doc docs)))
+ docs))
+
+(defmacro with-texinfo-file (pathname &body forms)
+ `(with-open-file (*texinfo-output* ,pathname
+ :direction :output
+ :if-does-not-exist :create
+ :if-exists :supersede)
+ ,@forms))
+
+(defun write-ifnottex ()
+ ;; We use @&key, etc to escape & from TeX in lambda lists -- so we need to
+ ;; define them for info as well.
+ (flet ((macro (name)
+ (let ((string (string-downcase name)))
+ (format *texinfo-output* "@macro ~A~%~A~%@end macro~%" string string))))
+ (macro '&allow-other-keys)
+ (macro '&optional)
+ (macro '&rest)
+ (macro '&key)
+ (macro '&body)))
+
+(defun generate-includes (directory packages &key (base-package :cl-user))
+ "Create files in `directory' containing Texinfo markup of all
+docstrings of each exported symbol in `packages'. `directory' is
+created if necessary. If you supply a namestring that doesn't end in a
+slash, you lose. The generated files are of the form
+\"<doc-type>_<packagename>_<symbol-name>.texinfo\" and can be included
+via @include statements. Texinfo syntax-significant characters are
+escaped in symbol names, but if a docstring contains invalid Texinfo
+markup, you lose."
+ (handler-bind ((warning #'muffle-warning))
+ (let ((directory (merge-pathnames (pathname directory)))
+ (*base-package* (find-package base-package)))
+ (ensure-directories-exist directory)
+ (dolist (package packages)
+ (dolist (doc (collect-documentation (find-package package)))
+ (with-texinfo-file (merge-pathnames (include-pathname doc) directory)
+ (write-texinfo doc))))
+ (with-texinfo-file (merge-pathnames "ifnottex.texinfo" directory)
+ (write-ifnottex))
+ directory)))
+
+(defun document-package (package &optional filename)
+ "Create a file containing all available documentation for the
+exported symbols of `package' in Texinfo format. If `filename' is not
+supplied, a file \"<packagename>.texinfo\" is generated.
+
+The definitions can be referenced using Texinfo statements like
+@ref{<doc-type>_<packagename>_<symbol-name>.texinfo}. Texinfo
+syntax-significant characters are escaped in symbol names, but if a
+docstring contains invalid Texinfo markup, you lose."
+ (handler-bind ((warning #'muffle-warning))
+ (let* ((package (find-package package))
+ (filename (or filename (make-pathname
+ :name (string-downcase (short-package-name package))
+ :type "texinfo")))
+ (docs (sort (collect-documentation package) #'documentation<)))
+ (with-texinfo-file filename
+ (dolist (doc docs)
+ (write-texinfo doc)))
+ filename)))
--- /dev/null
+(in-package :alexandria)
+
+(defun featurep (feature-expression)
+ "Returns T if the argument matches the state of the *FEATURES*
+list and NIL if it does not. FEATURE-EXPRESSION can be any atom
+or list acceptable to the reader macros #+ and #-."
+ (etypecase feature-expression
+ (symbol (not (null (member feature-expression *features*))))
+ (cons (check-type (first feature-expression) symbol)
+ (eswitch ((first feature-expression) :test 'string=)
+ (:and (every #'featurep (rest feature-expression)))
+ (:or (some #'featurep (rest feature-expression)))
+ (:not (assert (= 2 (length feature-expression)))
+ (not (featurep (second feature-expression))))))))
--- /dev/null
+(in-package :alexandria)
+
+;;; To propagate return type and allow the compiler to eliminate the IF when
+;;; it is known if the argument is function or not.
+(declaim (inline ensure-function))
+
+(declaim (ftype (function (t) (values function &optional))
+ ensure-function))
+(defun ensure-function (function-designator)
+ "Returns the function designated by FUNCTION-DESIGNATOR:
+if FUNCTION-DESIGNATOR is a function, it is returned, otherwise
+it must be a function name and its FDEFINITION is returned."
+ (if (functionp function-designator)
+ function-designator
+ (fdefinition function-designator)))
+
+(define-modify-macro ensure-functionf/1 () ensure-function)
+
+(defmacro ensure-functionf (&rest places)
+ "Multiple-place modify macro for ENSURE-FUNCTION: ensures that each of
+PLACES contains a function."
+ `(progn ,@(mapcar (lambda (x) `(ensure-functionf/1 ,x)) places)))
+
+(defun disjoin (predicate &rest more-predicates)
+ "Returns a function that applies each of PREDICATE and MORE-PREDICATE
+functions in turn to its arguments, returning the primary value of the first
+predicate that returns true, without calling the remaining predicates.
+If none of the predicates returns true, NIL is returned."
+ (declare (optimize (speed 3) (safety 1) (debug 1)))
+ (let ((predicate (ensure-function predicate))
+ (more-predicates (mapcar #'ensure-function more-predicates)))
+ (lambda (&rest arguments)
+ (or (apply predicate arguments)
+ (some (lambda (p)
+ (declare (type function p))
+ (apply p arguments))
+ more-predicates)))))
+
+(defun conjoin (predicate &rest more-predicates)
+ "Returns a function that applies each of PREDICATE and MORE-PREDICATE
+functions in turn to its arguments, returning NIL if any of the predicates
+returns false, without calling the remaining predicates. If none of the
+predicates returns false, returns the primary value of the last predicate."
+ (if (null more-predicates)
+ predicate
+ (lambda (&rest arguments)
+ (and (apply predicate arguments)
+ ;; Cannot simply use CL:EVERY because we want to return the
+ ;; non-NIL value of the last predicate if all succeed.
+ (do ((tail (cdr more-predicates) (cdr tail))
+ (head (car more-predicates) (car tail)))
+ ((not tail)
+ (apply head arguments))
+ (unless (apply head arguments)
+ (return nil)))))))
+
+
+(defun compose (function &rest more-functions)
+ "Returns a function composed of FUNCTION and MORE-FUNCTIONS that applies its
+arguments to to each in turn, starting from the rightmost of MORE-FUNCTIONS,
+and then calling the next one with the primary value of the last."
+ (declare (optimize (speed 3) (safety 1) (debug 1)))
+ (reduce (lambda (f g)
+ (let ((f (ensure-function f))
+ (g (ensure-function g)))
+ (lambda (&rest arguments)
+ (declare (dynamic-extent arguments))
+ (funcall f (apply g arguments)))))
+ more-functions
+ :initial-value function))
+
+(define-compiler-macro compose (function &rest more-functions)
+ (labels ((compose-1 (funs)
+ (if (cdr funs)
+ `(funcall ,(car funs) ,(compose-1 (cdr funs)))
+ `(apply ,(car funs) arguments))))
+ (let* ((args (cons function more-functions))
+ (funs (make-gensym-list (length args) "COMPOSE")))
+ `(let ,(loop for f in funs for arg in args
+ collect `(,f (ensure-function ,arg)))
+ (declare (optimize (speed 3) (safety 1) (debug 1)))
+ (lambda (&rest arguments)
+ (declare (dynamic-extent arguments))
+ ,(compose-1 funs))))))
+
+(defun multiple-value-compose (function &rest more-functions)
+ "Returns a function composed of FUNCTION and MORE-FUNCTIONS that applies
+its arguments to each in turn, starting from the rightmost of
+MORE-FUNCTIONS, and then calling the next one with all the return values of
+the last."
+ (declare (optimize (speed 3) (safety 1) (debug 1)))
+ (reduce (lambda (f g)
+ (let ((f (ensure-function f))
+ (g (ensure-function g)))
+ (lambda (&rest arguments)
+ (declare (dynamic-extent arguments))
+ (multiple-value-call f (apply g arguments)))))
+ more-functions
+ :initial-value function))
+
+(define-compiler-macro multiple-value-compose (function &rest more-functions)
+ (labels ((compose-1 (funs)
+ (if (cdr funs)
+ `(multiple-value-call ,(car funs) ,(compose-1 (cdr funs)))
+ `(apply ,(car funs) arguments))))
+ (let* ((args (cons function more-functions))
+ (funs (make-gensym-list (length args) "MV-COMPOSE")))
+ `(let ,(mapcar #'list funs args)
+ (declare (optimize (speed 3) (safety 1) (debug 1)))
+ (lambda (&rest arguments)
+ (declare (dynamic-extent arguments))
+ ,(compose-1 funs))))))
+
+(declaim (inline curry rcurry))
+
+(defun curry (function &rest arguments)
+ "Returns a function that applies ARGUMENTS and the arguments
+it is called with to FUNCTION."
+ (declare (optimize (speed 3) (safety 1)))
+ (let ((fn (ensure-function function)))
+ (lambda (&rest more)
+ (declare (dynamic-extent more))
+ ;; Using M-V-C we don't need to append the arguments.
+ (multiple-value-call fn (values-list arguments) (values-list more)))))
+
+(define-compiler-macro curry (function &rest arguments)
+ (let ((curries (make-gensym-list (length arguments) "CURRY"))
+ (fun (gensym "FUN")))
+ `(let ((,fun (ensure-function ,function))
+ ,@(mapcar #'list curries arguments))
+ (declare (optimize (speed 3) (safety 1)))
+ (lambda (&rest more)
+ (declare (dynamic-extent more))
+ (apply ,fun ,@curries more)))))
+
+(defun rcurry (function &rest arguments)
+ "Returns a function that applies the arguments it is called
+with and ARGUMENTS to FUNCTION."
+ (declare (optimize (speed 3) (safety 1)))
+ (let ((fn (ensure-function function)))
+ (lambda (&rest more)
+ (declare (dynamic-extent more))
+ (multiple-value-call fn (values-list more) (values-list arguments)))))
+
+(define-compiler-macro rcurry (function &rest arguments)
+ (let ((rcurries (make-gensym-list (length arguments) "RCURRY"))
+ (fun (gensym "FUN")))
+ `(let ((,fun (ensure-function ,function))
+ ,@(mapcar #'list rcurries arguments))
+ (declare (optimize (speed 3) (safety 1)))
+ (lambda (&rest more)
+ (declare (dynamic-extent more))
+ (multiple-value-call ,fun (values-list more) ,@rcurries)))))
+
+(declaim (notinline curry rcurry))
+
+(defmacro named-lambda (name lambda-list &body body)
+ "Expands into a lambda-expression within whose BODY NAME denotes the
+corresponding function."
+ `(labels ((,name ,lambda-list ,@body))
+ #',name))
\ No newline at end of file
--- /dev/null
+(in-package :alexandria)
+
+(defun copy-hash-table (table &key key test size
+ rehash-size rehash-threshold)
+ "Returns a copy of hash table TABLE, with the same keys and values
+as the TABLE. The copy has the same properties as the original, unless
+overridden by the keyword arguments.
+
+Before each of the original values is set into the new hash-table, KEY
+is invoked on the value. As KEY defaults to CL:IDENTITY, a shallow
+copy is returned by default."
+ (setf key (or key 'identity))
+ (setf test (or test (hash-table-test table)))
+ (setf size (or size (hash-table-size table)))
+ (setf rehash-size (or rehash-size (hash-table-rehash-size table)))
+ (setf rehash-threshold (or rehash-threshold (hash-table-rehash-threshold table)))
+ (let ((copy (make-hash-table :test test :size size
+ :rehash-size rehash-size
+ :rehash-threshold rehash-threshold)))
+ (maphash (lambda (k v)
+ (setf (gethash k copy) (funcall key v)))
+ table)
+ copy))
+
+(declaim (inline maphash-keys))
+(defun maphash-keys (function table)
+ "Like MAPHASH, but calls FUNCTION with each key in the hash table TABLE."
+ (maphash (lambda (k v)
+ (declare (ignore v))
+ (funcall function k))
+ table))
+
+(declaim (inline maphash-values))
+(defun maphash-values (function table)
+ "Like MAPHASH, but calls FUNCTION with each value in the hash table TABLE."
+ (maphash (lambda (k v)
+ (declare (ignore k))
+ (funcall function v))
+ table))
+
+(defun hash-table-keys (table)
+ "Returns a list containing the keys of hash table TABLE."
+ (let ((keys nil))
+ (maphash-keys (lambda (k)
+ (push k keys))
+ table)
+ keys))
+
+(defun hash-table-values (table)
+ "Returns a list containing the values of hash table TABLE."
+ (let ((values nil))
+ (maphash-values (lambda (v)
+ (push v values))
+ table)
+ values))
+
+(defun hash-table-alist (table)
+ "Returns an association list containing the keys and values of hash table
+TABLE."
+ (let ((alist nil))
+ (maphash (lambda (k v)
+ (push (cons k v) alist))
+ table)
+ alist))
+
+(defun hash-table-plist (table)
+ "Returns a property list containing the keys and values of hash table
+TABLE."
+ (let ((plist nil))
+ (maphash (lambda (k v)
+ (setf plist (list* k v plist)))
+ table)
+ plist))
+
+(defun alist-hash-table (alist &rest hash-table-initargs)
+ "Returns a hash table containing the keys and values of the association list
+ALIST. Hash table is initialized using the HASH-TABLE-INITARGS."
+ (let ((table (apply #'make-hash-table hash-table-initargs)))
+ (dolist (cons alist)
+ (setf (gethash (car cons) table) (cdr cons)))
+ table))
+
+(defun plist-hash-table (plist &rest hash-table-initargs)
+ "Returns a hash table containing the keys and values of the property list
+PLIST. Hash table is initialized using the HASH-TABLE-INITARGS."
+ (let ((table (apply #'make-hash-table hash-table-initargs)))
+ (do ((tail plist (cddr tail)))
+ ((not tail))
+ (setf (gethash (car tail) table) (cadr tail)))
+ table))
+
+(defmacro ensure-gethash (key hash-table &optional default)
+ "Like GETHASH, but if KEY is not found in the HASH-TABLE saves the DEFAULT
+under key before returning it. Secondary return value is true if key was
+already in the table."
+ (once-only (key hash-table)
+ (with-unique-names (value presentp)
+ `(multiple-value-bind (,value ,presentp) (gethash ,key ,hash-table)
+ (if ,presentp
+ (values ,value ,presentp)
+ (values (setf (gethash ,key ,hash-table) ,default) nil))))))
--- /dev/null
+;; Copyright (c) 2002-2006, Edward Marco Baringer
+;; All rights reserved.
+
+(in-package :alexandria)
+
+(defmacro with-open-file* ((stream filespec &key direction element-type
+ if-exists if-does-not-exist external-format)
+ &body body)
+ "Just like WITH-OPEN-FILE, but NIL values in the keyword arguments mean to use
+the default value specified for OPEN."
+ (once-only (direction element-type if-exists if-does-not-exist external-format)
+ `(with-open-stream
+ (,stream (apply #'open ,filespec
+ (append
+ (when ,direction
+ (list :direction ,direction))
+ (when ,element-type
+ (list :element-type ,element-type))
+ (when ,if-exists
+ (list :if-exists ,if-exists))
+ (when ,if-does-not-exist
+ (list :if-does-not-exist ,if-does-not-exist))
+ (when ,external-format
+ (list :external-format ,external-format)))))
+ ,@body)))
+
+(defmacro with-input-from-file ((stream-name file-name &rest args
+ &key (direction nil direction-p)
+ &allow-other-keys)
+ &body body)
+ "Evaluate BODY with STREAM-NAME to an input stream on the file
+FILE-NAME. ARGS is sent as is to the call to OPEN except EXTERNAL-FORMAT,
+which is only sent to WITH-OPEN-FILE when it's not NIL."
+ (declare (ignore direction))
+ (when direction-p
+ (error "Can't specify :DIRECTION for WITH-INPUT-FROM-FILE."))
+ `(with-open-file* (,stream-name ,file-name :direction :input ,@args)
+ ,@body))
+
+(defmacro with-output-to-file ((stream-name file-name &rest args
+ &key (direction nil direction-p)
+ &allow-other-keys)
+ &body body)
+ "Evaluate BODY with STREAM-NAME to an output stream on the file
+FILE-NAME. ARGS is sent as is to the call to OPEN except EXTERNAL-FORMAT,
+which is only sent to WITH-OPEN-FILE when it's not NIL."
+ (declare (ignore direction))
+ (when direction-p
+ (error "Can't specify :DIRECTION for WITH-OUTPUT-TO-FILE."))
+ `(with-open-file* (,stream-name ,file-name :direction :output ,@args)
+ ,@body))
+
+(defun read-stream-content-into-string (stream &key (buffer-size 4096))
+ "Return the \"content\" of STREAM as a fresh string."
+ (check-type buffer-size positive-integer)
+ (let ((*print-pretty* nil))
+ (with-output-to-string (datum)
+ (let ((buffer (make-array buffer-size :element-type 'character)))
+ (loop
+ :for bytes-read = (read-sequence buffer stream)
+ :do (write-sequence buffer datum :start 0 :end bytes-read)
+ :while (= bytes-read buffer-size))))))
+
+(defun read-file-into-string (pathname &key (buffer-size 4096) external-format)
+ "Return the contents of the file denoted by PATHNAME as a fresh string.
+
+The EXTERNAL-FORMAT parameter will be passed directly to WITH-OPEN-FILE
+unless it's NIL, which means the system default."
+ (with-input-from-file
+ (file-stream pathname :external-format external-format)
+ (read-stream-content-into-string file-stream :buffer-size buffer-size)))
+
+(defun write-string-into-file (string pathname &key (if-exists :error)
+ if-does-not-exist
+ external-format)
+ "Write STRING to PATHNAME.
+
+The EXTERNAL-FORMAT parameter will be passed directly to WITH-OPEN-FILE
+unless it's NIL, which means the system default."
+ (with-output-to-file (file-stream pathname :if-exists if-exists
+ :if-does-not-exist if-does-not-exist
+ :external-format external-format)
+ (write-sequence string file-stream)))
+
+(defun read-stream-content-into-byte-vector (stream &key ((%length length))
+ (initial-size 4096))
+ "Return \"content\" of STREAM as freshly allocated (unsigned-byte 8) vector."
+ (check-type length (or null non-negative-integer))
+ (check-type initial-size positive-integer)
+ (do ((buffer (make-array (or length initial-size)
+ :element-type '(unsigned-byte 8)))
+ (offset 0)
+ (offset-wanted 0))
+ ((or (/= offset-wanted offset)
+ (and length (>= offset length)))
+ (if (= offset (length buffer))
+ buffer
+ (subseq buffer 0 offset)))
+ (unless (zerop offset)
+ (let ((new-buffer (make-array (* 2 (length buffer))
+ :element-type '(unsigned-byte 8))))
+ (replace new-buffer buffer)
+ (setf buffer new-buffer)))
+ (setf offset-wanted (length buffer)
+ offset (read-sequence buffer stream :start offset))))
+
+(defun read-file-into-byte-vector (pathname)
+ "Read PATHNAME into a freshly allocated (unsigned-byte 8) vector."
+ (with-input-from-file (stream pathname :element-type '(unsigned-byte 8))
+ (read-stream-content-into-byte-vector stream '%length (file-length stream))))
+
+(defun write-byte-vector-into-file (bytes pathname &key (if-exists :error)
+ if-does-not-exist)
+ "Write BYTES to PATHNAME."
+ (check-type bytes (vector (unsigned-byte 8)))
+ (with-output-to-file (stream pathname :if-exists if-exists
+ :if-does-not-exist if-does-not-exist
+ :element-type '(unsigned-byte 8))
+ (write-sequence bytes stream)))
+
+(defun copy-file (from to &key (if-to-exists :supersede)
+ (element-type '(unsigned-byte 8)) finish-output)
+ (with-input-from-file (input from :element-type element-type)
+ (with-output-to-file (output to :element-type element-type
+ :if-exists if-to-exists)
+ (copy-stream input output
+ :element-type element-type
+ :finish-output finish-output))))
+
+(defun copy-stream (input output &key (element-type (stream-element-type input))
+ (buffer-size 4096)
+ (buffer (make-array buffer-size :element-type element-type))
+ (start 0) end
+ finish-output)
+ "Reads data from INPUT and writes it to OUTPUT. Both INPUT and OUTPUT must
+be streams, they will be passed to READ-SEQUENCE and WRITE-SEQUENCE and must have
+compatible element-types."
+ (check-type start non-negative-integer)
+ (check-type end (or null non-negative-integer))
+ (check-type buffer-size positive-integer)
+ (when (and end
+ (< end start))
+ (error "END is smaller than START in ~S" 'copy-stream))
+ (let ((output-position 0)
+ (input-position 0))
+ (unless (zerop start)
+ ;; FIXME add platform specific optimization to skip seekable streams
+ (loop while (< input-position start)
+ do (let ((n (read-sequence buffer input
+ :end (min (length buffer)
+ (- start input-position)))))
+ (when (zerop n)
+ (error "~@<Could not read enough bytes from the input to fulfill ~
+ the :START ~S requirement in ~S.~:@>" 'copy-stream start))
+ (incf input-position n))))
+ (assert (= input-position start))
+ (loop while (or (null end) (< input-position end))
+ do (let ((n (read-sequence buffer input
+ :end (when end
+ (min (length buffer)
+ (- end input-position))))))
+ (when (zerop n)
+ (if end
+ (error "~@<Could not read enough bytes from the input to fulfill ~
+ the :END ~S requirement in ~S.~:@>" 'copy-stream end)
+ (return)))
+ (incf input-position n)
+ (write-sequence buffer output :end n)
+ (incf output-position n)))
+ (when finish-output
+ (finish-output output))
+ output-position))
--- /dev/null
+(in-package :alexandria)
+
+(declaim (inline safe-endp))
+(defun safe-endp (x)
+ (declare (optimize safety))
+ (endp x))
+
+(defun alist-plist (alist)
+ "Returns a property list containing the same keys and values as the
+association list ALIST in the same order."
+ (let (plist)
+ (dolist (pair alist)
+ (push (car pair) plist)
+ (push (cdr pair) plist))
+ (nreverse plist)))
+
+(defun plist-alist (plist)
+ "Returns an association list containing the same keys and values as the
+property list PLIST in the same order."
+ (let (alist)
+ (do ((tail plist (cddr tail)))
+ ((safe-endp tail) (nreverse alist))
+ (push (cons (car tail) (cadr tail)) alist))))
+
+(declaim (inline racons))
+(defun racons (key value ralist)
+ (acons value key ralist))
+
+(macrolet
+ ((define-alist-get (name get-entry get-value-from-entry add doc)
+ `(progn
+ (declaim (inline ,name))
+ (defun ,name (alist key &key (test 'eql))
+ ,doc
+ (let ((entry (,get-entry key alist :test test)))
+ (values (,get-value-from-entry entry) entry)))
+ (define-setf-expander ,name (place key &key (test ''eql)
+ &environment env)
+ (multiple-value-bind
+ (temporary-variables initforms newvals setter getter)
+ (get-setf-expansion place env)
+ (when (cdr newvals)
+ (error "~A cannot store multiple values in one place" ',name))
+ (with-unique-names (new-value key-val test-val alist entry)
+ (values
+ (append temporary-variables
+ (list alist
+ key-val
+ test-val
+ entry))
+ (append initforms
+ (list getter
+ key
+ test
+ `(,',get-entry ,key-val ,alist :test ,test-val)))
+ `(,new-value)
+ `(cond
+ (,entry
+ (setf (,',get-value-from-entry ,entry) ,new-value))
+ (t
+ (let ,newvals
+ (setf ,(first newvals) (,',add ,key ,new-value ,alist))
+ ,setter
+ ,new-value)))
+ `(,',get-value-from-entry ,entry))))))))
+ (define-alist-get assoc-value assoc cdr acons
+"ASSOC-VALUE is an alist accessor very much like ASSOC, but it can
+be used with SETF.")
+ (define-alist-get rassoc-value rassoc car racons
+"RASSOC-VALUE is an alist accessor very much like RASSOC, but it can
+be used with SETF."))
+
+(defun malformed-plist (plist)
+ (error "Malformed plist: ~S" plist))
+
+(defmacro doplist ((key val plist &optional values) &body body)
+ "Iterates over elements of PLIST. BODY can be preceded by
+declarations, and is like a TAGBODY. RETURN may be used to terminate
+the iteration early. If RETURN is not used, returns VALUES."
+ (multiple-value-bind (forms declarations) (parse-body body)
+ (with-gensyms (tail loop results)
+ `(block nil
+ (flet ((,results ()
+ (let (,key ,val)
+ (declare (ignorable ,key ,val))
+ (return ,values))))
+ (let* ((,tail ,plist)
+ (,key (if ,tail
+ (pop ,tail)
+ (,results)))
+ (,val (if ,tail
+ (pop ,tail)
+ (malformed-plist ',plist))))
+ (declare (ignorable ,key ,val))
+ ,@declarations
+ (tagbody
+ ,loop
+ ,@forms
+ (setf ,key (if ,tail
+ (pop ,tail)
+ (,results))
+ ,val (if ,tail
+ (pop ,tail)
+ (malformed-plist ',plist)))
+ (go ,loop))))))))
+
+(define-modify-macro appendf (&rest lists) append
+ "Modify-macro for APPEND. Appends LISTS to the place designated by the first
+argument.")
+
+(define-modify-macro nconcf (&rest lists) nconc
+ "Modify-macro for NCONC. Concatenates LISTS to place designated by the first
+argument.")
+
+(define-modify-macro unionf (list &rest args) union
+ "Modify-macro for UNION. Saves the union of LIST and the contents of the
+place designated by the first argument to the designated place.")
+
+(define-modify-macro nunionf (list &rest args) nunion
+ "Modify-macro for NUNION. Saves the union of LIST and the contents of the
+place designated by the first argument to the designated place. May modify
+either argument.")
+
+(define-modify-macro reversef () reverse
+ "Modify-macro for REVERSE. Copies and reverses the list stored in the given
+place and saves back the result into the place.")
+
+(define-modify-macro nreversef () nreverse
+ "Modify-macro for NREVERSE. Reverses the list stored in the given place by
+destructively modifying it and saves back the result into the place.")
+
+(defun circular-list (&rest elements)
+ "Creates a circular list of ELEMENTS."
+ (let ((cycle (copy-list elements)))
+ (nconc cycle cycle)))
+
+(defun circular-list-p (object)
+ "Returns true if OBJECT is a circular list, NIL otherwise."
+ (and (listp object)
+ (do ((fast object (cddr fast))
+ (slow (cons (car object) (cdr object)) (cdr slow)))
+ (nil)
+ (unless (and (consp fast) (listp (cdr fast)))
+ (return nil))
+ (when (eq fast slow)
+ (return t)))))
+
+(defun circular-tree-p (object)
+ "Returns true if OBJECT is a circular tree, NIL otherwise."
+ (labels ((circularp (object seen)
+ (and (consp object)
+ (do ((fast (cons (car object) (cdr object)) (cddr fast))
+ (slow object (cdr slow)))
+ (nil)
+ (when (or (eq fast slow) (member slow seen))
+ (return-from circular-tree-p t))
+ (when (or (not (consp fast)) (not (consp (cdr slow))))
+ (return
+ (do ((tail object (cdr tail)))
+ ((not (consp tail))
+ nil)
+ (let ((elt (car tail)))
+ (circularp elt (cons object seen))))))))))
+ (circularp object nil)))
+
+(defun proper-list-p (object)
+ "Returns true if OBJECT is a proper list."
+ (cond ((not object)
+ t)
+ ((consp object)
+ (do ((fast object (cddr fast))
+ (slow (cons (car object) (cdr object)) (cdr slow)))
+ (nil)
+ (unless (and (listp fast) (consp (cdr fast)))
+ (return (and (listp fast) (not (cdr fast)))))
+ (when (eq fast slow)
+ (return nil))))
+ (t
+ nil)))
+
+(deftype proper-list ()
+ "Type designator for proper lists. Implemented as a SATISFIES type, hence
+not recommended for performance intensive use. Main usefullness as a type
+designator of the expected type in a TYPE-ERROR."
+ `(and list (satisfies proper-list-p)))
+
+(defun circular-list-error (list)
+ (error 'type-error
+ :datum list
+ :expected-type '(and list (not circular-list))))
+
+(macrolet ((def (name lambda-list doc step declare ret1 ret2)
+ (assert (member 'list lambda-list))
+ `(defun ,name ,lambda-list
+ ,doc
+ (do ((last list fast)
+ (fast list (cddr fast))
+ (slow (cons (car list) (cdr list)) (cdr slow))
+ ,@(when step (list step)))
+ (nil)
+ (declare (dynamic-extent slow) ,@(when declare (list declare))
+ (ignorable last))
+ (when (safe-endp fast)
+ (return ,ret1))
+ (when (safe-endp (cdr fast))
+ (return ,ret2))
+ (when (eq fast slow)
+ (circular-list-error list))))))
+ (def proper-list-length (list)
+ "Returns length of LIST, signalling an error if it is not a proper list."
+ (n 1 (+ n 2))
+ ;; KLUDGE: Most implementations don't actually support lists with bignum
+ ;; elements -- and this is WAY faster on most implementations then declaring
+ ;; N to be an UNSIGNED-BYTE.
+ (fixnum n)
+ (1- n)
+ n)
+
+ (def lastcar (list)
+ "Returns the last element of LIST. Signals a type-error if LIST is not a
+proper list."
+ nil
+ nil
+ (cadr last)
+ (car fast))
+
+ (def (setf lastcar) (object list)
+ "Sets the last element of LIST. Signals a type-error if LIST is not a proper
+list."
+ nil
+ nil
+ (setf (cadr last) object)
+ (setf (car fast) object)))
+
+(defun make-circular-list (length &key initial-element)
+ "Creates a circular list of LENGTH with the given INITIAL-ELEMENT."
+ (let ((cycle (make-list length :initial-element initial-element)))
+ (nconc cycle cycle)))
+
+(deftype circular-list ()
+ "Type designator for circular lists. Implemented as a SATISFIES type, so not
+recommended for performance intensive use. Main usefullness as the
+expected-type designator of a TYPE-ERROR."
+ `(satisfies circular-list-p))
+
+(defun ensure-car (thing)
+ "If THING is a CONS, its CAR is returned. Otherwise THING is returned."
+ (if (consp thing)
+ (car thing)
+ thing))
+
+(defun ensure-cons (cons)
+ "If CONS is a cons, it is returned. Otherwise returns a fresh cons with CONS
+ in the car, and NIL in the cdr."
+ (if (consp cons)
+ cons
+ (cons cons nil)))
+
+(defun ensure-list (list)
+ "If LIST is a list, it is returned. Otherwise returns the list designated by LIST."
+ (if (listp list)
+ list
+ (list list)))
+
+(defun remove-from-plist (plist &rest keys)
+ "Returns a propery-list with same keys and values as PLIST, except that keys
+in the list designated by KEYS and values corresponding to them are removed.
+The returned property-list may share structure with the PLIST, but PLIST is
+not destructively modified. Keys are compared using EQ."
+ (declare (optimize (speed 3)))
+ ;; FIXME: possible optimization: (remove-from-plist '(:x 0 :a 1 :b 2) :a)
+ ;; could return the tail without consing up a new list.
+ (loop for (key . rest) on plist by #'cddr
+ do (assert rest () "Expected a proper plist, got ~S" plist)
+ unless (member key keys :test #'eq)
+ collect key and collect (first rest)))
+
+(defun delete-from-plist (plist &rest keys)
+ "Just like REMOVE-FROM-PLIST, but this version may destructively modify the
+provided plist."
+ (declare (optimize speed))
+ (loop with head = plist
+ with tail = nil ; a nil tail means an empty result so far
+ for (key . rest) on plist by #'cddr
+ do (assert rest () "Expected a proper plist, got ~S" plist)
+ (if (member key keys :test #'eq)
+ ;; skip over this pair
+ (let ((next (cdr rest)))
+ (if tail
+ (setf (cdr tail) next)
+ (setf head next)))
+ ;; keep this pair
+ (setf tail rest))
+ finally (return head)))
+
+(define-modify-macro remove-from-plistf (&rest keys) remove-from-plist
+ "Modify macro for REMOVE-FROM-PLIST.")
+(define-modify-macro delete-from-plistf (&rest keys) delete-from-plist
+ "Modify macro for DELETE-FROM-PLIST.")
+
+(declaim (inline sans))
+(defun sans (plist &rest keys)
+ "Alias of REMOVE-FROM-PLIST for backward compatibility."
+ (apply #'remove-from-plist plist keys))
+
+(defun mappend (function &rest lists)
+ "Applies FUNCTION to respective element(s) of each LIST, appending all the
+all the result list to a single list. FUNCTION must return a list."
+ (loop for results in (apply #'mapcar function lists)
+ append results))
+
+(defun setp (object &key (test #'eql) (key #'identity))
+ "Returns true if OBJECT is a list that denotes a set, NIL otherwise. A list
+denotes a set if each element of the list is unique under KEY and TEST."
+ (and (listp object)
+ (let (seen)
+ (dolist (elt object t)
+ (let ((key (funcall key elt)))
+ (if (member key seen :test test)
+ (return nil)
+ (push key seen)))))))
+
+(defun set-equal (list1 list2 &key (test #'eql) (key nil keyp))
+ "Returns true if every element of LIST1 matches some element of LIST2 and
+every element of LIST2 matches some element of LIST1. Otherwise returns false."
+ (let ((keylist1 (if keyp (mapcar key list1) list1))
+ (keylist2 (if keyp (mapcar key list2) list2)))
+ (and (dolist (elt keylist1 t)
+ (or (member elt keylist2 :test test)
+ (return nil)))
+ (dolist (elt keylist2 t)
+ (or (member elt keylist1 :test test)
+ (return nil))))))
+
+(defun map-product (function list &rest more-lists)
+ "Returns a list containing the results of calling FUNCTION with one argument
+from LIST, and one from each of MORE-LISTS for each combination of arguments.
+In other words, returns the product of LIST and MORE-LISTS using FUNCTION.
+
+Example:
+
+ (map-product 'list '(1 2) '(3 4) '(5 6))
+ => ((1 3 5) (1 3 6) (1 4 5) (1 4 6)
+ (2 3 5) (2 3 6) (2 4 5) (2 4 6))
+"
+ (labels ((%map-product (f lists)
+ (let ((more (cdr lists))
+ (one (car lists)))
+ (if (not more)
+ (mapcar f one)
+ (mappend (lambda (x)
+ (%map-product (curry f x) more))
+ one)))))
+ (%map-product (ensure-function function) (cons list more-lists))))
+
+(defun flatten (tree)
+ "Traverses the tree in order, collecting non-null leaves into a list."
+ (let (list)
+ (labels ((traverse (subtree)
+ (when subtree
+ (if (consp subtree)
+ (progn
+ (traverse (car subtree))
+ (traverse (cdr subtree)))
+ (push subtree list)))))
+ (traverse tree))
+ (nreverse list)))
--- /dev/null
+(in-package :alexandria)
+
+(defmacro with-gensyms (names &body forms)
+ "Binds each variable named by a symbol in NAMES to a unique symbol around
+FORMS. Each of NAMES must either be either a symbol, or of the form:
+
+ (symbol string-designator)
+
+Bare symbols appearing in NAMES are equivalent to:
+
+ (symbol symbol)
+
+The string-designator is used as the argument to GENSYM when constructing the
+unique symbol the named variable will be bound to."
+ `(let ,(mapcar (lambda (name)
+ (multiple-value-bind (symbol string)
+ (etypecase name
+ (symbol
+ (values name (symbol-name name)))
+ ((cons symbol (cons string-designator null))
+ (values (first name) (string (second name)))))
+ `(,symbol (gensym ,string))))
+ names)
+ ,@forms))
+
+(defmacro with-unique-names (names &body forms)
+ "Alias for WITH-GENSYMS."
+ `(with-gensyms ,names ,@forms))
+
+(defmacro once-only (specs &body forms)
+ "Evaluates FORMS with symbols specified in SPECS rebound to temporary
+variables, ensuring that each initform is evaluated only once.
+
+Each of SPECS must either be a symbol naming the variable to be rebound, or of
+the form:
+
+ (symbol initform)
+
+Bare symbols in SPECS are equivalent to
+
+ (symbol symbol)
+
+Example:
+
+ (defmacro cons1 (x) (once-only (x) `(cons ,x ,x)))
+ (let ((y 0)) (cons1 (incf y))) => (1 . 1)
+"
+ (let ((gensyms (make-gensym-list (length specs) "ONCE-ONLY"))
+ (names-and-forms (mapcar (lambda (spec)
+ (etypecase spec
+ (list
+ (destructuring-bind (name form) spec
+ (cons name form)))
+ (symbol
+ (cons spec spec))))
+ specs)))
+ ;; bind in user-macro
+ `(let ,(mapcar (lambda (g n) (list g `(gensym ,(string (car n)))))
+ gensyms names-and-forms)
+ ;; bind in final expansion
+ `(let (,,@(mapcar (lambda (g n)
+ ``(,,g ,,(cdr n)))
+ gensyms names-and-forms))
+ ;; bind in user-macro
+ ,(let ,(mapcar (lambda (n g) (list (car n) g))
+ names-and-forms gensyms)
+ ,@forms)))))
+
+(defun parse-body (body &key documentation whole)
+ "Parses BODY into (values remaining-forms declarations doc-string).
+Documentation strings are recognized only if DOCUMENTATION is true.
+Syntax errors in body are signalled and WHOLE is used in the signal
+arguments when given."
+ (let ((doc nil)
+ (decls nil)
+ (current nil))
+ (tagbody
+ :declarations
+ (setf current (car body))
+ (when (and documentation (stringp current) (cdr body))
+ (if doc
+ (error "Too many documentation strings in ~S." (or whole body))
+ (setf doc (pop body)))
+ (go :declarations))
+ (when (and (listp current) (eql (first current) 'declare))
+ (push (pop body) decls)
+ (go :declarations)))
+ (values body (nreverse decls) doc)))
+
+(defun parse-ordinary-lambda-list (lambda-list &key (normalize t)
+ allow-specializers
+ (normalize-optional normalize)
+ (normalize-keyword normalize)
+ (normalize-auxilary normalize))
+ "Parses an ordinary lambda-list, returning as multiple values:
+
+1. Required parameters.
+
+2. Optional parameter specifications, normalized into form:
+
+ (name init suppliedp)
+
+3. Name of the rest parameter, or NIL.
+
+4. Keyword parameter specifications, normalized into form:
+
+ ((keyword-name name) init suppliedp)
+
+5. Boolean indicating &ALLOW-OTHER-KEYS presence.
+
+6. &AUX parameter specifications, normalized into form
+
+ (name init).
+
+7. Existence of &KEY in the lambda-list.
+
+Signals a PROGRAM-ERROR is the lambda-list is malformed."
+ (let ((state :required)
+ (allow-other-keys nil)
+ (auxp nil)
+ (required nil)
+ (optional nil)
+ (rest nil)
+ (keys nil)
+ (keyp nil)
+ (aux nil))
+ (labels ((fail (elt)
+ (simple-program-error "Misplaced ~S in ordinary lambda-list:~% ~S"
+ elt lambda-list))
+ (check-variable (elt what &optional (allow-specializers allow-specializers))
+ (unless (and (or (symbolp elt)
+ (and allow-specializers
+ (consp elt) (= 2 (length elt)) (symbolp (first elt))))
+ (not (constantp elt)))
+ (simple-program-error "Invalid ~A ~S in ordinary lambda-list:~% ~S"
+ what elt lambda-list)))
+ (check-spec (spec what)
+ (destructuring-bind (init suppliedp) spec
+ (declare (ignore init))
+ (check-variable suppliedp what nil))))
+ (dolist (elt lambda-list)
+ (case elt
+ (&optional
+ (if (eq state :required)
+ (setf state elt)
+ (fail elt)))
+ (&rest
+ (if (member state '(:required &optional))
+ (setf state elt)
+ (fail elt)))
+ (&key
+ (if (member state '(:required &optional :after-rest))
+ (setf state elt)
+ (fail elt))
+ (setf keyp t))
+ (&allow-other-keys
+ (if (eq state '&key)
+ (setf allow-other-keys t
+ state elt)
+ (fail elt)))
+ (&aux
+ (cond ((eq state '&rest)
+ (fail elt))
+ (auxp
+ (simple-program-error "Multiple ~S in ordinary lambda-list:~% ~S"
+ elt lambda-list))
+ (t
+ (setf auxp t
+ state elt))
+ ))
+ (otherwise
+ (when (member elt '#.(set-difference lambda-list-keywords
+ '(&optional &rest &key &allow-other-keys &aux)))
+ (simple-program-error
+ "Bad lambda-list keyword ~S in ordinary lambda-list:~% ~S"
+ elt lambda-list))
+ (case state
+ (:required
+ (check-variable elt "required parameter")
+ (push elt required))
+ (&optional
+ (cond ((consp elt)
+ (destructuring-bind (name &rest tail) elt
+ (check-variable name "optional parameter")
+ (cond ((cdr tail)
+ (check-spec tail "optional-supplied-p parameter"))
+ ((and normalize-optional tail)
+ (setf elt (append elt '(nil))))
+ (normalize-optional
+ (setf elt (append elt '(nil nil)))))))
+ (t
+ (check-variable elt "optional parameter")
+ (when normalize-optional
+ (setf elt (cons elt '(nil nil))))))
+ (push (ensure-list elt) optional))
+ (&rest
+ (check-variable elt "rest parameter")
+ (setf rest elt
+ state :after-rest))
+ (&key
+ (cond ((consp elt)
+ (destructuring-bind (var-or-kv &rest tail) elt
+ (cond ((consp var-or-kv)
+ (destructuring-bind (keyword var) var-or-kv
+ (unless (symbolp keyword)
+ (simple-program-error "Invalid keyword name ~S in ordinary ~
+ lambda-list:~% ~S"
+ keyword lambda-list))
+ (check-variable var "keyword parameter")))
+ (t
+ (check-variable var-or-kv "keyword parameter")
+ (when normalize-keyword
+ (setf var-or-kv (list (make-keyword var-or-kv) var-or-kv)))))
+ (cond ((cdr tail)
+ (check-spec tail "keyword-supplied-p parameter"))
+ ((and normalize-keyword tail)
+ (setf tail (append tail '(nil))))
+ (normalize-keyword
+ (setf tail '(nil nil))))
+ (setf elt (cons var-or-kv tail))))
+ (t
+ (check-variable elt "keyword parameter")
+ (setf elt (if normalize-keyword
+ (list (list (make-keyword elt) elt) nil nil)
+ elt))))
+ (push elt keys))
+ (&aux
+ (if (consp elt)
+ (destructuring-bind (var &optional init) elt
+ (declare (ignore init))
+ (check-variable var "&aux parameter"))
+ (progn
+ (check-variable elt "&aux parameter")
+ (setf elt (list* elt (when normalize-auxilary
+ '(nil))))))
+ (push elt aux))
+ (t
+ (simple-program-error "Invalid ordinary lambda-list:~% ~S" lambda-list)))))))
+ (values (nreverse required) (nreverse optional) rest (nreverse keys)
+ allow-other-keys (nreverse aux) keyp)))
+
+;;;; DESTRUCTURING-*CASE
+
+(defun expand-destructuring-case (key clauses case)
+ (once-only (key)
+ `(if (typep ,key 'cons)
+ (,case (car ,key)
+ ,@(mapcar (lambda (clause)
+ (destructuring-bind ((keys . lambda-list) &body body) clause
+ `(,keys
+ (destructuring-bind ,lambda-list (cdr ,key)
+ ,@body))))
+ clauses))
+ (error "Invalid key to DESTRUCTURING-~S: ~S" ',case ,key))))
+
+(defmacro destructuring-case (keyform &body clauses)
+ "DESTRUCTURING-CASE, -CCASE, and -ECASE are a combination of CASE and DESTRUCTURING-BIND.
+KEYFORM must evaluate to a CONS.
+
+Clauses are of the form:
+
+ ((CASE-KEYS . DESTRUCTURING-LAMBDA-LIST) FORM*)
+
+The clause whose CASE-KEYS matches CAR of KEY, as if by CASE, CCASE, or ECASE,
+is selected, and FORMs are then executed with CDR of KEY is destructured and
+bound by the DESTRUCTURING-LAMBDA-LIST.
+
+Example:
+
+ (defun dcase (x)
+ (destructuring-case x
+ ((:foo a b)
+ (format nil \"foo: ~S, ~S\" a b))
+ ((:bar &key a b)
+ (format nil \"bar, ~S, ~S\" a b))
+ (((:alt1 :alt2) a)
+ (format nil \"alt: ~S\" a))
+ ((t &rest rest)
+ (format nil \"unknown: ~S\" rest))))
+
+ (dcase (list :foo 1 2)) ; => \"foo: 1, 2\"
+ (dcase (list :bar :a 1 :b 2)) ; => \"bar: 1, 2\"
+ (dcase (list :alt1 1)) ; => \"alt: 1\"
+ (dcase (list :alt2 2)) ; => \"alt: 2\"
+ (dcase (list :quux 1 2 3)) ; => \"unknown: 1, 2, 3\"
+
+ (defun decase (x)
+ (destructuring-case x
+ ((:foo a b)
+ (format nil \"foo: ~S, ~S\" a b))
+ ((:bar &key a b)
+ (format nil \"bar, ~S, ~S\" a b))
+ (((:alt1 :alt2) a)
+ (format nil \"alt: ~S\" a))))
+
+ (decase (list :foo 1 2)) ; => \"foo: 1, 2\"
+ (decase (list :bar :a 1 :b 2)) ; => \"bar: 1, 2\"
+ (decase (list :alt1 1)) ; => \"alt: 1\"
+ (decase (list :alt2 2)) ; => \"alt: 2\"
+ (decase (list :quux 1 2 3)) ; =| error
+"
+ (expand-destructuring-case keyform clauses 'case))
+
+(defmacro destructuring-ccase (keyform &body clauses)
+ (expand-destructuring-case keyform clauses 'ccase))
+
+(defmacro destructuring-ecase (keyform &body clauses)
+ (expand-destructuring-case keyform clauses 'ecase))
+
+(dolist (name '(destructuring-ccase destructuring-ecase))
+ (setf (documentation name 'function) (documentation 'destructuring-case 'function)))
+
+
+
--- /dev/null
+(in-package :alexandria)
+
+(declaim (inline clamp))
+(defun clamp (number min max)
+ "Clamps the NUMBER into [min, max] range. Returns MIN if NUMBER is lesser then
+MIN and MAX if NUMBER is greater then MAX, otherwise returns NUMBER."
+ (if (< number min)
+ min
+ (if (> number max)
+ max
+ number)))
+
+(defun gaussian-random (&optional min max)
+ "Returns two gaussian random double floats as the primary and secondary value,
+optionally constrained by MIN and MAX. Gaussian random numbers form a standard
+normal distribution around 0.0d0.
+
+Sufficiently positive MIN or negative MAX will cause the algorithm used to
+take a very long time. If MIN is positive it should be close to zero, and
+similarly if MAX is negative it should be close to zero."
+ (macrolet
+ ((valid (x)
+ `(<= (or min ,x) ,x (or max ,x)) ))
+ (labels
+ ((gauss ()
+ (loop
+ for x1 = (- (random 2.0d0) 1.0d0)
+ for x2 = (- (random 2.0d0) 1.0d0)
+ for w = (+ (expt x1 2) (expt x2 2))
+ when (< w 1.0d0)
+ do (let ((v (sqrt (/ (* -2.0d0 (log w)) w))))
+ (return (values (* x1 v) (* x2 v))))))
+ (guard (x)
+ (unless (valid x)
+ (tagbody
+ :retry
+ (multiple-value-bind (x1 x2) (gauss)
+ (when (valid x1)
+ (setf x x1)
+ (go :done))
+ (when (valid x2)
+ (setf x x2)
+ (go :done))
+ (go :retry))
+ :done))
+ x))
+ (multiple-value-bind
+ (g1 g2) (gauss)
+ (values (guard g1) (guard g2))))))
+
+(declaim (inline iota))
+(defun iota (n &key (start 0) (step 1))
+ "Return a list of n numbers, starting from START (with numeric contagion
+from STEP applied), each consequtive number being the sum of the previous one
+and STEP. START defaults to 0 and STEP to 1.
+
+Examples:
+
+ (iota 4) => (0 1 2 3)
+ (iota 3 :start 1 :step 1.0) => (1.0 2.0 3.0)
+ (iota 3 :start -1 :step -1/2) => (-1 -3/2 -2)
+"
+ (declare (type (integer 0) n) (number start step))
+ (loop repeat n
+ ;; KLUDGE: get numeric contagion right for the first element too
+ for i = (+ (- (+ start step) step)) then (+ i step)
+ collect i))
+
+(declaim (inline map-iota))
+(defun map-iota (function n &key (start 0) (step 1))
+ "Calls FUNCTION with N numbers, starting from START (with numeric contagion
+from STEP applied), each consequtive number being the sum of the previous one
+and STEP. START defaults to 0 and STEP to 1. Returns N.
+
+Examples:
+
+ (map-iota #'print 3 :start 1 :step 1.0) => 3
+ ;;; 1.0
+ ;;; 2.0
+ ;;; 3.0
+"
+ (declare (type (integer 0) n) (number start step))
+ (loop repeat n
+ ;; KLUDGE: get numeric contagion right for the first element too
+ for i = (+ start (- step step)) then (+ i step)
+ do (funcall function i))
+ n)
+
+(declaim (inline lerp))
+(defun lerp (v a b)
+ "Returns the result of linear interpolation between A and B, using the
+interpolation coefficient V."
+ ;; The correct version is numerically stable, at the expense of an
+ ;; extra multiply. See (lerp 0.1 4 25) with (+ a (* v (- b a))). The
+ ;; unstable version can often be converted to a fast instruction on
+ ;; a lot of machines, though this is machine/implementation
+ ;; specific. As alexandria is more about correct code, than
+ ;; efficiency, and we're only talking about a single extra multiply,
+ ;; many would prefer the stable version
+ (+ (* (- 1.0 v) a) (* v b)))
+
+(declaim (inline mean))
+(defun mean (sample)
+ "Returns the mean of SAMPLE. SAMPLE must be a sequence of numbers."
+ (/ (reduce #'+ sample) (length sample)))
+
+(declaim (inline median))
+(defun median (sample)
+ "Returns median of SAMPLE. SAMPLE must be a sequence of real numbers."
+ (let* ((vector (sort (copy-sequence 'vector sample) #'<))
+ (length (length vector))
+ (middle (truncate length 2)))
+ (if (oddp length)
+ (aref vector middle)
+ (/ (+ (aref vector middle) (aref vector (1- middle))) 2))))
+
+(declaim (inline variance))
+(defun variance (sample &key (biased t))
+ "Variance of SAMPLE. Returns the biased variance if BIASED is true (the default),
+and the unbiased estimator of variance if BIASED is false. SAMPLE must be a
+sequence of numbers."
+ (let ((mean (mean sample)))
+ (/ (reduce (lambda (a b)
+ (+ a (expt (- b mean) 2)))
+ sample
+ :initial-value 0)
+ (- (length sample) (if biased 0 1)))))
+
+(declaim (inline standard-deviation))
+(defun standard-deviation (sample &key (biased t))
+ "Standard deviation of SAMPLE. Returns the biased standard deviation if
+BIASED is true (the default), and the square root of the unbiased estimator
+for variance if BIASED is false (which is not the same as the unbiased
+estimator for standard deviation). SAMPLE must be a sequence of numbers."
+ (sqrt (variance sample :biased biased)))
+
+(define-modify-macro maxf (&rest numbers) max
+ "Modify-macro for MAX. Sets place designated by the first argument to the
+maximum of its original value and NUMBERS.")
+
+(define-modify-macro minf (&rest numbers) min
+ "Modify-macro for MIN. Sets place designated by the first argument to the
+minimum of its original value and NUMBERS.")
+
+;;;; Factorial
+
+;;; KLUDGE: This is really dependant on the numbers in question: for
+;;; small numbers this is larger, and vice versa. Ideally instead of a
+;;; constant we would have RANGE-FAST-TO-MULTIPLY-DIRECTLY-P.
+(defconstant +factorial-bisection-range-limit+ 8)
+
+;;; KLUDGE: This is really platform dependant: ideally we would use
+;;; (load-time-value (find-good-direct-multiplication-limit)) instead.
+(defconstant +factorial-direct-multiplication-limit+ 13)
+
+(defun %multiply-range (i j)
+ ;; We use a a bit of cleverness here:
+ ;;
+ ;; 1. For large factorials we bisect in order to avoid expensive bignum
+ ;; multiplications: 1 x 2 x 3 x ... runs into bignums pretty soon,
+ ;; and once it does that all further multiplications will be with bignums.
+ ;;
+ ;; By instead doing the multiplication in a tree like
+ ;; ((1 x 2) x (3 x 4)) x ((5 x 6) x (7 x 8))
+ ;; we manage to get less bignums.
+ ;;
+ ;; 2. Division isn't exactly free either, however, so we don't bisect
+ ;; all the way down, but multiply ranges of integers close to each
+ ;; other directly.
+ ;;
+ ;; For even better results it should be possible to use prime
+ ;; factorization magic, but Nikodemus ran out of steam.
+ ;;
+ ;; KLUDGE: We support factorials of bignums, but it seems quite
+ ;; unlikely anyone would ever be able to use them on a modern lisp,
+ ;; since the resulting numbers are unlikely to fit in memory... but
+ ;; it would be extremely unelegant to define FACTORIAL only on
+ ;; fixnums, _and_ on lisps with 16 bit fixnums this can actually be
+ ;; needed.
+ (labels ((bisect (j k)
+ (declare (type (integer 1 #.most-positive-fixnum) j k))
+ (if (< (- k j) +factorial-bisection-range-limit+)
+ (multiply-range j k)
+ (let ((middle (+ j (truncate (- k j) 2))))
+ (* (bisect j middle)
+ (bisect (+ middle 1) k)))))
+ (bisect-big (j k)
+ (declare (type (integer 1) j k))
+ (if (= j k)
+ j
+ (let ((middle (+ j (truncate (- k j) 2))))
+ (* (if (<= middle most-positive-fixnum)
+ (bisect j middle)
+ (bisect-big j middle))
+ (bisect-big (+ middle 1) k)))))
+ (multiply-range (j k)
+ (declare (type (integer 1 #.most-positive-fixnum) j k))
+ (do ((f k (* f m))
+ (m (1- k) (1- m)))
+ ((< m j) f)
+ (declare (type (integer 0 (#.most-positive-fixnum)) m)
+ (type unsigned-byte f)))))
+ (if (and (typep i 'fixnum) (typep j 'fixnum))
+ (bisect i j)
+ (bisect-big i j))))
+
+(declaim (inline factorial))
+(defun %factorial (n)
+ (if (< n 2)
+ 1
+ (%multiply-range 1 n)))
+
+(defun factorial (n)
+ "Factorial of non-negative integer N."
+ (check-type n (integer 0))
+ (%factorial n))
+
+;;;; Combinatorics
+
+(defun binomial-coefficient (n k)
+ "Binomial coefficient of N and K, also expressed as N choose K. This is the
+number of K element combinations given N choises. N must be equal to or
+greater then K."
+ (check-type n (integer 0))
+ (check-type k (integer 0))
+ (assert (>= n k))
+ (if (or (zerop k) (= n k))
+ 1
+ (let ((n-k (- n k)))
+ ;; Swaps K and N-K if K < N-K because the algorithm
+ ;; below is faster for bigger K and smaller N-K
+ (when (< k n-k)
+ (rotatef k n-k))
+ (if (= 1 n-k)
+ n
+ ;; General case, avoid computing the 1x...xK twice:
+ ;;
+ ;; N! 1x...xN (K+1)x...xN
+ ;; -------- = ---------------- = ------------, N>1
+ ;; K!(N-K)! 1x...xK x (N-K)! (N-K)!
+ (/ (%multiply-range (+ k 1) n)
+ (%factorial n-k))))))
+
+(defun subfactorial (n)
+ "Subfactorial of the non-negative integer N."
+ (check-type n (integer 0))
+ (if (zerop n)
+ 1
+ (do ((x 1 (1+ x))
+ (a 0 (* x (+ a b)))
+ (b 1 a))
+ ((= n x) a))))
+
+(defun count-permutations (n &optional (k n))
+ "Number of K element permutations for a sequence of N objects.
+K defaults to N"
+ (check-type n (integer 0))
+ (check-type k (integer 0))
+ (assert (>= n k))
+ (%multiply-range (1+ (- n k)) n))
--- /dev/null
+(defpackage :alexandria.0.dev
+ (:nicknames :alexandria)
+ (:use :cl)
+ #+sb-package-locks
+ (:lock t)
+ (:export
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;; BLESSED
+ ;;
+ ;; Binding constructs
+ #:if-let
+ #:when-let
+ #:when-let*
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;; REVIEW IN PROGRESS
+ ;;
+ ;; Control flow
+ ;;
+ ;; -- no clear consensus yet --
+ #:cswitch
+ #:eswitch
+ #:switch
+ ;; -- problem free? --
+ #:multiple-value-prog2
+ #:nth-value-or
+ #:whichever
+ #:xor
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;; REVIEW PENDING
+ ;;
+ ;; Definitions
+ #:define-constant
+ ;; Hash tables
+ #:alist-hash-table
+ #:copy-hash-table
+ #:ensure-gethash
+ #:hash-table-alist
+ #:hash-table-keys
+ #:hash-table-plist
+ #:hash-table-values
+ #:maphash-keys
+ #:maphash-values
+ #:plist-hash-table
+ ;; Functions
+ #:compose
+ #:conjoin
+ #:curry
+ #:disjoin
+ #:ensure-function
+ #:ensure-functionf
+ #:multiple-value-compose
+ #:named-lambda
+ #:rcurry
+ ;; Lists
+ #:alist-plist
+ #:appendf
+ #:nconcf
+ #:reversef
+ #:nreversef
+ #:circular-list
+ #:circular-list-p
+ #:circular-tree-p
+ #:doplist
+ #:ensure-car
+ #:ensure-cons
+ #:ensure-list
+ #:flatten
+ #:lastcar
+ #:make-circular-list
+ #:map-product
+ #:mappend
+ #:nunionf
+ #:plist-alist
+ #:proper-list
+ #:proper-list-length
+ #:proper-list-p
+ #:remove-from-plist
+ #:remove-from-plistf
+ #:delete-from-plist
+ #:delete-from-plistf
+ #:set-equal
+ #:setp
+ #:unionf
+ ;; Numbers
+ #:binomial-coefficient
+ #:clamp
+ #:count-permutations
+ #:factorial
+ #:gaussian-random
+ #:iota
+ #:lerp
+ #:map-iota
+ #:maxf
+ #:mean
+ #:median
+ #:minf
+ #:standard-deviation
+ #:subfactorial
+ #:variance
+ ;; Arrays
+ #:array-index
+ #:array-length
+ #:copy-array
+ ;; Sequences
+ #:copy-sequence
+ #:deletef
+ #:emptyp
+ #:ends-with
+ #:ends-with-subseq
+ #:extremum
+ #:first-elt
+ #:last-elt
+ #:length=
+ #:map-combinations
+ #:map-derangements
+ #:map-permutations
+ #:proper-sequence
+ #:random-elt
+ #:removef
+ #:rotate
+ #:sequence-of-length-p
+ #:shuffle
+ #:starts-with
+ #:starts-with-subseq
+ ;; Macros
+ #:once-only
+ #:parse-body
+ #:parse-ordinary-lambda-list
+ #:with-gensyms
+ #:with-unique-names
+ ;; Symbols
+ #:ensure-symbol
+ #:format-symbol
+ #:make-gensym
+ #:make-gensym-list
+ #:make-keyword
+ ;; Strings
+ #:string-designator
+ ;; Types
+ #:negative-double-float
+ #:negative-fixnum-p
+ #:negative-float
+ #:negative-float-p
+ #:negative-long-float
+ #:negative-long-float-p
+ #:negative-rational
+ #:negative-rational-p
+ #:negative-real
+ #:negative-single-float-p
+ #:non-negative-double-float
+ #:non-negative-double-float-p
+ #:non-negative-fixnum
+ #:non-negative-fixnum-p
+ #:non-negative-float
+ #:non-negative-float-p
+ #:non-negative-integer-p
+ #:non-negative-long-float
+ #:non-negative-rational
+ #:non-negative-real-p
+ #:non-negative-short-float-p
+ #:non-negative-single-float
+ #:non-negative-single-float-p
+ #:non-positive-double-float
+ #:non-positive-double-float-p
+ #:non-positive-fixnum
+ #:non-positive-fixnum-p
+ #:non-positive-float
+ #:non-positive-float-p
+ #:non-positive-integer
+ #:non-positive-rational
+ #:non-positive-real
+ #:non-positive-real-p
+ #:non-positive-short-float
+ #:non-positive-short-float-p
+ #:non-positive-single-float-p
+ #:ordinary-lambda-list-keywords
+ #:positive-double-float
+ #:positive-double-float-p
+ #:positive-fixnum
+ #:positive-fixnum-p
+ #:positive-float
+ #:positive-float-p
+ #:positive-integer
+ #:positive-rational
+ #:positive-real
+ #:positive-real-p
+ #:positive-short-float
+ #:positive-short-float-p
+ #:positive-single-float
+ #:positive-single-float-p
+ #:coercef
+ #:negative-double-float-p
+ #:negative-fixnum
+ #:negative-integer
+ #:negative-integer-p
+ #:negative-real-p
+ #:negative-short-float
+ #:negative-short-float-p
+ #:negative-single-float
+ #:non-negative-integer
+ #:non-negative-long-float-p
+ #:non-negative-rational-p
+ #:non-negative-real
+ #:non-negative-short-float
+ #:non-positive-integer-p
+ #:non-positive-long-float
+ #:non-positive-long-float-p
+ #:non-positive-rational-p
+ #:non-positive-single-float
+ #:of-type
+ #:positive-integer-p
+ #:positive-long-float
+ #:positive-long-float-p
+ #:positive-rational-p
+ #:type=
+ ;; Conditions
+ #:required-argument
+ #:ignore-some-conditions
+ #:simple-style-warning
+ #:simple-reader-error
+ #:simple-parse-error
+ #:simple-program-error
+ #:unwind-protect-case
+ ;; Features
+ #:featurep
+ ;; io
+ #:with-input-from-file
+ #:with-output-to-file
+ #:read-stream-content-into-string
+ #:read-file-into-string
+ #:write-string-into-file
+ #:read-stream-content-into-byte-vector
+ #:read-file-into-byte-vector
+ #:write-byte-vector-into-file
+ #:copy-stream
+ #:copy-file
+ ;; new additions collected at the end (subject to removal or further changes)
+ #:symbolicate
+ #:assoc-value
+ #:rassoc-value
+ #:destructuring-case
+ #:destructuring-ccase
+ #:destructuring-ecase
+ ))
--- /dev/null
+(in-package :alexandria)
+
+;; Make these inlinable by declaiming them INLINE here and some of them
+;; NOTINLINE at the end of the file. Exclude functions that have a compiler
+;; macro, because NOTINLINE is required to prevent compiler-macro expansion.
+(declaim (inline copy-sequence sequence-of-length-p))
+
+(defun sequence-of-length-p (sequence length)
+ "Return true if SEQUENCE is a sequence of length LENGTH. Signals an error if
+SEQUENCE is not a sequence. Returns FALSE for circular lists."
+ (declare (type array-index length)
+ (inline length)
+ (optimize speed))
+ (etypecase sequence
+ (null
+ (zerop length))
+ (cons
+ (let ((n (1- length)))
+ (unless (minusp n)
+ (let ((tail (nthcdr n sequence)))
+ (and tail
+ (null (cdr tail)))))))
+ (vector
+ (= length (length sequence)))
+ (sequence
+ (= length (length sequence)))))
+
+(defun rotate-tail-to-head (sequence n)
+ (declare (type (integer 1) n))
+ (if (listp sequence)
+ (let ((m (mod n (proper-list-length sequence))))
+ (if (null (cdr sequence))
+ sequence
+ (let* ((tail (last sequence (+ m 1)))
+ (last (cdr tail)))
+ (setf (cdr tail) nil)
+ (nconc last sequence))))
+ (let* ((len (length sequence))
+ (m (mod n len))
+ (tail (subseq sequence (- len m))))
+ (replace sequence sequence :start1 m :start2 0)
+ (replace sequence tail)
+ sequence)))
+
+(defun rotate-head-to-tail (sequence n)
+ (declare (type (integer 1) n))
+ (if (listp sequence)
+ (let ((m (mod (1- n) (proper-list-length sequence))))
+ (if (null (cdr sequence))
+ sequence
+ (let* ((headtail (nthcdr m sequence))
+ (tail (cdr headtail)))
+ (setf (cdr headtail) nil)
+ (nconc tail sequence))))
+ (let* ((len (length sequence))
+ (m (mod n len))
+ (head (subseq sequence 0 m)))
+ (replace sequence sequence :start1 0 :start2 m)
+ (replace sequence head :start1 (- len m))
+ sequence)))
+
+(defun rotate (sequence &optional (n 1))
+ "Returns a sequence of the same type as SEQUENCE, with the elements of
+SEQUENCE rotated by N: N elements are moved from the end of the sequence to
+the front if N is positive, and -N elements moved from the front to the end if
+N is negative. SEQUENCE must be a proper sequence. N must be an integer,
+defaulting to 1.
+
+If absolute value of N is greater then the length of the sequence, the results
+are identical to calling ROTATE with
+
+ (* (signum n) (mod n (length sequence))).
+
+Note: the original sequence may be destructively altered, and result sequence may
+share structure with it."
+ (if (plusp n)
+ (rotate-tail-to-head sequence n)
+ (if (minusp n)
+ (rotate-head-to-tail sequence (- n))
+ sequence)))
+
+(defun shuffle (sequence &key (start 0) end)
+ "Returns a random permutation of SEQUENCE bounded by START and END.
+Original sequece may be destructively modified, and share storage with
+the original one. Signals an error if SEQUENCE is not a proper
+sequence."
+ (declare (type fixnum start)
+ (type (or fixnum null) end))
+ (etypecase sequence
+ (list
+ (let* ((end (or end (proper-list-length sequence)))
+ (n (- end start)))
+ (do ((tail (nthcdr start sequence) (cdr tail)))
+ ((zerop n))
+ (rotatef (car tail) (car (nthcdr (random n) tail)))
+ (decf n))))
+ (vector
+ (let ((end (or end (length sequence))))
+ (loop for i from start below end
+ do (rotatef (aref sequence i)
+ (aref sequence (+ i (random (- end i))))))))
+ (sequence
+ (let ((end (or end (length sequence))))
+ (loop for i from (- end 1) downto start
+ do (rotatef (elt sequence i)
+ (elt sequence (+ i (random (- end i)))))))))
+ sequence)
+
+(defun random-elt (sequence &key (start 0) end)
+ "Returns a random element from SEQUENCE bounded by START and END. Signals an
+error if the SEQUENCE is not a proper non-empty sequence, or if END and START
+are not proper bounding index designators for SEQUENCE."
+ (declare (sequence sequence) (fixnum start) (type (or fixnum null) end))
+ (let* ((size (if (listp sequence)
+ (proper-list-length sequence)
+ (length sequence)))
+ (end2 (or end size)))
+ (cond ((zerop size)
+ (error 'type-error
+ :datum sequence
+ :expected-type `(and sequence (not (satisfies emptyp)))))
+ ((not (and (<= 0 start) (< start end2) (<= end2 size)))
+ (error 'simple-type-error
+ :datum (cons start end)
+ :expected-type `(cons (integer 0 (,end2))
+ (or null (integer (,start) ,size)))
+ :format-control "~@<~S and ~S are not valid bounding index designators for ~
+ a sequence of length ~S.~:@>"
+ :format-arguments (list start end size)))
+ (t
+ (let ((index (+ start (random (- end2 start)))))
+ (elt sequence index))))))
+
+(declaim (inline remove/swapped-arguments))
+(defun remove/swapped-arguments (sequence item &rest keyword-arguments)
+ (apply #'remove item sequence keyword-arguments))
+
+(define-modify-macro removef (item &rest remove-keywords)
+ remove/swapped-arguments
+ "Modify-macro for REMOVE. Sets place designated by the first argument to
+the result of calling REMOVE with ITEM, place, and the REMOVE-KEYWORDS.")
+
+(declaim (inline delete/swapped-arguments))
+(defun delete/swapped-arguments (sequence item &rest keyword-arguments)
+ (apply #'delete item sequence keyword-arguments))
+
+(define-modify-macro deletef (item &rest remove-keywords)
+ delete/swapped-arguments
+ "Modify-macro for DELETE. Sets place designated by the first argument to
+the result of calling DELETE with ITEM, place, and the REMOVE-KEYWORDS.")
+
+(deftype proper-sequence ()
+ "Type designator for proper sequences, that is proper lists and sequences
+that are not lists."
+ `(or proper-list
+ (and (not list) sequence)))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (when (and (find-package '#:sequence)
+ (find-symbol (string '#:emptyp) '#:sequence))
+ (pushnew 'sequence-emptyp *features*)))
+
+#-alexandria::sequence-emptyp
+(defun emptyp (sequence)
+ "Returns true if SEQUENCE is an empty sequence. Signals an error if SEQUENCE
+is not a sequence."
+ (etypecase sequence
+ (list (null sequence))
+ (sequence (zerop (length sequence)))))
+
+#+alexandria::sequence-emptyp
+(declaim (ftype (function (sequence) (values boolean &optional)) emptyp))
+#+alexandria::sequence-emptyp
+(setf (symbol-function 'emptyp) (symbol-function 'sequence:emptyp))
+#+alexandria::sequence-emptyp
+(define-compiler-macro emptyp (sequence)
+ `(sequence:emptyp ,sequence))
+
+(defun length= (&rest sequences)
+ "Takes any number of sequences or integers in any order. Returns true iff
+the length of all the sequences and the integers are equal. Hint: there's a
+compiler macro that expands into more efficient code if the first argument
+is a literal integer."
+ (declare (dynamic-extent sequences)
+ (inline sequence-of-length-p)
+ (optimize speed))
+ (unless (cdr sequences)
+ (error "You must call LENGTH= with at least two arguments"))
+ ;; There's room for optimization here: multiple list arguments could be
+ ;; traversed in parallel.
+ (let* ((first (pop sequences))
+ (current (if (integerp first)
+ first
+ (length first))))
+ (declare (type array-index current))
+ (dolist (el sequences)
+ (if (integerp el)
+ (unless (= el current)
+ (return-from length= nil))
+ (unless (sequence-of-length-p el current)
+ (return-from length= nil)))))
+ t)
+
+(define-compiler-macro length= (&whole form length &rest sequences)
+ (cond
+ ((zerop (length sequences))
+ form)
+ (t
+ (let ((optimizedp (integerp length)))
+ (with-unique-names (tmp current)
+ (declare (ignorable current))
+ `(locally
+ (declare (inline sequence-of-length-p))
+ (let ((,tmp)
+ ,@(unless optimizedp
+ `((,current ,length))))
+ ,@(unless optimizedp
+ `((unless (integerp ,current)
+ (setf ,current (length ,current)))))
+ (and
+ ,@(loop
+ :for sequence :in sequences
+ :collect `(progn
+ (setf ,tmp ,sequence)
+ (if (integerp ,tmp)
+ (= ,tmp ,(if optimizedp
+ length
+ current))
+ (sequence-of-length-p ,tmp ,(if optimizedp
+ length
+ current)))))))))))))
+
+(defun copy-sequence (type sequence)
+ "Returns a fresh sequence of TYPE, which has the same elements as
+SEQUENCE."
+ (if (typep sequence type)
+ (copy-seq sequence)
+ (coerce sequence type)))
+
+(defun first-elt (sequence)
+ "Returns the first element of SEQUENCE. Signals a type-error if SEQUENCE is
+not a sequence, or is an empty sequence."
+ ;; Can't just directly use ELT, as it is not guaranteed to signal the
+ ;; type-error.
+ (cond ((consp sequence)
+ (car sequence))
+ ((and (typep sequence 'sequence) (not (emptyp sequence)))
+ (elt sequence 0))
+ (t
+ (error 'type-error
+ :datum sequence
+ :expected-type '(and sequence (not (satisfies emptyp)))))))
+
+(defun (setf first-elt) (object sequence)
+ "Sets the first element of SEQUENCE. Signals a type-error if SEQUENCE is
+not a sequence, is an empty sequence, or if OBJECT cannot be stored in SEQUENCE."
+ ;; Can't just directly use ELT, as it is not guaranteed to signal the
+ ;; type-error.
+ (cond ((consp sequence)
+ (setf (car sequence) object))
+ ((and (typep sequence 'sequence) (not (emptyp sequence)))
+ (setf (elt sequence 0) object))
+ (t
+ (error 'type-error
+ :datum sequence
+ :expected-type '(and sequence (not (satisfies emptyp)))))))
+
+(defun last-elt (sequence)
+ "Returns the last element of SEQUENCE. Signals a type-error if SEQUENCE is
+not a proper sequence, or is an empty sequence."
+ ;; Can't just directly use ELT, as it is not guaranteed to signal the
+ ;; type-error.
+ (let ((len 0))
+ (cond ((consp sequence)
+ (lastcar sequence))
+ ((and (typep sequence '(and sequence (not list))) (plusp (setf len (length sequence))))
+ (elt sequence (1- len)))
+ (t
+ (error 'type-error
+ :datum sequence
+ :expected-type '(and proper-sequence (not (satisfies emptyp))))))))
+
+(defun (setf last-elt) (object sequence)
+ "Sets the last element of SEQUENCE. Signals a type-error if SEQUENCE is not a proper
+sequence, is an empty sequence, or if OBJECT cannot be stored in SEQUENCE."
+ (let ((len 0))
+ (cond ((consp sequence)
+ (setf (lastcar sequence) object))
+ ((and (typep sequence '(and sequence (not list))) (plusp (setf len (length sequence))))
+ (setf (elt sequence (1- len)) object))
+ (t
+ (error 'type-error
+ :datum sequence
+ :expected-type '(and proper-sequence (not (satisfies emptyp))))))))
+
+(defun starts-with-subseq (prefix sequence &rest args
+ &key
+ (return-suffix nil return-suffix-supplied-p)
+ &allow-other-keys)
+ "Test whether the first elements of SEQUENCE are the same (as per TEST) as the elements of PREFIX.
+
+If RETURN-SUFFIX is T the function returns, as a second value, a
+sub-sequence or displaced array pointing to the sequence after PREFIX."
+ (declare (dynamic-extent args))
+ (let ((sequence-length (length sequence))
+ (prefix-length (length prefix)))
+ (when (< sequence-length prefix-length)
+ (return-from starts-with-subseq (values nil nil)))
+ (flet ((make-suffix (start)
+ (when return-suffix
+ (cond
+ ((not (arrayp sequence))
+ (if start
+ (subseq sequence start)
+ (subseq sequence 0 0)))
+ ((not start)
+ (make-array 0
+ :element-type (array-element-type sequence)
+ :adjustable nil))
+ (t
+ (make-array (- sequence-length start)
+ :element-type (array-element-type sequence)
+ :displaced-to sequence
+ :displaced-index-offset start
+ :adjustable nil))))))
+ (let ((mismatch (apply #'mismatch prefix sequence
+ (if return-suffix-supplied-p
+ (remove-from-plist args :return-suffix)
+ args))))
+ (cond
+ ((not mismatch)
+ (values t (make-suffix nil)))
+ ((= mismatch prefix-length)
+ (values t (make-suffix mismatch)))
+ (t
+ (values nil nil)))))))
+
+(defun ends-with-subseq (suffix sequence &key (test #'eql))
+ "Test whether SEQUENCE ends with SUFFIX. In other words: return true if
+the last (length SUFFIX) elements of SEQUENCE are equal to SUFFIX."
+ (let ((sequence-length (length sequence))
+ (suffix-length (length suffix)))
+ (when (< sequence-length suffix-length)
+ ;; if SEQUENCE is shorter than SUFFIX, then SEQUENCE can't end with SUFFIX.
+ (return-from ends-with-subseq nil))
+ (loop for sequence-index from (- sequence-length suffix-length) below sequence-length
+ for suffix-index from 0 below suffix-length
+ when (not (funcall test (elt sequence sequence-index) (elt suffix suffix-index)))
+ do (return-from ends-with-subseq nil)
+ finally (return t))))
+
+(defun starts-with (object sequence &key (test #'eql) (key #'identity))
+ "Returns true if SEQUENCE is a sequence whose first element is EQL to OBJECT.
+Returns NIL if the SEQUENCE is not a sequence or is an empty sequence."
+ (let ((first-elt (typecase sequence
+ (cons (car sequence))
+ (sequence
+ (if (emptyp sequence)
+ (return-from starts-with nil)
+ (elt sequence 0)))
+ (t
+ (return-from starts-with nil)))))
+ (funcall test (funcall key first-elt) object)))
+
+(defun ends-with (object sequence &key (test #'eql) (key #'identity))
+ "Returns true if SEQUENCE is a sequence whose last element is EQL to OBJECT.
+Returns NIL if the SEQUENCE is not a sequence or is an empty sequence. Signals
+an error if SEQUENCE is an improper list."
+ (let ((last-elt (typecase sequence
+ (cons
+ (lastcar sequence)) ; signals for improper lists
+ (sequence
+ ;; Can't use last-elt, as that signals an error
+ ;; for empty sequences
+ (let ((len (length sequence)))
+ (if (plusp len)
+ (elt sequence (1- len))
+ (return-from ends-with nil))))
+ (t
+ (return-from ends-with nil)))))
+ (funcall test (funcall key last-elt) object)))
+
+(defun map-combinations (function sequence &key (start 0) end length (copy t))
+ "Calls FUNCTION with each combination of LENGTH constructable from the
+elements of the subsequence of SEQUENCE delimited by START and END. START
+defaults to 0, END to length of SEQUENCE, and LENGTH to the length of the
+delimited subsequence. (So unless LENGTH is specified there is only a single
+combination, which has the same elements as the delimited subsequence.) If
+COPY is true (the default) each combination is freshly allocated. If COPY is
+false all combinations are EQ to each other, in which case consequences are
+specified if a combination is modified by FUNCTION."
+ (let* ((end (or end (length sequence)))
+ (size (- end start))
+ (length (or length size))
+ (combination (subseq sequence 0 length))
+ (function (ensure-function function)))
+ (if (= length size)
+ (funcall function combination)
+ (flet ((call ()
+ (funcall function (if copy
+ (copy-seq combination)
+ combination))))
+ (etypecase sequence
+ ;; When dealing with lists we prefer walking back and
+ ;; forth instead of using indexes.
+ (list
+ (labels ((combine-list (c-tail o-tail)
+ (if (not c-tail)
+ (call)
+ (do ((tail o-tail (cdr tail)))
+ ((not tail))
+ (setf (car c-tail) (car tail))
+ (combine-list (cdr c-tail) (cdr tail))))))
+ (combine-list combination (nthcdr start sequence))))
+ (vector
+ (labels ((combine (count start)
+ (if (zerop count)
+ (call)
+ (loop for i from start below end
+ do (let ((j (- count 1)))
+ (setf (aref combination j) (aref sequence i))
+ (combine j (+ i 1)))))))
+ (combine length start)))
+ (sequence
+ (labels ((combine (count start)
+ (if (zerop count)
+ (call)
+ (loop for i from start below end
+ do (let ((j (- count 1)))
+ (setf (elt combination j) (elt sequence i))
+ (combine j (+ i 1)))))))
+ (combine length start)))))))
+ sequence)
+
+(defun map-permutations (function sequence &key (start 0) end length (copy t))
+ "Calls function with each permutation of LENGTH constructable
+from the subsequence of SEQUENCE delimited by START and END. START
+defaults to 0, END to length of the sequence, and LENGTH to the
+length of the delimited subsequence."
+ (let* ((end (or end (length sequence)))
+ (size (- end start))
+ (length (or length size)))
+ (labels ((permute (seq n)
+ (let ((n-1 (- n 1)))
+ (if (zerop n-1)
+ (funcall function (if copy
+ (copy-seq seq)
+ seq))
+ (loop for i from 0 upto n-1
+ do (permute seq n-1)
+ (if (evenp n-1)
+ (rotatef (elt seq 0) (elt seq n-1))
+ (rotatef (elt seq i) (elt seq n-1)))))))
+ (permute-sequence (seq)
+ (permute seq length)))
+ (if (= length size)
+ ;; Things are simple if we need to just permute the
+ ;; full START-END range.
+ (permute-sequence (subseq sequence start end))
+ ;; Otherwise we need to generate all the combinations
+ ;; of LENGTH in the START-END range, and then permute
+ ;; a copy of the result: can't permute the combination
+ ;; directly, as they share structure with each other.
+ (let ((permutation (subseq sequence 0 length)))
+ (flet ((permute-combination (combination)
+ (permute-sequence (replace permutation combination))))
+ (declare (dynamic-extent #'permute-combination))
+ (map-combinations #'permute-combination sequence
+ :start start
+ :end end
+ :length length
+ :copy nil)))))))
+
+(defun map-derangements (function sequence &key (start 0) end (copy t))
+ "Calls FUNCTION with each derangement of the subsequence of SEQUENCE denoted
+by the bounding index designators START and END. Derangement is a permutation
+of the sequence where no element remains in place. SEQUENCE is not modified,
+but individual derangements are EQ to each other. Consequences are unspecified
+if calling FUNCTION modifies either the derangement or SEQUENCE."
+ (let* ((end (or end (length sequence)))
+ (size (- end start))
+ ;; We don't really care about the elements here.
+ (derangement (subseq sequence 0 size))
+ ;; Bitvector that has 1 for elements that have been deranged.
+ (mask (make-array size :element-type 'bit :initial-element 0)))
+ (declare (dynamic-extent mask))
+ ;; ad hoc algorith
+ (labels ((derange (place n)
+ ;; Perform one recursive step in deranging the
+ ;; sequence: PLACE is index of the original sequence
+ ;; to derange to another index, and N is the number of
+ ;; indexes not yet deranged.
+ (if (zerop n)
+ (funcall function (if copy
+ (copy-seq derangement)
+ derangement))
+ ;; Itarate over the indexes I of the subsequence to
+ ;; derange: if I != PLACE and I has not yet been
+ ;; deranged by an earlier call put the element from
+ ;; PLACE to I, mark I as deranged, and recurse,
+ ;; finally removing the mark.
+ (loop for i from 0 below size
+ do
+ (unless (or (= place (+ i start)) (not (zerop (bit mask i))))
+ (setf (elt derangement i) (elt sequence place)
+ (bit mask i) 1)
+ (derange (1+ place) (1- n))
+ (setf (bit mask i) 0))))))
+ (derange start size)
+ sequence)))
+
+(declaim (notinline sequence-of-length-p))
+
+(defun extremum (sequence predicate &key key (start 0) end)
+ "Returns the element of SEQUENCE that would appear first if the subsequence
+bounded by START and END was sorted using PREDICATE and KEY.
+
+EXTREMUM determines the relationship between two elements of SEQUENCE by using
+the PREDICATE function. PREDICATE should return true if and only if the first
+argument is strictly less than the second one (in some appropriate sense). Two
+arguments X and Y are considered to be equal if (FUNCALL PREDICATE X Y)
+and (FUNCALL PREDICATE Y X) are both false.
+
+The arguments to the PREDICATE function are computed from elements of SEQUENCE
+using the KEY function, if supplied. If KEY is not supplied or is NIL, the
+sequence element itself is used.
+
+If SEQUENCE is empty, NIL is returned."
+ (let* ((pred-fun (ensure-function predicate))
+ (key-fun (unless (or (not key) (eq key 'identity) (eq key #'identity))
+ (ensure-function key)))
+ (real-end (or end (length sequence))))
+ (cond ((> real-end start)
+ (if key-fun
+ (flet ((reduce-keys (a b)
+ (if (funcall pred-fun
+ (funcall key-fun a)
+ (funcall key-fun b))
+ a
+ b)))
+ (declare (dynamic-extent #'reduce-keys))
+ (reduce #'reduce-keys sequence :start start :end real-end))
+ (flet ((reduce-elts (a b)
+ (if (funcall pred-fun a b)
+ a
+ b)))
+ (declare (dynamic-extent #'reduce-elts))
+ (reduce #'reduce-elts sequence :start start :end real-end))))
+ ((= real-end start)
+ nil)
+ (t
+ (error "Invalid bounding indexes for sequence of length ~S: ~S ~S, ~S ~S"
+ (length sequence)
+ :start start
+ :end end)))))
--- /dev/null
+(in-package :alexandria)
+
+(deftype string-designator ()
+ "A string designator type. A string designator is either a string, a symbol,
+or a character."
+ `(or symbol string character))
--- /dev/null
+(in-package :alexandria)
+
+(declaim (inline ensure-symbol))
+(defun ensure-symbol (name &optional (package *package*))
+ "Returns a symbol with name designated by NAME, accessible in package
+designated by PACKAGE. If symbol is not already accessible in PACKAGE, it is
+interned there. Returns a secondary value reflecting the status of the symbol
+in the package, which matches the secondary return value of INTERN.
+
+Example:
+
+ (ensure-symbol :cons :cl) => cl:cons, :external
+"
+ (intern (string name) package))
+
+(defun maybe-intern (name package)
+ (values
+ (if package
+ (intern name (if (eq t package) *package* package))
+ (make-symbol name))))
+
+(declaim (inline format-symbol))
+(defun format-symbol (package control &rest arguments)
+ "Constructs a string by applying ARGUMENTS to string designator CONTROL as
+if by FORMAT within WITH-STANDARD-IO-SYNTAX, and then creates a symbol named
+by that string.
+
+If PACKAGE is NIL, returns an uninterned symbol, if package is T, returns a
+symbol interned in the current package, and otherwise returns a symbol
+interned in the package designated by PACKAGE."
+ (maybe-intern (with-standard-io-syntax
+ (apply #'format nil (string control) arguments))
+ package))
+
+(defun make-keyword (name)
+ "Interns the string designated by NAME in the KEYWORD package."
+ (intern (string name) :keyword))
+
+(defun make-gensym (name)
+ "If NAME is a non-negative integer, calls GENSYM using it. Otherwise NAME
+must be a string designator, in which case calls GENSYM using the designated
+string as the argument."
+ (gensym (if (typep name '(integer 0))
+ name
+ (string name))))
+
+(defun make-gensym-list (length &optional (x "G"))
+ "Returns a list of LENGTH gensyms, each generated as if with a call to MAKE-GENSYM,
+using the second (optional, defaulting to \"G\") argument."
+ (let ((g (if (typep x '(integer 0)) x (string x))))
+ (loop repeat length
+ collect (gensym g))))
+
+(defun symbolicate (&rest things)
+ "Concatenate together the names of some strings and symbols,
+producing a symbol in the current package."
+ (let* ((length (reduce #'+ things
+ :key (lambda (x) (length (string x)))))
+ (name (make-array length :element-type 'character)))
+ (let ((index 0))
+ (dolist (thing things (values (intern name)))
+ (let* ((x (string thing))
+ (len (length x)))
+ (replace name x :start1 index)
+ (incf index len))))))
--- /dev/null
+(in-package :cl-user)
+
+(defpackage :alexandria-tests
+ (:use :cl :alexandria #+sbcl :sb-rt #-sbcl :rtest)
+ (:import-from #+sbcl :sb-rt #-sbcl :rtest
+ #:*compile-tests* #:*expected-failures*))
+
+(in-package :alexandria-tests)
+
+(defun run-tests (&key ((:compiled *compile-tests*)))
+ (do-tests))
+
+(defun hash-table-test-name (name)
+ ;; Workaround for Clisp calling EQL in a hash-table FASTHASH-EQL.
+ (hash-table-test (make-hash-table :test name)))
+
+;;;; Arrays
+
+(deftest copy-array.1
+ (let* ((orig (vector 1 2 3))
+ (copy (copy-array orig)))
+ (values (eq orig copy) (equalp orig copy)))
+ nil t)
+
+(deftest copy-array.2
+ (let ((orig (make-array 1024 :fill-pointer 0)))
+ (vector-push-extend 1 orig)
+ (vector-push-extend 2 orig)
+ (vector-push-extend 3 orig)
+ (let ((copy (copy-array orig)))
+ (values (eq orig copy) (equalp orig copy)
+ (array-has-fill-pointer-p copy)
+ (eql (fill-pointer orig) (fill-pointer copy)))))
+ nil t t t)
+
+(deftest copy-array.3
+ (let* ((orig (vector 1 2 3))
+ (copy (copy-array orig)))
+ (typep copy 'simple-array))
+ t)
+
+(deftest copy-array.4
+ (let ((orig (make-array 21
+ :adjustable t
+ :fill-pointer 0)))
+ (dotimes (n 42)
+ (vector-push-extend n orig))
+ (let ((copy (copy-array orig
+ :adjustable nil
+ :fill-pointer nil)))
+ (typep copy 'simple-array)))
+ t)
+
+(deftest array-index.1
+ (typep 0 'array-index)
+ t)
+
+;;;; Conditions
+
+(deftest unwind-protect-case.1
+ (let (result)
+ (unwind-protect-case ()
+ (random 10)
+ (:normal (push :normal result))
+ (:abort (push :abort result))
+ (:always (push :always result)))
+ result)
+ (:always :normal))
+
+(deftest unwind-protect-case.2
+ (let (result)
+ (unwind-protect-case ()
+ (random 10)
+ (:always (push :always result))
+ (:normal (push :normal result))
+ (:abort (push :abort result)))
+ result)
+ (:normal :always))
+
+(deftest unwind-protect-case.3
+ (let (result1 result2 result3)
+ (ignore-errors
+ (unwind-protect-case ()
+ (error "FOOF!")
+ (:normal (push :normal result1))
+ (:abort (push :abort result1))
+ (:always (push :always result1))))
+ (catch 'foof
+ (unwind-protect-case ()
+ (throw 'foof 42)
+ (:normal (push :normal result2))
+ (:abort (push :abort result2))
+ (:always (push :always result2))))
+ (block foof
+ (unwind-protect-case ()
+ (return-from foof 42)
+ (:normal (push :normal result3))
+ (:abort (push :abort result3))
+ (:always (push :always result3))))
+ (values result1 result2 result3))
+ (:always :abort)
+ (:always :abort)
+ (:always :abort))
+
+(deftest unwind-protect-case.4
+ (let (result)
+ (unwind-protect-case (aborted-p)
+ (random 42)
+ (:always (setq result aborted-p)))
+ result)
+ nil)
+
+(deftest unwind-protect-case.5
+ (let (result)
+ (block foof
+ (unwind-protect-case (aborted-p)
+ (return-from foof)
+ (:always (setq result aborted-p))))
+ result)
+ t)
+
+;;;; Control flow
+
+(deftest switch.1
+ (switch (13 :test =)
+ (12 :oops)
+ (13.0 :yay))
+ :yay)
+
+(deftest switch.2
+ (switch (13)
+ ((+ 12 2) :oops)
+ ((- 13 1) :oops2)
+ (t :yay))
+ :yay)
+
+(deftest eswitch.1
+ (let ((x 13))
+ (eswitch (x :test =)
+ (12 :oops)
+ (13.0 :yay)))
+ :yay)
+
+(deftest eswitch.2
+ (let ((x 13))
+ (eswitch (x :key 1+)
+ (11 :oops)
+ (14 :yay)))
+ :yay)
+
+(deftest cswitch.1
+ (cswitch (13 :test =)
+ (12 :oops)
+ (13.0 :yay))
+ :yay)
+
+(deftest cswitch.2
+ (cswitch (13 :key 1-)
+ (12 :yay)
+ (13.0 :oops))
+ :yay)
+
+(deftest multiple-value-prog2.1
+ (multiple-value-prog2
+ (values 1 1 1)
+ (values 2 20 200)
+ (values 3 3 3))
+ 2 20 200)
+
+(deftest nth-value-or.1
+ (multiple-value-bind (a b c)
+ (nth-value-or 1
+ (values 1 nil 1)
+ (values 2 2 2))
+ (= a b c 2))
+ t)
+
+(deftest whichever.1
+ (let ((x (whichever 1 2 3)))
+ (and (member x '(1 2 3)) t))
+ t)
+
+(deftest whichever.2
+ (let* ((a 1)
+ (b 2)
+ (c 3)
+ (x (whichever a b c)))
+ (and (member x '(1 2 3)) t))
+ t)
+
+(deftest xor.1
+ (xor nil nil 1 nil)
+ 1
+ t)
+
+(deftest xor.2
+ (xor nil nil 1 2)
+ nil
+ nil)
+
+(deftest xor.3
+ (xor nil nil nil)
+ nil
+ t)
+
+;;;; Definitions
+
+(deftest define-constant.1
+ (let ((name (gensym)))
+ (eval `(define-constant ,name "FOO" :test 'equal))
+ (eval `(define-constant ,name "FOO" :test 'equal))
+ (values (equal "FOO" (symbol-value name))
+ (constantp name)))
+ t
+ t)
+
+(deftest define-constant.2
+ (let ((name (gensym)))
+ (eval `(define-constant ,name 13))
+ (eval `(define-constant ,name 13))
+ (values (eql 13 (symbol-value name))
+ (constantp name)))
+ t
+ t)
+
+;;;; Errors
+
+;;; TYPEP is specified to return a generalized boolean and, for
+;;; example, ECL exploits this by returning the superclasses of ERROR
+;;; in this case.
+(defun errorp (x)
+ (not (null (typep x 'error))))
+
+(deftest required-argument.1
+ (multiple-value-bind (res err)
+ (ignore-errors (required-argument))
+ (errorp err))
+ t)
+
+;;;; Hash tables
+
+(deftest ensure-gethash.1
+ (let ((table (make-hash-table))
+ (x (list 1)))
+ (multiple-value-bind (value already-there)
+ (ensure-gethash x table 42)
+ (and (= value 42)
+ (not already-there)
+ (= 42 (gethash x table))
+ (multiple-value-bind (value2 already-there2)
+ (ensure-gethash x table 13)
+ (and (= value2 42)
+ already-there2
+ (= 42 (gethash x table)))))))
+ t)
+
+(deftest ensure-gethash.2
+ (let ((table (make-hash-table))
+ (count 0))
+ (multiple-value-call #'values
+ (ensure-gethash (progn (incf count) :foo)
+ (progn (incf count) table)
+ (progn (incf count) :bar))
+ (gethash :foo table)
+ count))
+ :bar nil :bar t 3)
+
+(deftest copy-hash-table.1
+ (let ((orig (make-hash-table :test 'eq :size 123))
+ (foo "foo"))
+ (setf (gethash orig orig) t
+ (gethash foo orig) t)
+ (let ((eq-copy (copy-hash-table orig))
+ (eql-copy (copy-hash-table orig :test 'eql))
+ (equal-copy (copy-hash-table orig :test 'equal))
+ (equalp-copy (copy-hash-table orig :test 'equalp)))
+ (list (eql (hash-table-size eq-copy) (hash-table-size orig))
+ (eql (hash-table-rehash-size eq-copy)
+ (hash-table-rehash-size orig))
+ (hash-table-count eql-copy)
+ (gethash orig eq-copy)
+ (gethash (copy-seq foo) eql-copy)
+ (gethash foo eql-copy)
+ (gethash (copy-seq foo) equal-copy)
+ (gethash "FOO" equal-copy)
+ (gethash "FOO" equalp-copy))))
+ (t t 2 t nil t t nil t))
+
+(deftest copy-hash-table.2
+ (let ((ht (make-hash-table))
+ (list (list :list (vector :A :B :C))))
+ (setf (gethash 'list ht) list)
+ (let* ((shallow-copy (copy-hash-table ht))
+ (deep1-copy (copy-hash-table ht :key 'copy-list))
+ (list (gethash 'list ht))
+ (shallow-list (gethash 'list shallow-copy))
+ (deep1-list (gethash 'list deep1-copy)))
+ (list (eq ht shallow-copy)
+ (eq ht deep1-copy)
+ (eq list shallow-list)
+ (eq list deep1-list) ; outer list was copied.
+ (eq (second list) (second shallow-list))
+ (eq (second list) (second deep1-list)) ; inner vector wasn't copied.
+ )))
+ (nil nil t nil t t))
+
+(deftest maphash-keys.1
+ (let ((keys nil)
+ (table (make-hash-table)))
+ (declare (notinline maphash-keys))
+ (dotimes (i 10)
+ (setf (gethash i table) t))
+ (maphash-keys (lambda (k) (push k keys)) table)
+ (set-equal keys '(0 1 2 3 4 5 6 7 8 9)))
+ t)
+
+(deftest maphash-values.1
+ (let ((vals nil)
+ (table (make-hash-table)))
+ (declare (notinline maphash-values))
+ (dotimes (i 10)
+ (setf (gethash i table) (- i)))
+ (maphash-values (lambda (v) (push v vals)) table)
+ (set-equal vals '(0 -1 -2 -3 -4 -5 -6 -7 -8 -9)))
+ t)
+
+(deftest hash-table-keys.1
+ (let ((table (make-hash-table)))
+ (dotimes (i 10)
+ (setf (gethash i table) t))
+ (set-equal (hash-table-keys table) '(0 1 2 3 4 5 6 7 8 9)))
+ t)
+
+(deftest hash-table-values.1
+ (let ((table (make-hash-table)))
+ (dotimes (i 10)
+ (setf (gethash (gensym) table) i))
+ (set-equal (hash-table-values table) '(0 1 2 3 4 5 6 7 8 9)))
+ t)
+
+(deftest hash-table-alist.1
+ (let ((table (make-hash-table)))
+ (dotimes (i 10)
+ (setf (gethash i table) (- i)))
+ (let ((alist (hash-table-alist table)))
+ (list (length alist)
+ (assoc 0 alist)
+ (assoc 3 alist)
+ (assoc 9 alist)
+ (assoc nil alist))))
+ (10 (0 . 0) (3 . -3) (9 . -9) nil))
+
+(deftest hash-table-plist.1
+ (let ((table (make-hash-table)))
+ (dotimes (i 10)
+ (setf (gethash i table) (- i)))
+ (let ((plist (hash-table-plist table)))
+ (list (length plist)
+ (getf plist 0)
+ (getf plist 2)
+ (getf plist 7)
+ (getf plist nil))))
+ (20 0 -2 -7 nil))
+
+(deftest alist-hash-table.1
+ (let* ((alist '((0 a) (1 b) (2 c)))
+ (table (alist-hash-table alist)))
+ (list (hash-table-count table)
+ (gethash 0 table)
+ (gethash 1 table)
+ (gethash 2 table)
+ (eq (hash-table-test-name 'eql)
+ (hash-table-test table))))
+ (3 (a) (b) (c) t))
+
+(deftest plist-hash-table.1
+ (let* ((plist '(:a 1 :b 2 :c 3))
+ (table (plist-hash-table plist :test 'eq)))
+ (list (hash-table-count table)
+ (gethash :a table)
+ (gethash :b table)
+ (gethash :c table)
+ (gethash 2 table)
+ (gethash nil table)
+ (eq (hash-table-test-name 'eq)
+ (hash-table-test table))))
+ (3 1 2 3 nil nil t))
+
+;;;; Functions
+
+(deftest disjoin.1
+ (let ((disjunction (disjoin (lambda (x)
+ (and (consp x) :cons))
+ (lambda (x)
+ (and (stringp x) :string)))))
+ (list (funcall disjunction 'zot)
+ (funcall disjunction '(foo bar))
+ (funcall disjunction "test")))
+ (nil :cons :string))
+
+(deftest disjoin.2
+ (let ((disjunction (disjoin #'zerop)))
+ (list (funcall disjunction 0)
+ (funcall disjunction 1)))
+ (t nil))
+
+(deftest conjoin.1
+ (let ((conjunction (conjoin #'consp
+ (lambda (x)
+ (stringp (car x)))
+ (lambda (x)
+ (char (car x) 0)))))
+ (list (funcall conjunction 'zot)
+ (funcall conjunction '(foo))
+ (funcall conjunction '("foo"))))
+ (nil nil #\f))
+
+(deftest conjoin.2
+ (let ((conjunction (conjoin #'zerop)))
+ (list (funcall conjunction 0)
+ (funcall conjunction 1)))
+ (t nil))
+
+(deftest compose.1
+ (let ((composite (compose '1+
+ (lambda (x)
+ (* x 2))
+ #'read-from-string)))
+ (funcall composite "1"))
+ 3)
+
+(deftest compose.2
+ (let ((composite
+ (locally (declare (notinline compose))
+ (compose '1+
+ (lambda (x)
+ (* x 2))
+ #'read-from-string))))
+ (funcall composite "2"))
+ 5)
+
+(deftest compose.3
+ (let ((compose-form (funcall (compiler-macro-function 'compose)
+ '(compose '1+
+ (lambda (x)
+ (* x 2))
+ #'read-from-string)
+ nil)))
+ (let ((fun (funcall (compile nil `(lambda () ,compose-form)))))
+ (funcall fun "3")))
+ 7)
+
+(deftest compose.4
+ (let ((composite (compose #'zerop)))
+ (list (funcall composite 0)
+ (funcall composite 1)))
+ (t nil))
+
+(deftest multiple-value-compose.1
+ (let ((composite (multiple-value-compose
+ #'truncate
+ (lambda (x y)
+ (values y x))
+ (lambda (x)
+ (with-input-from-string (s x)
+ (values (read s) (read s)))))))
+ (multiple-value-list (funcall composite "2 7")))
+ (3 1))
+
+(deftest multiple-value-compose.2
+ (let ((composite (locally (declare (notinline multiple-value-compose))
+ (multiple-value-compose
+ #'truncate
+ (lambda (x y)
+ (values y x))
+ (lambda (x)
+ (with-input-from-string (s x)
+ (values (read s) (read s))))))))
+ (multiple-value-list (funcall composite "2 11")))
+ (5 1))
+
+(deftest multiple-value-compose.3
+ (let ((compose-form (funcall (compiler-macro-function 'multiple-value-compose)
+ '(multiple-value-compose
+ #'truncate
+ (lambda (x y)
+ (values y x))
+ (lambda (x)
+ (with-input-from-string (s x)
+ (values (read s) (read s)))))
+ nil)))
+ (let ((fun (funcall (compile nil `(lambda () ,compose-form)))))
+ (multiple-value-list (funcall fun "2 9"))))
+ (4 1))
+
+(deftest multiple-value-compose.4
+ (let ((composite (multiple-value-compose #'truncate)))
+ (multiple-value-list (funcall composite 9 2)))
+ (4 1))
+
+(deftest curry.1
+ (let ((curried (curry '+ 3)))
+ (funcall curried 1 5))
+ 9)
+
+(deftest curry.2
+ (let ((curried (locally (declare (notinline curry))
+ (curry '* 2 3))))
+ (funcall curried 7))
+ 42)
+
+(deftest curry.3
+ (let ((curried-form (funcall (compiler-macro-function 'curry)
+ '(curry '/ 8)
+ nil)))
+ (let ((fun (funcall (compile nil `(lambda () ,curried-form)))))
+ (funcall fun 2)))
+ 4)
+
+(deftest curry.4
+ (let* ((x 1)
+ (curried (curry (progn
+ (incf x)
+ (lambda (y z) (* x y z)))
+ 3)))
+ (list (funcall curried 7)
+ (funcall curried 7)
+ x))
+ (42 42 2))
+
+(deftest rcurry.1
+ (let ((r (rcurry '/ 2)))
+ (funcall r 8))
+ 4)
+
+(deftest rcurry.2
+ (let* ((x 1)
+ (curried (rcurry (progn
+ (incf x)
+ (lambda (y z) (* x y z)))
+ 3)))
+ (list (funcall curried 7)
+ (funcall curried 7)
+ x))
+ (42 42 2))
+
+(deftest named-lambda.1
+ (let ((fac (named-lambda fac (x)
+ (if (> x 1)
+ (* x (fac (- x 1)))
+ x))))
+ (funcall fac 5))
+ 120)
+
+(deftest named-lambda.2
+ (let ((fac (named-lambda fac (&key x)
+ (if (> x 1)
+ (* x (fac :x (- x 1)))
+ x))))
+ (funcall fac :x 5))
+ 120)
+
+;;;; Lists
+
+(deftest alist-plist.1
+ (alist-plist '((a . 1) (b . 2) (c . 3)))
+ (a 1 b 2 c 3))
+
+(deftest plist-alist.1
+ (plist-alist '(a 1 b 2 c 3))
+ ((a . 1) (b . 2) (c . 3)))
+
+(deftest unionf.1
+ (let* ((list (list 1 2 3))
+ (orig list))
+ (unionf list (list 1 2 4))
+ (values (equal orig (list 1 2 3))
+ (eql (length list) 4)
+ (set-difference list (list 1 2 3 4))
+ (set-difference (list 1 2 3 4) list)))
+ t
+ t
+ nil
+ nil)
+
+(deftest nunionf.1
+ (let ((list (list 1 2 3)))
+ (nunionf list (list 1 2 4))
+ (values (eql (length list) 4)
+ (set-difference (list 1 2 3 4) list)
+ (set-difference list (list 1 2 3 4))))
+ t
+ nil
+ nil)
+
+(deftest appendf.1
+ (let* ((list (list 1 2 3))
+ (orig list))
+ (appendf list '(4 5 6) '(7 8))
+ (list list (eq list orig)))
+ ((1 2 3 4 5 6 7 8) nil))
+
+(deftest nconcf.1
+ (let ((list1 (list 1 2 3))
+ (list2 (list 4 5 6)))
+ (nconcf list1 list2 (list 7 8 9))
+ list1)
+ (1 2 3 4 5 6 7 8 9))
+
+(deftest circular-list.1
+ (let ((circle (circular-list 1 2 3)))
+ (list (first circle)
+ (second circle)
+ (third circle)
+ (fourth circle)
+ (eq circle (nthcdr 3 circle))))
+ (1 2 3 1 t))
+
+(deftest circular-list-p.1
+ (let* ((circle (circular-list 1 2 3 4))
+ (tree (list circle circle))
+ (dotted (cons circle t))
+ (proper (list 1 2 3 circle))
+ (tailcirc (list* 1 2 3 circle)))
+ (list (circular-list-p circle)
+ (circular-list-p tree)
+ (circular-list-p dotted)
+ (circular-list-p proper)
+ (circular-list-p tailcirc)))
+ (t nil nil nil t))
+
+(deftest circular-list-p.2
+ (circular-list-p 'foo)
+ nil)
+
+(deftest circular-tree-p.1
+ (let* ((circle (circular-list 1 2 3 4))
+ (tree1 (list circle circle))
+ (tree2 (let* ((level2 (list 1 nil 2))
+ (level1 (list level2)))
+ (setf (second level2) level1)
+ level1))
+ (dotted (cons circle t))
+ (proper (list 1 2 3 circle))
+ (tailcirc (list* 1 2 3 circle))
+ (quite-proper (list 1 2 3))
+ (quite-dotted (list 1 (cons 2 3))))
+ (list (circular-tree-p circle)
+ (circular-tree-p tree1)
+ (circular-tree-p tree2)
+ (circular-tree-p dotted)
+ (circular-tree-p proper)
+ (circular-tree-p tailcirc)
+ (circular-tree-p quite-proper)
+ (circular-tree-p quite-dotted)))
+ (t t t t t t nil nil))
+
+(deftest circular-tree-p.2
+ (alexandria:circular-tree-p '#1=(#1#))
+ t)
+
+(deftest proper-list-p.1
+ (let ((l1 (list 1))
+ (l2 (list 1 2))
+ (l3 (cons 1 2))
+ (l4 (list (cons 1 2) 3))
+ (l5 (circular-list 1 2)))
+ (list (proper-list-p l1)
+ (proper-list-p l2)
+ (proper-list-p l3)
+ (proper-list-p l4)
+ (proper-list-p l5)))
+ (t t nil t nil))
+
+(deftest proper-list-p.2
+ (proper-list-p '(1 2 . 3))
+ nil)
+
+(deftest proper-list.type.1
+ (let ((l1 (list 1))
+ (l2 (list 1 2))
+ (l3 (cons 1 2))
+ (l4 (list (cons 1 2) 3))
+ (l5 (circular-list 1 2)))
+ (list (typep l1 'proper-list)
+ (typep l2 'proper-list)
+ (typep l3 'proper-list)
+ (typep l4 'proper-list)
+ (typep l5 'proper-list)))
+ (t t nil t nil))
+
+(deftest proper-list-length.1
+ (values
+ (proper-list-length nil)
+ (proper-list-length (list 1))
+ (proper-list-length (list 2 2))
+ (proper-list-length (list 3 3 3))
+ (proper-list-length (list 4 4 4 4))
+ (proper-list-length (list 5 5 5 5 5))
+ (proper-list-length (list 6 6 6 6 6 6))
+ (proper-list-length (list 7 7 7 7 7 7 7))
+ (proper-list-length (list 8 8 8 8 8 8 8 8))
+ (proper-list-length (list 9 9 9 9 9 9 9 9 9)))
+ 0 1 2 3 4 5 6 7 8 9)
+
+(deftest proper-list-length.2
+ (flet ((plength (x)
+ (handler-case
+ (proper-list-length x)
+ (type-error ()
+ :ok))))
+ (values
+ (plength (list* 1))
+ (plength (list* 2 2))
+ (plength (list* 3 3 3))
+ (plength (list* 4 4 4 4))
+ (plength (list* 5 5 5 5 5))
+ (plength (list* 6 6 6 6 6 6))
+ (plength (list* 7 7 7 7 7 7 7))
+ (plength (list* 8 8 8 8 8 8 8 8))
+ (plength (list* 9 9 9 9 9 9 9 9 9))))
+ :ok :ok :ok
+ :ok :ok :ok
+ :ok :ok :ok)
+
+(deftest lastcar.1
+ (let ((l1 (list 1))
+ (l2 (list 1 2)))
+ (list (lastcar l1)
+ (lastcar l2)))
+ (1 2))
+
+(deftest lastcar.error.2
+ (handler-case
+ (progn
+ (lastcar (circular-list 1 2 3))
+ nil)
+ (error ()
+ t))
+ t)
+
+(deftest setf-lastcar.1
+ (let ((l (list 1 2 3 4)))
+ (values (lastcar l)
+ (progn
+ (setf (lastcar l) 42)
+ (lastcar l))))
+ 4
+ 42)
+
+(deftest setf-lastcar.2
+ (let ((l (circular-list 1 2 3)))
+ (multiple-value-bind (res err)
+ (ignore-errors (setf (lastcar l) 4))
+ (typep err 'type-error)))
+ t)
+
+(deftest make-circular-list.1
+ (let ((l (make-circular-list 3 :initial-element :x)))
+ (setf (car l) :y)
+ (list (eq l (nthcdr 3 l))
+ (first l)
+ (second l)
+ (third l)
+ (fourth l)))
+ (t :y :x :x :y))
+
+(deftest circular-list.type.1
+ (let* ((l1 (list 1 2 3))
+ (l2 (circular-list 1 2 3))
+ (l3 (list* 1 2 3 l2)))
+ (list (typep l1 'circular-list)
+ (typep l2 'circular-list)
+ (typep l3 'circular-list)))
+ (nil t t))
+
+(deftest ensure-list.1
+ (let ((x (list 1))
+ (y 2))
+ (list (ensure-list x)
+ (ensure-list y)))
+ ((1) (2)))
+
+(deftest ensure-cons.1
+ (let ((x (cons 1 2))
+ (y nil)
+ (z "foo"))
+ (values (ensure-cons x)
+ (ensure-cons y)
+ (ensure-cons z)))
+ (1 . 2)
+ (nil)
+ ("foo"))
+
+(deftest setp.1
+ (setp '(1))
+ t)
+
+(deftest setp.2
+ (setp nil)
+ t)
+
+(deftest setp.3
+ (setp "foo")
+ nil)
+
+(deftest setp.4
+ (setp '(1 2 3 1))
+ nil)
+
+(deftest setp.5
+ (setp '(1 2 3))
+ t)
+
+(deftest setp.6
+ (setp '(a :a))
+ t)
+
+(deftest setp.7
+ (setp '(a :a) :key 'character)
+ nil)
+
+(deftest setp.8
+ (setp '(a :a) :key 'character :test (constantly nil))
+ t)
+
+(deftest set-equal.1
+ (set-equal '(1 2 3) '(3 1 2))
+ t)
+
+(deftest set-equal.2
+ (set-equal '("Xa") '("Xb")
+ :test (lambda (a b) (eql (char a 0) (char b 0))))
+ t)
+
+(deftest set-equal.3
+ (set-equal '(1 2) '(4 2))
+ nil)
+
+(deftest set-equal.4
+ (set-equal '(a b c) '(:a :b :c) :key 'string :test 'equal)
+ t)
+
+(deftest set-equal.5
+ (set-equal '(a d c) '(:a :b :c) :key 'string :test 'equal)
+ nil)
+
+(deftest set-equal.6
+ (set-equal '(a b c) '(a b c d))
+ nil)
+
+(deftest map-product.1
+ (map-product 'cons '(2 3) '(1 4))
+ ((2 . 1) (2 . 4) (3 . 1) (3 . 4)))
+
+(deftest map-product.2
+ (map-product #'cons '(2 3) '(1 4))
+ ((2 . 1) (2 . 4) (3 . 1) (3 . 4)))
+
+(deftest flatten.1
+ (flatten '((1) 2 (((3 4))) ((((5)) 6)) 7))
+ (1 2 3 4 5 6 7))
+
+(deftest remove-from-plist.1
+ (let ((orig '(a 1 b 2 c 3 d 4)))
+ (list (remove-from-plist orig 'a 'c)
+ (remove-from-plist orig 'b 'd)
+ (remove-from-plist orig 'b)
+ (remove-from-plist orig 'a)
+ (remove-from-plist orig 'd 42 "zot")
+ (remove-from-plist orig 'a 'b 'c 'd)
+ (remove-from-plist orig 'a 'b 'c 'd 'x)
+ (equal orig '(a 1 b 2 c 3 d 4))))
+ ((b 2 d 4)
+ (a 1 c 3)
+ (a 1 c 3 d 4)
+ (b 2 c 3 d 4)
+ (a 1 b 2 c 3)
+ nil
+ nil
+ t))
+
+(deftest delete-from-plist.1
+ (let ((orig '(a 1 b 2 c 3 d 4 d 5)))
+ (list (delete-from-plist (copy-list orig) 'a 'c)
+ (delete-from-plist (copy-list orig) 'b 'd)
+ (delete-from-plist (copy-list orig) 'b)
+ (delete-from-plist (copy-list orig) 'a)
+ (delete-from-plist (copy-list orig) 'd 42 "zot")
+ (delete-from-plist (copy-list orig) 'a 'b 'c 'd)
+ (delete-from-plist (copy-list orig) 'a 'b 'c 'd 'x)
+ (equal orig (delete-from-plist orig))
+ (eq orig (delete-from-plist orig))))
+ ((b 2 d 4 d 5)
+ (a 1 c 3)
+ (a 1 c 3 d 4 d 5)
+ (b 2 c 3 d 4 d 5)
+ (a 1 b 2 c 3)
+ nil
+ nil
+ t
+ t))
+
+(deftest mappend.1
+ (mappend (compose 'list '*) '(1 2 3) '(1 2 3))
+ (1 4 9))
+
+(deftest assoc-value.1
+ (let ((key1 '(complex key))
+ (key2 'simple-key)
+ (alist '())
+ (result '()))
+ (push 1 (assoc-value alist key1 :test #'equal))
+ (push 2 (assoc-value alist key1 :test 'equal))
+ (push 42 (assoc-value alist key2))
+ (push 43 (assoc-value alist key2 :test 'eq))
+ (push (assoc-value alist key1 :test #'equal) result)
+ (push (assoc-value alist key2) result)
+
+ (push 'very (rassoc-value alist (list 2 1) :test #'equal))
+ (push (cdr (assoc '(very complex key) alist :test #'equal)) result)
+ result)
+ ((2 1) (43 42) (2 1)))
+
+;;;; Numbers
+
+(deftest clamp.1
+ (list (clamp 1.5 1 2)
+ (clamp 2.0 1 2)
+ (clamp 1.0 1 2)
+ (clamp 3 1 2)
+ (clamp 0 1 2))
+ (1.5 2.0 1.0 2 1))
+
+(deftest gaussian-random.1
+ (let ((min -0.2)
+ (max +0.2))
+ (multiple-value-bind (g1 g2)
+ (gaussian-random min max)
+ (values (<= min g1 max)
+ (<= min g2 max)
+ (/= g1 g2) ;uh
+ )))
+ t
+ t
+ t)
+
+#+sbcl
+(deftest gaussian-random.2
+ (handler-case
+ (sb-ext:with-timeout 2
+ (progn
+ (loop
+ :repeat 10000
+ :do (gaussian-random 0 nil))
+ 'done))
+ (sb-ext:timeout ()
+ 'timed-out))
+ done)
+
+(deftest iota.1
+ (iota 3)
+ (0 1 2))
+
+(deftest iota.2
+ (iota 3 :start 0.0d0)
+ (0.0d0 1.0d0 2.0d0))
+
+(deftest iota.3
+ (iota 3 :start 2 :step 3.0)
+ (2.0 5.0 8.0))
+
+(deftest map-iota.1
+ (let (all)
+ (declare (notinline map-iota))
+ (values (map-iota (lambda (x) (push x all))
+ 3
+ :start 2
+ :step 1.1d0)
+ all))
+ 3
+ (4.2d0 3.1d0 2.0d0))
+
+(deftest lerp.1
+ (lerp 0.5 1 2)
+ 1.5)
+
+(deftest lerp.2
+ (lerp 0.1 1 2)
+ 1.1)
+
+(deftest lerp.3
+ (lerp 0.1 4 25)
+ 6.1)
+
+(deftest mean.1
+ (mean '(1 2 3))
+ 2)
+
+(deftest mean.2
+ (mean '(1 2 3 4))
+ 5/2)
+
+(deftest mean.3
+ (mean '(1 2 10))
+ 13/3)
+
+(deftest median.1
+ (median '(100 0 99 1 98 2 97))
+ 97)
+
+(deftest median.2
+ (median '(100 0 99 1 98 2 97 96))
+ 193/2)
+
+(deftest variance.1
+ (variance (list 1 2 3))
+ 2/3)
+
+(deftest standard-deviation.1
+ (< 0 (standard-deviation (list 1 2 3)) 1)
+ t)
+
+(deftest maxf.1
+ (let ((x 1))
+ (maxf x 2)
+ x)
+ 2)
+
+(deftest maxf.2
+ (let ((x 1))
+ (maxf x 0)
+ x)
+ 1)
+
+(deftest maxf.3
+ (let ((x 1)
+ (c 0))
+ (maxf x (incf c))
+ (list x c))
+ (1 1))
+
+(deftest maxf.4
+ (let ((xv (vector 0 0 0))
+ (p 0))
+ (maxf (svref xv (incf p)) (incf p))
+ (list p xv))
+ (2 #(0 2 0)))
+
+(deftest minf.1
+ (let ((y 1))
+ (minf y 0)
+ y)
+ 0)
+
+(deftest minf.2
+ (let ((xv (vector 10 10 10))
+ (p 0))
+ (minf (svref xv (incf p)) (incf p))
+ (list p xv))
+ (2 #(10 2 10)))
+
+(deftest subfactorial.1
+ (mapcar #'subfactorial (iota 22))
+ (1
+ 0
+ 1
+ 2
+ 9
+ 44
+ 265
+ 1854
+ 14833
+ 133496
+ 1334961
+ 14684570
+ 176214841
+ 2290792932
+ 32071101049
+ 481066515734
+ 7697064251745
+ 130850092279664
+ 2355301661033953
+ 44750731559645106
+ 895014631192902121
+ 18795307255050944540))
+
+;;;; Arrays
+
+#+nil
+(deftest array-index.type)
+
+#+nil
+(deftest copy-array)
+
+;;;; Sequences
+
+(deftest rotate.1
+ (list (rotate (list 1 2 3) 0)
+ (rotate (list 1 2 3) 1)
+ (rotate (list 1 2 3) 2)
+ (rotate (list 1 2 3) 3)
+ (rotate (list 1 2 3) 4))
+ ((1 2 3)
+ (3 1 2)
+ (2 3 1)
+ (1 2 3)
+ (3 1 2)))
+
+(deftest rotate.2
+ (list (rotate (vector 1 2 3 4) 0)
+ (rotate (vector 1 2 3 4))
+ (rotate (vector 1 2 3 4) 2)
+ (rotate (vector 1 2 3 4) 3)
+ (rotate (vector 1 2 3 4) 4)
+ (rotate (vector 1 2 3 4) 5))
+ (#(1 2 3 4)
+ #(4 1 2 3)
+ #(3 4 1 2)
+ #(2 3 4 1)
+ #(1 2 3 4)
+ #(4 1 2 3)))
+
+(deftest rotate.3
+ (list (rotate (list 1 2 3) 0)
+ (rotate (list 1 2 3) -1)
+ (rotate (list 1 2 3) -2)
+ (rotate (list 1 2 3) -3)
+ (rotate (list 1 2 3) -4))
+ ((1 2 3)
+ (2 3 1)
+ (3 1 2)
+ (1 2 3)
+ (2 3 1)))
+
+(deftest rotate.4
+ (list (rotate (vector 1 2 3 4) 0)
+ (rotate (vector 1 2 3 4) -1)
+ (rotate (vector 1 2 3 4) -2)
+ (rotate (vector 1 2 3 4) -3)
+ (rotate (vector 1 2 3 4) -4)
+ (rotate (vector 1 2 3 4) -5))
+ (#(1 2 3 4)
+ #(2 3 4 1)
+ #(3 4 1 2)
+ #(4 1 2 3)
+ #(1 2 3 4)
+ #(2 3 4 1)))
+
+(deftest rotate.5
+ (values (rotate (list 1) 17)
+ (rotate (list 1) -5))
+ (1)
+ (1))
+
+(deftest shuffle.1
+ (let ((s (shuffle (iota 100))))
+ (list (equal s (iota 100))
+ (every (lambda (x)
+ (member x s))
+ (iota 100))
+ (every (lambda (x)
+ (typep x '(integer 0 99)))
+ s)))
+ (nil t t))
+
+(deftest shuffle.2
+ (let ((s (shuffle (coerce (iota 100) 'vector))))
+ (list (equal s (coerce (iota 100) 'vector))
+ (every (lambda (x)
+ (find x s))
+ (iota 100))
+ (every (lambda (x)
+ (typep x '(integer 0 99)))
+ s)))
+ (nil t t))
+
+(deftest shuffle.3
+ (let* ((orig (coerce (iota 21) 'vector))
+ (copy (copy-seq orig)))
+ (shuffle copy :start 10 :end 15)
+ (list (every #'eql (subseq copy 0 10) (subseq orig 0 10))
+ (every #'eql (subseq copy 15) (subseq orig 15))))
+ (t t))
+
+(deftest random-elt.1
+ (let ((s1 #(1 2 3 4))
+ (s2 '(1 2 3 4)))
+ (list (dotimes (i 1000 nil)
+ (unless (member (random-elt s1) s2)
+ (return nil))
+ (when (/= (random-elt s1) (random-elt s1))
+ (return t)))
+ (dotimes (i 1000 nil)
+ (unless (member (random-elt s2) s2)
+ (return nil))
+ (when (/= (random-elt s2) (random-elt s2))
+ (return t)))))
+ (t t))
+
+(deftest removef.1
+ (let* ((x '(1 2 3))
+ (x* x)
+ (y #(1 2 3))
+ (y* y))
+ (removef x 1)
+ (removef y 3)
+ (list x x* y y*))
+ ((2 3)
+ (1 2 3)
+ #(1 2)
+ #(1 2 3)))
+
+(deftest deletef.1
+ (let* ((x (list 1 2 3))
+ (x* x)
+ (y (vector 1 2 3)))
+ (deletef x 2)
+ (deletef y 1)
+ (list x x* y))
+ ((1 3)
+ (1 3)
+ #(2 3)))
+
+(deftest map-permutations.1
+ (let ((seq (list 1 2 3))
+ (seen nil)
+ (ok t))
+ (map-permutations (lambda (s)
+ (unless (set-equal s seq)
+ (setf ok nil))
+ (when (member s seen :test 'equal)
+ (setf ok nil))
+ (push s seen))
+ seq
+ :copy t)
+ (values ok (length seen)))
+ t
+ 6)
+
+(deftest proper-sequence.type.1
+ (mapcar (lambda (x)
+ (typep x 'proper-sequence))
+ (list (list 1 2 3)
+ (vector 1 2 3)
+ #2a((1 2) (3 4))
+ (circular-list 1 2 3 4)))
+ (t t nil nil))
+
+(deftest emptyp.1
+ (mapcar #'emptyp
+ (list (list 1)
+ (circular-list 1)
+ nil
+ (vector)
+ (vector 1)))
+ (nil nil t t nil))
+
+(deftest sequence-of-length-p.1
+ (mapcar #'sequence-of-length-p
+ (list nil
+ #()
+ (list 1)
+ (vector 1)
+ (list 1 2)
+ (vector 1 2)
+ (list 1 2)
+ (vector 1 2)
+ (list 1 2)
+ (vector 1 2))
+ (list 0
+ 0
+ 1
+ 1
+ 2
+ 2
+ 1
+ 1
+ 4
+ 4))
+ (t t t t t t nil nil nil nil))
+
+(deftest length=.1
+ (mapcar #'length=
+ (list nil
+ #()
+ (list 1)
+ (vector 1)
+ (list 1 2)
+ (vector 1 2)
+ (list 1 2)
+ (vector 1 2)
+ (list 1 2)
+ (vector 1 2))
+ (list 0
+ 0
+ 1
+ 1
+ 2
+ 2
+ 1
+ 1
+ 4
+ 4))
+ (t t t t t t nil nil nil nil))
+
+(deftest length=.2
+ ;; test the compiler macro
+ (macrolet ((x (&rest args)
+ (funcall
+ (compile nil
+ `(lambda ()
+ (length= ,@args))))))
+ (list (x 2 '(1 2))
+ (x '(1 2) '(3 4))
+ (x '(1 2) 2)
+ (x '(1 2) 2 '(3 4))
+ (x 1 2 3)))
+ (t t t t nil))
+
+(deftest copy-sequence.1
+ (let ((l (list 1 2 3))
+ (v (vector #\a #\b #\c)))
+ (declare (notinline copy-sequence))
+ (let ((l.list (copy-sequence 'list l))
+ (l.vector (copy-sequence 'vector l))
+ (l.spec-v (copy-sequence '(vector fixnum) l))
+ (v.vector (copy-sequence 'vector v))
+ (v.list (copy-sequence 'list v))
+ (v.string (copy-sequence 'string v)))
+ (list (member l (list l.list l.vector l.spec-v))
+ (member v (list v.vector v.list v.string))
+ (equal l.list l)
+ (equalp l.vector #(1 2 3))
+ (type= (upgraded-array-element-type 'fixnum)
+ (array-element-type l.spec-v))
+ (equalp v.vector v)
+ (equal v.list '(#\a #\b #\c))
+ (equal "abc" v.string))))
+ (nil nil t t t t t t))
+
+(deftest first-elt.1
+ (mapcar #'first-elt
+ (list (list 1 2 3)
+ "abc"
+ (vector :a :b :c)))
+ (1 #\a :a))
+
+(deftest first-elt.error.1
+ (mapcar (lambda (x)
+ (handler-case
+ (first-elt x)
+ (type-error ()
+ :type-error)))
+ (list nil
+ #()
+ 12
+ :zot))
+ (:type-error
+ :type-error
+ :type-error
+ :type-error))
+
+(deftest setf-first-elt.1
+ (let ((l (list 1 2 3))
+ (s (copy-seq "foobar"))
+ (v (vector :a :b :c)))
+ (setf (first-elt l) -1
+ (first-elt s) #\x
+ (first-elt v) 'zot)
+ (values l s v))
+ (-1 2 3)
+ "xoobar"
+ #(zot :b :c))
+
+(deftest setf-first-elt.error.1
+ (let ((l 'foo))
+ (multiple-value-bind (res err)
+ (ignore-errors (setf (first-elt l) 4))
+ (typep err 'type-error)))
+ t)
+
+(deftest last-elt.1
+ (mapcar #'last-elt
+ (list (list 1 2 3)
+ (vector :a :b :c)
+ "FOOBAR"
+ #*001
+ #*010))
+ (3 :c #\R 1 0))
+
+(deftest last-elt.error.1
+ (mapcar (lambda (x)
+ (handler-case
+ (last-elt x)
+ (type-error ()
+ :type-error)))
+ (list nil
+ #()
+ 12
+ :zot
+ (circular-list 1 2 3)
+ (list* 1 2 3 (circular-list 4 5))))
+ (:type-error
+ :type-error
+ :type-error
+ :type-error
+ :type-error
+ :type-error))
+
+(deftest setf-last-elt.1
+ (let ((l (list 1 2 3))
+ (s (copy-seq "foobar"))
+ (b (copy-seq #*010101001)))
+ (setf (last-elt l) '???
+ (last-elt s) #\?
+ (last-elt b) 0)
+ (values l s b))
+ (1 2 ???)
+ "fooba?"
+ #*010101000)
+
+(deftest setf-last-elt.error.1
+ (handler-case
+ (setf (last-elt 'foo) 13)
+ (type-error ()
+ :type-error))
+ :type-error)
+
+(deftest starts-with.1
+ (list (starts-with 1 '(1 2 3))
+ (starts-with 1 #(1 2 3))
+ (starts-with #\x "xyz")
+ (starts-with 2 '(1 2 3))
+ (starts-with 3 #(1 2 3))
+ (starts-with 1 1)
+ (starts-with nil nil))
+ (t t t nil nil nil nil))
+
+(deftest starts-with.2
+ (values (starts-with 1 '(-1 2 3) :key '-)
+ (starts-with "foo" '("foo" "bar") :test 'equal)
+ (starts-with "f" '(#\f) :key 'string :test 'equal)
+ (starts-with -1 '(0 1 2) :key #'1+)
+ (starts-with "zot" '("ZOT") :test 'equal))
+ t
+ t
+ t
+ nil
+ nil)
+
+(deftest ends-with.1
+ (list (ends-with 3 '(1 2 3))
+ (ends-with 3 #(1 2 3))
+ (ends-with #\z "xyz")
+ (ends-with 2 '(1 2 3))
+ (ends-with 1 #(1 2 3))
+ (ends-with 1 1)
+ (ends-with nil nil))
+ (t t t nil nil nil nil))
+
+(deftest ends-with.2
+ (values (ends-with 2 '(0 13 1) :key '1+)
+ (ends-with "foo" (vector "bar" "foo") :test 'equal)
+ (ends-with "X" (vector 1 2 #\X) :key 'string :test 'equal)
+ (ends-with "foo" "foo" :test 'equal))
+ t
+ t
+ t
+ nil)
+
+(deftest ends-with.error.1
+ (handler-case
+ (ends-with 3 (circular-list 3 3 3 1 3 3))
+ (type-error ()
+ :type-error))
+ :type-error)
+
+(deftest sequences.passing-improper-lists
+ (macrolet ((signals-error-p (form)
+ `(handler-case
+ (progn ,form nil)
+ (type-error (e)
+ t)))
+ (cut (fn &rest args)
+ (with-gensyms (arg)
+ (print`(lambda (,arg)
+ (apply ,fn (list ,@(substitute arg '_ args))))))))
+ (let ((circular-list (make-circular-list 5 :initial-element :foo))
+ (dotted-list (list* 'a 'b 'c 'd)))
+ (loop for nth from 0
+ for fn in (list
+ (cut #'lastcar _)
+ (cut #'rotate _ 3)
+ (cut #'rotate _ -3)
+ (cut #'shuffle _)
+ (cut #'random-elt _)
+ (cut #'last-elt _)
+ (cut #'ends-with :foo _))
+ nconcing
+ (let ((on-circular-p (signals-error-p (funcall fn circular-list)))
+ (on-dotted-p (signals-error-p (funcall fn dotted-list))))
+ (when (or (not on-circular-p) (not on-dotted-p))
+ (append
+ (unless on-circular-p
+ (let ((*print-circle* t))
+ (list
+ (format nil
+ "No appropriate error signalled when passing ~S to ~Ath entry."
+ circular-list nth))))
+ (unless on-dotted-p
+ (list
+ (format nil
+ "No appropriate error signalled when passing ~S to ~Ath entry."
+ dotted-list nth)))))))))
+ nil)
+
+;;;; IO
+
+(deftest read-stream-content-into-string.1
+ (values (with-input-from-string (stream "foo bar")
+ (read-stream-content-into-string stream))
+ (with-input-from-string (stream "foo bar")
+ (read-stream-content-into-string stream :buffer-size 1))
+ (with-input-from-string (stream "foo bar")
+ (read-stream-content-into-string stream :buffer-size 6))
+ (with-input-from-string (stream "foo bar")
+ (read-stream-content-into-string stream :buffer-size 7)))
+ "foo bar"
+ "foo bar"
+ "foo bar"
+ "foo bar")
+
+(deftest read-stream-content-into-string.2
+ (handler-case
+ (let ((stream (make-broadcast-stream)))
+ (read-stream-content-into-string stream :buffer-size 0))
+ (type-error ()
+ :type-error))
+ :type-error)
+
+#+(or)
+(defvar *octets*
+ (map '(simple-array (unsigned-byte 8) (7)) #'char-code "foo bar"))
+
+#+(or)
+(deftest read-stream-content-into-byte-vector.1
+ (values (with-input-from-byte-vector (stream *octets*)
+ (read-stream-content-into-byte-vector stream))
+ (with-input-from-byte-vector (stream *octets*)
+ (read-stream-content-into-byte-vector stream :initial-size 1))
+ (with-input-from-byte-vector (stream *octets*)
+ (read-stream-content-into-byte-vector stream 'alexandria::%length 6))
+ (with-input-from-byte-vector (stream *octets*)
+ (read-stream-content-into-byte-vector stream 'alexandria::%length 3)))
+ *octets*
+ *octets*
+ *octets*
+ (subseq *octets* 0 3))
+
+(deftest read-stream-content-into-byte-vector.2
+ (handler-case
+ (let ((stream (make-broadcast-stream)))
+ (read-stream-content-into-byte-vector stream :initial-size 0))
+ (type-error ()
+ :type-error))
+ :type-error)
+
+;;;; Macros
+
+(deftest with-unique-names.1
+ (let ((*gensym-counter* 0))
+ (let ((syms (with-unique-names (foo bar quux)
+ (list foo bar quux))))
+ (list (find-if #'symbol-package syms)
+ (equal '("FOO0" "BAR1" "QUUX2")
+ (mapcar #'symbol-name syms)))))
+ (nil t))
+
+(deftest with-unique-names.2
+ (let ((*gensym-counter* 0))
+ (let ((syms (with-unique-names ((foo "_foo_") (bar -bar-) (quux #\q))
+ (list foo bar quux))))
+ (list (find-if #'symbol-package syms)
+ (equal '("_foo_0" "-BAR-1" "q2")
+ (mapcar #'symbol-name syms)))))
+ (nil t))
+
+(deftest with-unique-names.3
+ (let ((*gensym-counter* 0))
+ (multiple-value-bind (res err)
+ (ignore-errors
+ (eval
+ '(let ((syms
+ (with-unique-names ((foo "_foo_") (bar -bar-) (quux 42))
+ (list foo bar quux))))
+ (list (find-if #'symbol-package syms)
+ (equal '("_foo_0" "-BAR-1" "q2")
+ (mapcar #'symbol-name syms))))))
+ (errorp err)))
+ t)
+
+(deftest once-only.1
+ (macrolet ((cons1.good (x)
+ (once-only (x)
+ `(cons ,x ,x)))
+ (cons1.bad (x)
+ `(cons ,x ,x)))
+ (let ((y 0))
+ (list (cons1.good (incf y))
+ y
+ (cons1.bad (incf y))
+ y)))
+ ((1 . 1) 1 (2 . 3) 3))
+
+(deftest once-only.2
+ (macrolet ((cons1 (x)
+ (once-only ((y x))
+ `(cons ,y ,y))))
+ (let ((z 0))
+ (list (cons1 (incf z))
+ z
+ (cons1 (incf z)))))
+ ((1 . 1) 1 (2 . 2)))
+
+(deftest parse-body.1
+ (parse-body '("doc" "body") :documentation t)
+ ("body")
+ nil
+ "doc")
+
+(deftest parse-body.2
+ (parse-body '("body") :documentation t)
+ ("body")
+ nil
+ nil)
+
+(deftest parse-body.3
+ (parse-body '("doc" "body"))
+ ("doc" "body")
+ nil
+ nil)
+
+(deftest parse-body.4
+ (parse-body '((declare (foo)) "doc" (declare (bar)) body) :documentation t)
+ (body)
+ ((declare (foo)) (declare (bar)))
+ "doc")
+
+(deftest parse-body.5
+ (parse-body '((declare (foo)) "doc" (declare (bar)) body))
+ ("doc" (declare (bar)) body)
+ ((declare (foo)))
+ nil)
+
+(deftest parse-body.6
+ (multiple-value-bind (res err)
+ (ignore-errors
+ (parse-body '("foo" "bar" "quux")
+ :documentation t))
+ (errorp err))
+ t)
+
+;;;; Symbols
+
+(deftest ensure-symbol.1
+ (ensure-symbol :cons :cl)
+ cons
+ :external)
+
+(deftest ensure-symbol.2
+ (ensure-symbol "CONS" :alexandria)
+ cons
+ :inherited)
+
+(deftest ensure-symbol.3
+ (ensure-symbol 'foo :keyword)
+ :foo
+ :external)
+
+(deftest ensure-symbol.4
+ (ensure-symbol #\* :alexandria)
+ *
+ :inherited)
+
+(deftest format-symbol.1
+ (let ((s (format-symbol nil '#:x-~d 13)))
+ (list (symbol-package s)
+ (string= (string '#:x-13) (symbol-name s))))
+ (nil t))
+
+(deftest format-symbol.2
+ (format-symbol :keyword '#:sym-~a (string :bolic))
+ :sym-bolic)
+
+(deftest format-symbol.3
+ (let ((*package* (find-package :cl)))
+ (format-symbol t '#:find-~a (string 'package)))
+ find-package)
+
+(deftest make-keyword.1
+ (list (make-keyword 'zot)
+ (make-keyword "FOO")
+ (make-keyword #\Q))
+ (:zot :foo :q))
+
+(deftest make-gensym-list.1
+ (let ((*gensym-counter* 0))
+ (let ((syms (make-gensym-list 3 "FOO")))
+ (list (find-if 'symbol-package syms)
+ (equal '("FOO0" "FOO1" "FOO2")
+ (mapcar 'symbol-name syms)))))
+ (nil t))
+
+(deftest make-gensym-list.2
+ (let ((*gensym-counter* 0))
+ (let ((syms (make-gensym-list 3)))
+ (list (find-if 'symbol-package syms)
+ (equal '("G0" "G1" "G2")
+ (mapcar 'symbol-name syms)))))
+ (nil t))
+
+;;;; Type-system
+
+(deftest of-type.1
+ (locally
+ (declare (notinline of-type))
+ (let ((f (of-type 'string)))
+ (list (funcall f "foo")
+ (funcall f 'bar))))
+ (t nil))
+
+(deftest type=.1
+ (type= 'string 'string)
+ t
+ t)
+
+(deftest type=.2
+ (type= 'list '(or null cons))
+ t
+ t)
+
+(deftest type=.3
+ (type= 'null '(and symbol list))
+ t
+ t)
+
+(deftest type=.4
+ (type= 'string '(satisfies emptyp))
+ nil
+ nil)
+
+(deftest type=.5
+ (type= 'string 'list)
+ nil
+ t)
+
+(macrolet
+ ((test (type numbers)
+ `(deftest ,(format-symbol t '#:cdr5.~a (string type))
+ (let ((numbers ,numbers))
+ (values (mapcar (of-type ',(format-symbol t '#:negative-~a (string type))) numbers)
+ (mapcar (of-type ',(format-symbol t '#:non-positive-~a (string type))) numbers)
+ (mapcar (of-type ',(format-symbol t '#:non-negative-~a (string type))) numbers)
+ (mapcar (of-type ',(format-symbol t '#:positive-~a (string type))) numbers)))
+ (t t t nil nil nil nil)
+ (t t t t nil nil nil)
+ (nil nil nil t t t t)
+ (nil nil nil nil t t t))))
+ (test fixnum (list most-negative-fixnum -42 -1 0 1 42 most-positive-fixnum))
+ (test integer (list (1- most-negative-fixnum) -42 -1 0 1 42 (1+ most-positive-fixnum)))
+ (test rational (list (1- most-negative-fixnum) -42/13 -1 0 1 42/13 (1+ most-positive-fixnum)))
+ (test real (list most-negative-long-float -42/13 -1 0 1 42/13 most-positive-long-float))
+ (test float (list most-negative-short-float -42.02 -1.0 0.0 1.0 42.02 most-positive-short-float))
+ (test short-float (list most-negative-short-float -42.02s0 -1.0s0 0.0s0 1.0s0 42.02s0 most-positive-short-float))
+ (test single-float (list most-negative-single-float -42.02f0 -1.0f0 0.0f0 1.0f0 42.02f0 most-positive-single-float))
+ (test double-float (list most-negative-double-float -42.02d0 -1.0d0 0.0d0 1.0d0 42.02d0 most-positive-double-float))
+ (test long-float (list most-negative-long-float -42.02l0 -1.0l0 0.0l0 1.0l0 42.02l0 most-positive-long-float)))
+
+;;;; Bindings
+
+(declaim (notinline opaque))
+(defun opaque (x)
+ x)
+
+(deftest if-let.1
+ (if-let (x (opaque :ok))
+ x
+ :bad)
+ :ok)
+
+(deftest if-let.2
+ (if-let (x (opaque nil))
+ :bad
+ (and (not x) :ok))
+ :ok)
+
+(deftest if-let.3
+ (let ((x 1))
+ (if-let ((x 2)
+ (y x))
+ (+ x y)
+ :oops))
+ 3)
+
+(deftest if-let.4
+ (if-let ((x 1)
+ (y nil))
+ :oops
+ (and (not y) x))
+ 1)
+
+(deftest if-let.5
+ (if-let (x)
+ :oops
+ (not x))
+ t)
+
+(deftest if-let.error.1
+ (handler-case
+ (eval '(if-let x
+ :oops
+ :oops))
+ (type-error ()
+ :type-error))
+ :type-error)
+
+(deftest when-let.1
+ (when-let (x (opaque :ok))
+ (setf x (cons x x))
+ x)
+ (:ok . :ok))
+
+(deftest when-let.2
+ (when-let ((x 1)
+ (y nil)
+ (z 3))
+ :oops)
+ nil)
+
+(deftest when-let.3
+ (let ((x 1))
+ (when-let ((x 2)
+ (y x))
+ (+ x y)))
+ 3)
+
+(deftest when-let.error.1
+ (handler-case
+ (eval '(when-let x :oops))
+ (type-error ()
+ :type-error))
+ :type-error)
+
+(deftest when-let*.1
+ (let ((x 1))
+ (when-let* ((x 2)
+ (y x))
+ (+ x y)))
+ 4)
+
+(deftest when-let*.2
+ (let ((y 1))
+ (when-let* (x y)
+ (1+ x)))
+ 2)
+
+(deftest when-let*.3
+ (when-let* ((x t)
+ (y (consp x))
+ (z (error "OOPS")))
+ t)
+ nil)
+
+(deftest when-let*.error.1
+ (handler-case
+ (eval '(when-let* x :oops))
+ (type-error ()
+ :type-error))
+ :type-error)
+
+(deftest doplist.1
+ (let (keys values)
+ (doplist (k v '(a 1 b 2 c 3) (values t (reverse keys) (reverse values) k v))
+ (push k keys)
+ (push v values)))
+ t
+ (a b c)
+ (1 2 3)
+ nil
+ nil)
+
+(deftest count-permutations.1
+ (values (count-permutations 31 7)
+ (count-permutations 1 1)
+ (count-permutations 2 1)
+ (count-permutations 2 2)
+ (count-permutations 3 2)
+ (count-permutations 3 1))
+ 13253058000
+ 1
+ 2
+ 2
+ 6
+ 3)
+
+(deftest binomial-coefficient.1
+ (alexandria:binomial-coefficient 1239 139)
+ 28794902202288970200771694600561826718847179309929858835480006683522184441358211423695124921058123706380656375919763349913245306834194782172712255592710204598527867804110129489943080460154)
+
+;; Exercise bignum case (at least on x86).
+(deftest binomial-coefficient.2
+ (alexandria:binomial-coefficient 2000000000000 20)
+ 430998041177272843950422879590338454856322722740402365741730748431530623813012487773080486408378680853987520854296499536311275320016878730999689934464711239072435565454954447356845336730100919970769793030177499999999900000000000)
+
+(deftest copy-stream.1
+ (let ((data "sdkfjhsakfh weior763495ewofhsdfk sdfadlkfjhsadf woif sdlkjfhslkdfh sdklfjh"))
+ (values (equal data
+ (with-input-from-string (in data)
+ (with-output-to-string (out)
+ (alexandria:copy-stream in out))))
+ (equal (subseq data 10 20)
+ (with-input-from-string (in data)
+ (with-output-to-string (out)
+ (alexandria:copy-stream in out :start 10 :end 20))))
+ (equal (subseq data 10)
+ (with-input-from-string (in data)
+ (with-output-to-string (out)
+ (alexandria:copy-stream in out :start 10))))
+ (equal (subseq data 0 20)
+ (with-input-from-string (in data)
+ (with-output-to-string (out)
+ (alexandria:copy-stream in out :end 20))))))
+ t
+ t
+ t
+ t)
+
+(deftest extremum.1
+ (let ((n 0))
+ (dotimes (i 10)
+ (let ((data (shuffle (coerce (iota 10000 :start i) 'vector)))
+ (ok t))
+ (unless (eql i (extremum data #'<))
+ (setf ok nil))
+ (unless (eql i (extremum (coerce data 'list) #'<))
+ (setf ok nil))
+ (unless (eql (+ 9999 i) (extremum data #'>))
+ (setf ok nil))
+ (unless (eql (+ 9999 i) (extremum (coerce data 'list) #'>))
+ (setf ok nil))
+ (when ok
+ (incf n))))
+ (when (eql 10 (extremum #(100 1 10 1000) #'> :start 1 :end 3))
+ (incf n))
+ (when (eql -1000 (extremum #(100 1 10 -1000) #'> :key 'abs))
+ (incf n))
+ (when (eq nil (extremum "" (lambda (a b) (error "wtf? ~S, ~S" a b))))
+ (incf n))
+ n)
+ 13)
+
+(deftest starts-with-subseq.string
+ (starts-with-subseq "f" "foo" :return-suffix t)
+ t
+ "oo")
+
+(deftest starts-with-subseq.vector
+ (starts-with-subseq #(1) #(1 2 3) :return-suffix t)
+ t
+ #(2 3))
+
+(deftest starts-with-subseq.list
+ (starts-with-subseq '(1) '(1 2 3) :return-suffix t)
+ t
+ (2 3))
+
+(deftest starts-with-subseq.start1
+ (starts-with-subseq "foo" "oop" :start1 1)
+ t
+ nil)
+
+(deftest starts-with-subseq.start2
+ (starts-with-subseq "foo" "xfoop" :start2 1)
+ t
+ nil)
+
+(deftest format-symbol.print-case-bound
+ (let ((upper (intern "FOO-BAR"))
+ (lower (intern "foo-bar"))
+ (*print-escape* nil))
+ (values
+ (let ((*print-case* :downcase))
+ (and (eq upper (format-symbol t "~A" upper))
+ (eq lower (format-symbol t "~A" lower))))
+ (let ((*print-case* :upcase))
+ (and (eq upper (format-symbol t "~A" upper))
+ (eq lower (format-symbol t "~A" lower))))
+ (let ((*print-case* :capitalize))
+ (and (eq upper (format-symbol t "~A" upper))
+ (eq lower (format-symbol t "~A" lower))))))
+ t
+ t
+ t)
+
+(deftest iota.fp-start-and-complex-integer-step
+ (equal '(#C(0.0 0.0) #C(0.0 2.0) #C(0.0 4.0))
+ (iota 3 :start 0.0 :step #C(0 2)))
+ t)
+
+(deftest parse-ordinary-lambda-list.1
+ (multiple-value-bind (req opt rest keys allowp aux keyp)
+ (parse-ordinary-lambda-list '(a b c
+ &optional o1 (o2 42) (o3 42 o3-supplied?)
+ &key (k1) ((:key k2)) (k3 42 k3-supplied?))
+ :normalize t)
+ (and (equal '(a b c) req)
+ (equal '((o1 nil nil)
+ (o2 42 nil)
+ (o3 42 o3-supplied?))
+ opt)
+ (equal '(((:k1 k1) nil nil)
+ ((:key k2) nil nil)
+ ((:k3 k3) 42 k3-supplied?))
+ keys)
+ (not allowp)
+ (not aux)
+ (eq t keyp)))
+ t)
--- /dev/null
+(in-package :alexandria)
+
+(deftype array-index (&optional (length (1- array-dimension-limit)))
+ "Type designator for an index into array of LENGTH: an integer between
+0 (inclusive) and LENGTH (exclusive). LENGTH defaults to one less than
+ARRAY-DIMENSION-LIMIT."
+ `(integer 0 (,length)))
+
+(deftype array-length (&optional (length (1- array-dimension-limit)))
+ "Type designator for a dimension of an array of LENGTH: an integer between
+0 (inclusive) and LENGTH (inclusive). LENGTH defaults to one less than
+ARRAY-DIMENSION-LIMIT."
+ `(integer 0 ,length))
+
+;; This MACROLET will generate most of CDR5 (http://cdr.eurolisp.org/document/5/)
+;; except the RATIO related definitions and ARRAY-INDEX.
+(macrolet
+ ((frob (type &optional (base-type type))
+ (let ((subtype-names (list))
+ (predicate-names (list)))
+ (flet ((make-subtype-name (format-control)
+ (let ((result (format-symbol :alexandria format-control
+ (symbol-name type))))
+ (push result subtype-names)
+ result))
+ (make-predicate-name (sybtype-name)
+ (let ((result (format-symbol :alexandria '#:~A-p
+ (symbol-name sybtype-name))))
+ (push result predicate-names)
+ result))
+ (make-docstring (range-beg range-end range-type)
+ (let ((inf (ecase range-type (:negative "-inf") (:positive "+inf"))))
+ (format nil "Type specifier denoting the ~(~A~) range from ~A to ~A."
+ type
+ (if (equal range-beg ''*) inf (ensure-car range-beg))
+ (if (equal range-end ''*) inf (ensure-car range-end))))))
+ (let* ((negative-name (make-subtype-name '#:negative-~a))
+ (non-positive-name (make-subtype-name '#:non-positive-~a))
+ (non-negative-name (make-subtype-name '#:non-negative-~a))
+ (positive-name (make-subtype-name '#:positive-~a))
+ (negative-p-name (make-predicate-name negative-name))
+ (non-positive-p-name (make-predicate-name non-positive-name))
+ (non-negative-p-name (make-predicate-name non-negative-name))
+ (positive-p-name (make-predicate-name positive-name))
+ (negative-extremum)
+ (positive-extremum)
+ (below-zero)
+ (above-zero)
+ (zero))
+ (setf (values negative-extremum below-zero
+ above-zero positive-extremum zero)
+ (ecase type
+ (fixnum (values 'most-negative-fixnum -1 1 'most-positive-fixnum 0))
+ (integer (values ''* -1 1 ''* 0))
+ (rational (values ''* '(0) '(0) ''* 0))
+ (real (values ''* '(0) '(0) ''* 0))
+ (float (values ''* '(0.0E0) '(0.0E0) ''* 0.0E0))
+ (short-float (values ''* '(0.0S0) '(0.0S0) ''* 0.0S0))
+ (single-float (values ''* '(0.0F0) '(0.0F0) ''* 0.0F0))
+ (double-float (values ''* '(0.0D0) '(0.0D0) ''* 0.0D0))
+ (long-float (values ''* '(0.0L0) '(0.0L0) ''* 0.0L0))))
+ `(progn
+ (deftype ,negative-name ()
+ ,(make-docstring negative-extremum below-zero :negative)
+ `(,',base-type ,,negative-extremum ,',below-zero))
+
+ (deftype ,non-positive-name ()
+ ,(make-docstring negative-extremum zero :negative)
+ `(,',base-type ,,negative-extremum ,',zero))
+
+ (deftype ,non-negative-name ()
+ ,(make-docstring zero positive-extremum :positive)
+ `(,',base-type ,',zero ,,positive-extremum))
+
+ (deftype ,positive-name ()
+ ,(make-docstring above-zero positive-extremum :positive)
+ `(,',base-type ,',above-zero ,,positive-extremum))
+
+ (declaim (inline ,@predicate-names))
+
+ (defun ,negative-p-name (n)
+ (and (typep n ',type)
+ (< n ,zero)))
+
+ (defun ,non-positive-p-name (n)
+ (and (typep n ',type)
+ (<= n ,zero)))
+
+ (defun ,non-negative-p-name (n)
+ (and (typep n ',type)
+ (<= ,zero n)))
+
+ (defun ,positive-p-name (n)
+ (and (typep n ',type)
+ (< ,zero n)))))))))
+ (frob fixnum integer)
+ (frob integer)
+ (frob rational)
+ (frob real)
+ (frob float)
+ (frob short-float)
+ (frob single-float)
+ (frob double-float)
+ (frob long-float))
+
+(defun of-type (type)
+ "Returns a function of one argument, which returns true when its argument is
+of TYPE."
+ (lambda (thing) (typep thing type)))
+
+(define-compiler-macro of-type (&whole form type &environment env)
+ ;; This can yeild a big benefit, but no point inlining the function
+ ;; all over the place if TYPE is not constant.
+ (if (constantp type env)
+ (with-gensyms (thing)
+ `(lambda (,thing)
+ (typep ,thing ,type)))
+ form))
+
+(declaim (inline type=))
+(defun type= (type1 type2)
+ "Returns a primary value of T is TYPE1 and TYPE2 are the same type,
+and a secondary value that is true is the type equality could be reliably
+determined: primary value of NIL and secondary value of T indicates that the
+types are not equivalent."
+ (multiple-value-bind (sub ok) (subtypep type1 type2)
+ (cond ((and ok sub)
+ (subtypep type2 type1))
+ (ok
+ (values nil ok))
+ (t
+ (multiple-value-bind (sub ok) (subtypep type2 type1)
+ (declare (ignore sub))
+ (values nil ok))))))
+
+(define-modify-macro coercef (type-spec) coerce
+ "Modify-macro for COERCE.")
--- /dev/null
+;;;; This file is part of the Anaphora package Common Lisp,
+;;;; and has been placed in Public Domain by the author,
+;;;; Nikodemus Siivola <nikodemus@random-state.net>
--- /dev/null
+;;;; Anaphora: The Anaphoric Macro Package from Hell
+;;;;
+;;;; This been placed in Public Domain by the author,
+;;;; Nikodemus Siivola <nikodemus@random-state.net>
+
+(defsystem :anaphora
+ :version "0.9.3"
+ :components
+ ((:file "packages")
+ (:file "early" :depends-on ("packages"))
+ (:file "symbolic" :depends-on ("early"))
+ (:file "anaphora" :depends-on ("symbolic"))))
+
+(defsystem :anaphora-test
+ :depends-on (:anaphora :rt)
+ :components ((:file "tests")))
+
+(defmethod perform ((o test-op) (c (eql (find-system :anaphora))))
+ (operate 'load-op :anaphora-test)
+ (operate 'test-op :anaphora-test :force t))
+
+(defmethod perform ((o test-op) (c (eql (find-system :anaphora-test))))
+ (or (funcall (intern "DO-TESTS" :rt))
+ (error "test-op failed")))
--- /dev/null
+;;;; Anaphora: The Anaphoric Macro Package from Hell
+;;;;
+;;;; This been placed in Public Domain by the author,
+;;;; Nikodemus Siivola <nikodemus@random-state.net>
+
+(in-package :anaphora)
+
+(defmacro anaphoric (op test &body body)
+ ;; Note: multiple values discarded. Handling them would be nice, but also
+ ;; requires consing up a values-list, which seems a bit harsh for something
+ ;; that is supposed to be "simple syntactic sugar".
+ `(let ((it ,test))
+ (,op it ,@body)))
+
+;;; This was the original implementation of SYMBOLIC -- and still good
+;;; for getting the basic idea. Brian Masterbrooks solution to
+;;; infinite recusion during macroexpansion, that nested forms of this
+;;; are subject to, is in symbolic.lisp.
+;;;
+;;; (defmacro symbolic (op test &body body &environment env)
+;;; `(symbol-macrolet ((it ,test))
+;;; (,op it ,@body)))
+
+(defmacro aand (first &rest rest)
+ "Like AND, except binds the first argument to IT (via LET) for the
+scope of the rest of the arguments."
+ `(anaphoric and ,first ,@rest))
+
+(defmacro sor (first &rest rest)
+ "Like OR, except binds the first argument to IT (via SYMBOL-MACROLET) for
+the scope of the rest of the arguments. IT can be set with SETF."
+ `(symbolic or ,first ,@rest))
+
+(defmacro aif (test then &optional else)
+ "Like IF, except binds the result of the test to IT (via LET) for
+the scope of the then and else expressions."
+ `(anaphoric if ,test ,then ,else))
+
+(defmacro sif (test then &optional else &environment env)
+ "Like IF, except binds the test form to IT (via SYMBOL-MACROLET) for
+the scope of the then and else expressions. IT can be set with SETF"
+ `(symbolic if ,test ,then ,else))
+
+(defmacro asif (test then &optional else)
+ "Like IF, except binds the result of the test to IT (via LET) for
+the the scope of the then-expression, and the test form to IT (via
+SYMBOL-MACROLET) for the scope of the else-expression. Within scope of
+the else-expression IT can be set with SETF."
+ `(let ((it ,test))
+ (if it
+ ,then
+ (symbolic ignore-first ,test ,else))))
+
+(defmacro aprog1 (first &body rest)
+ "Binds IT to the first form so that it can be used in the rest of the
+forms. The whole thing returns IT."
+ `(anaphoric prog1 ,first ,@rest))
+
+(defmacro awhen (test &body body)
+ "Like WHEN, except binds the result of the test to IT (via LET) for the scope
+of the body."
+ `(anaphoric when ,test ,@body))
+
+(defmacro swhen (test &body body)
+ "Like WHEN, except binds the test form to IT (via SYMBOL-MACROLET) for the
+scope of the body. IT can be set with SETF."
+ `(symbolic when ,test ,@body))
+
+(defmacro sunless (test &body body)
+ "Like UNLESS, except binds the test form to IT (via SYMBOL-MACROLET) for the
+scope of the body. IT can be set with SETF."
+ `(symbolic unless ,test ,@body))
+
+(defmacro acase (keyform &body cases)
+ "Like CASE, except binds the result of the keyform to IT (via LET) for the
+scope of the cases."
+ `(anaphoric case ,keyform ,@cases))
+
+(defmacro scase (keyform &body cases)
+ "Like CASE, except binds the keyform to IT (via SYMBOL-MACROLET) for the
+scope of the body. IT can be set with SETF."
+ `(symbolic case ,keyform ,@cases))
+
+(defmacro aecase (keyform &body cases)
+ "Like ECASE, except binds the result of the keyform to IT (via LET) for the
+scope of the cases."
+ `(anaphoric ecase ,keyform ,@cases))
+
+(defmacro secase (keyform &body cases)
+ "Like ECASE, except binds the keyform to IT (via SYMBOL-MACROLET) for the
+scope of the cases. IT can be set with SETF."
+ `(symbolic ecase ,keyform ,@cases))
+
+(defmacro accase (keyform &body cases)
+ "Like CCASE, except binds the result of the keyform to IT (via LET) for the
+scope of the cases. Unlike CCASE, the keyform/place doesn't receive new values
+possibly stored with STORE-VALUE restart; the new value is received by IT."
+ `(anaphoric ccase ,keyform ,@cases))
+
+(defmacro sccase (keyform &body cases)
+ "Like CCASE, except binds the keyform to IT (via SYMBOL-MACROLET) for the
+scope of the cases. IT can be set with SETF."
+ `(symbolic ccase ,keyform ,@cases))
+
+(defmacro atypecase (keyform &body cases)
+ "Like TYPECASE, except binds the result of the keyform to IT (via LET) for
+the scope of the cases."
+ `(anaphoric typecase ,keyform ,@cases))
+
+(defmacro stypecase (keyform &body cases)
+ "Like TYPECASE, except binds the keyform to IT (via SYMBOL-MACROLET) for the
+scope of the cases. IT can be set with SETF."
+ `(symbolic typecase ,keyform ,@cases))
+
+(defmacro aetypecase (keyform &body cases)
+ "Like ETYPECASE, except binds the result of the keyform to IT (via LET) for
+the scope of the cases."
+ `(anaphoric etypecase ,keyform ,@cases))
+
+(defmacro setypecase (keyform &body cases)
+ "Like ETYPECASE, except binds the keyform to IT (via SYMBOL-MACROLET) for
+the scope of the cases. IT can be set with SETF."
+ `(symbolic etypecase ,keyform ,@cases))
+
+(defmacro actypecase (keyform &body cases)
+ "Like CTYPECASE, except binds the result of the keyform to IT (via LET) for
+the scope of the cases. Unlike CTYPECASE, new values possible stored by the
+STORE-VALUE restart are not received by the keyform/place, but by IT."
+ `(anaphoric ctypecase ,keyform ,@cases))
+
+(defmacro sctypecase (keyform &body cases)
+ "Like CTYPECASE, except binds the keyform to IT (via SYMBOL-MACROLET) for
+the scope of the cases. IT can be set with SETF."
+ `(symbolic ctypecase ,keyform ,@cases))
+
+(defmacro acond (&body clauses)
+ "Like COND, except result of each test-form is bound to IT (via LET) for the
+scope of the corresponding clause."
+ (labels ((rec (clauses)
+ (if clauses
+ (destructuring-bind ((test &body body) . rest) clauses
+ (if body
+ `(anaphoric if ,test (progn ,@body) ,(rec rest))
+ `(anaphoric if ,test it ,(rec rest))))
+ nil)))
+ (rec clauses)))
+
+(defmacro scond (&body clauses)
+ "Like COND, except each test-form is bound to IT (via SYMBOL-MACROLET) for the
+scope of the corresponsing clause. IT can be seet with SETF."
+ (labels ((rec (clauses)
+ (if clauses
+ (destructuring-bind ((test &body body) . rest) clauses
+ (if body
+ `(symbolic if ,test (progn ,@body) ,(rec rest))
+ `(symbolic if ,test it ,(rec rest))))
+ nil)))
+ (rec clauses)))
--- /dev/null
+;;;; Anaphora: The Anaphoric Macro Package from Hell
+;;;;
+;;;; This been placed in Public Domain by the author,
+;;;; Nikodemus Siivola <nikodemus@random-state.net>
+
+(in-package :anaphora)
+
+(defmacro with-unique-names ((&rest bindings) &body body)
+ `(let ,(mapcar #'(lambda (binding)
+ (destructuring-bind (var prefix)
+ (if (consp binding) binding (list binding binding))
+ `(,var (gensym ,(string prefix)))))
+ bindings)
+ ,@body))
+
+(defmacro ignore-first (first expr)
+ (declare (ignore first))
+ expr)
--- /dev/null
+;;;; Anaphora: The Anaphoric Macro Package from Hell
+;;;;
+;;;; This been placed in Public Domain by the author,
+;;;; Nikodemus Siivola <nikodemus@random-state.net>
+
+(defpackage :anaphora
+ (:use :cl)
+ (:export
+ #:it
+ #:aif
+ #:aand
+ #:sor
+ #:awhen
+ #:aprog1
+ #:acase
+ #:aecase
+ #:accase
+ #:atypecase
+ #:aetypecase
+ #:actypecase
+ #:acond
+ #:sif
+ #:asif
+ #:swhen
+ #:sunless
+ #:scase
+ #:secase
+ #:sccase
+ #:stypecase
+ #:setypecase
+ #:sctypecase
+ #:scond)
+ (:documentation
+ "ANAPHORA provides a full complement of anaphoric macros. Subsets of the
+functionality provided by this package are exported from ANAPHORA-BASIC and
+ANAPHORA-SYMBOL."))
+
+(defpackage :anaphora-basic
+ (:use :cl :anaphora)
+ (:export
+ #:it
+ #:aif
+ #:aand
+ #:awhen
+ #:aprog1
+ #:acase
+ #:aecase
+ #:accase
+ #:atypecase
+ #:aetypecase
+ #:actypecase
+ #:acond)
+ (:documentation
+ "ANAPHORA-BASIC provides all normal anaphoric constructs, which bind
+primary values to IT."))
+
+(defpackage :anaphora-symbol
+ (:use :cl :anaphora)
+ (:export
+ #:it
+ #:sor
+ #:sif
+ #:asif
+ #:swhen
+ #:sunless
+ #:scase
+ #:secase
+ #:sccase
+ #:stypecase
+ #:setypecase
+ #:sctypecase
+ #:scond)
+ (:documentation
+ "ANAPHORA-SYMBOL provides ``symbolic anaphoric macros'', which bind forms
+to IT via SYMBOL-MACROLET.
+
+Examples:
+
+ (sor (gethash key table) (setf it default))
+
+ (asif (gethash key table)
+ (foo it) ; IT is a value bound by LET here
+ (setf it default)) ; IT is the GETHASH form bound by SYMBOL-MACROLET here
+"))
--- /dev/null
+;;;; Copyright (c) 2003 Brian Mastenbrook
+
+;;;; Permission is hereby granted, free of charge, to any person obtaining
+;;;; a copy of this software and associated documentation files (the
+;;;; "Software"), to deal in the Software without restriction, including
+;;;; without limitation the rights to use, copy, modify, merge, publish,
+;;;; distribute, sublicense, and/or sell copies of the Software, and to
+;;;; permit persons to whom the Software is furnished to do so, subject to
+;;;; the following conditions:
+
+;;;; The above copyright notice and this permission notice shall be
+;;;; included in all copies or substantial portions of the Software.
+
+;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+;;;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+;;;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+;;;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+;;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+
+(in-package :anaphora)
+
+(defmacro internal-symbol-macrolet (&rest whatever)
+ `(symbol-macrolet ,@whatever))
+
+(define-setf-expander internal-symbol-macrolet (binding-forms place &environment env)
+ (multiple-value-bind (dummies vals newval setter getter)
+ (get-setf-expansion place env)
+ (declare (ignore newval setter))
+ (let ((store (gensym)))
+ (values dummies
+ (substitute `(symbol-macrolet ,binding-forms it) 'it vals)
+ `(,store)
+ `(symbol-macrolet ,binding-forms
+ (setf ,getter ,store) ,store)
+ `(symbol-macrolet ,binding-forms ,getter)))))
+
+(with-unique-names (s-indicator current-s-indicator)
+ (defmacro symbolic (operation test &rest other-args)
+ (with-unique-names (this-s)
+ (let ((current-s (get s-indicator current-s-indicator)))
+ (setf (get s-indicator current-s-indicator) this-s)
+ `(symbol-macrolet
+ ((,this-s (internal-symbol-macrolet ((it ,current-s)) ,test))
+ (it ,this-s))
+ (,operation it ,@other-args))))))
--- /dev/null
+;;;; Anaphora: The Anaphoric Macro Package from Hell
+;;;;
+;;;; This been placed in Public Domain by the author,
+;;;; Nikodemus Siivola <nikodemus@random-state.net>
+
+(defpackage :anaphora-test
+ (:use :cl :anaphora :rt))
+
+(in-package :anaphora-test)
+
+(deftest aand.1
+ (aand (+ 1 1)
+ (+ 1 it))
+ 3)
+
+(deftest aand.2
+ (aand 1 t (values it 2))
+ 1 2)
+
+(deftest aand.3
+ (let ((x 1))
+ (aand (incf x) t t (values t it)))
+ t 2)
+
+(deftest aand.4
+ (aand 1 (values t it))
+ t 1)
+
+#+(or)
+;;; bug or a feature? forms like this expand to
+;;;
+;;; (let ((it (values ...))) (and it ...))
+;;;
+(deftest aand.5
+ (aand (values nil t) it)
+ nil t)
+
+(deftest sor.1
+ (let ((x (list nil)))
+ (sor (car x)
+ (setf it t))
+ x)
+ (t))
+
+(deftest aif.1
+ (aif (+ 1 1)
+ (+ 1 it)
+ :never)
+ 3)
+
+(deftest aif.2
+ (let ((x 0))
+ (aif (incf x)
+ it
+ :never))
+ 1)
+
+(deftest aif.3
+ (let ((x 0))
+ (aif (eval `(and ,(incf x) nil))
+ :never
+ (list it x)))
+ (nil 1))
+
+(deftest sif.1
+ (let ((x (list nil)))
+ (sif (car x)
+ (setf it :oops)
+ (setf it :yes!))
+ (car x))
+ :yes!)
+
+(deftest sif.2
+ (let ((x (list t)))
+ (sif (car x)
+ (setf it :yes!)
+ (setf it :oops))
+ (car x))
+ :yes!)
+
+(deftest sif.3
+ (sif (list 1 2 3)
+ (sif (car it)
+ (setf it 'a)
+ :foo))
+ a)
+
+(deftest sif.4
+ (progn
+ (defclass sif.4 ()
+ ((a :initform (list :sif))))
+ (with-slots (a)
+ (make-instance 'sif.4)
+ (sif a
+ (sif (car it)
+ it))))
+ :sif)
+
+(deftest asif.1
+ (let ((x (list 0)))
+ (asif (incf (car x))
+ it
+ (list :oops it)))
+ 1)
+
+(deftest asif.2
+ (let ((x (list nil)))
+ (asif (car x)
+ (setf x :oops)
+ (setf it :yes!))
+ x)
+ (:yes!))
+
+(deftest awhen.1
+ (let ((x 0))
+ (awhen (incf x)
+ (+ 1 it)))
+ 2)
+
+(deftest awhen.2
+ (let ((x 0))
+ (or (awhen (not (incf x))
+ t)
+ x))
+ 1)
+
+(deftest swhen.1
+ (let ((x 0))
+ (swhen x
+ (setf it :ok))
+ x)
+ :ok)
+
+(deftest swhen.2
+ (let ((x nil))
+ (swhen x
+ (setf it :oops))
+ x)
+ nil)
+
+(deftest sunless.1
+ (let ((x nil))
+ (sunless x
+ (setf it :ok))
+ x)
+ :ok)
+
+(deftest sunless.2
+ (let ((x t))
+ (sunless x
+ (setf it :oops))
+ x)
+ t)
+
+(deftest acase.1
+ (let ((x 0))
+ (acase (incf x)
+ (0 :no)
+ (1 (list :yes it))
+ (2 :nono)))
+ (:yes 1))
+
+(deftest scase.1
+ (let ((x (list 3)))
+ (scase (car x)
+ (0 (setf it :no))
+ (3 (setf it :yes!))
+ (t (setf it :nono)))
+ x)
+ (:yes!))
+
+(deftest aecase.1
+ (let ((x (list :x)))
+ (aecase (car x)
+ (:y :no)
+ (:x (list it :yes))))
+ (:x :yes))
+
+(deftest aecase.2
+ (nth-value 0 (ignore-errors
+ (let ((x (list :x)))
+ (secase (car x)
+ (:y :no)))
+ :oops))
+ nil)
+
+(deftest secase.1
+ (let ((x (list :x)))
+ (secase (car x)
+ (:y (setf it :no))
+ (:x (setf it :yes)))
+ x)
+ (:yes))
+
+(deftest secase.2
+ (nth-value 0 (ignore-errors
+ (let ((x (list :x)))
+ (secase (car x)
+ (:y (setf it :no)))
+ :oops)))
+ nil)
+
+(deftest accase.1
+ (let ((x (list :x)))
+ (accase (car x)
+ (:y :no)
+ (:x (list it :yes))))
+ (:x :yes))
+
+(deftest accase.2
+ (let ((x (list :x)))
+ (handler-bind ((type-error (lambda (e) (store-value :z e))))
+ (accase (car x)
+ (:y (setf x :no))
+ (:z (setf x :yes))))
+ x)
+ :yes)
+
+(deftest accase.3
+ (let ((x (list :x)))
+ (accase (car x)
+ (:x (setf it :foo)))
+ x)
+ (:x))
+
+(deftest sccase.1
+ (let ((x (list :x)))
+ (sccase (car x)
+ (:y (setf it :no))
+ (:x (setf it :yes)))
+ x)
+ (:yes))
+
+(deftest sccase.2
+ (let ((x (list :x)))
+ (handler-bind ((type-error (lambda (e) (store-value :z e))))
+ (sccase (car x)
+ (:y (setf it :no))
+ (:z (setf it :yes))))
+ x)
+ (:yes))
+
+(deftest atypecase.1
+ (atypecase 1.0
+ (integer (+ 2 it))
+ (float (1- it)))
+ 0.0)
+
+(deftest atypecase.2
+ (atypecase "Foo"
+ (fixnum :no)
+ (hash-table :nono))
+ nil)
+
+(deftest stypecase.1
+ (let ((x (list 'foo)))
+ (stypecase (car x)
+ (vector (setf it :no))
+ (symbol (setf it :yes)))
+ x)
+ (:yes))
+
+(deftest stypecase.2
+ (let ((x (list :bar)))
+ (stypecase (car x)
+ (fixnum (setf it :no)))
+ x)
+ (:bar))
+
+(deftest aetypecase.1
+ (aetypecase 1.0
+ (fixnum (* 2 it))
+ (float (+ 2.0 it))
+ (symbol :oops))
+ 3.0)
+
+(deftest aetypecase.2
+ (nth-value 0 (ignore-errors
+ (aetypecase 1.0
+ (symbol :oops))))
+ nil)
+
+(deftest setypecase.1
+ (let ((x (list "Foo")))
+ (setypecase (car x)
+ (symbol (setf it :no))
+ (string (setf it "OK"))
+ (integer (setf it :noon)))
+ x)
+ ("OK"))
+
+(deftest setypecase.2
+ (nth-value 0 (ignore-errors
+ (setypecase 'foo
+ (string :nono))))
+ nil)
+
+(deftest actypecase.1
+ (actypecase :foo
+ (string (list :string it))
+ (keyword (list :keyword it))
+ (symbol (list :symbol it)))
+ (:keyword :foo))
+
+(deftest actypecase.2
+ (handler-bind ((type-error (lambda (e) (store-value "OK" e))))
+ (actypecase 0
+ (string it)))
+ "OK")
+
+(deftest sctypecase.1
+ (let ((x (list 0)))
+ (sctypecase (car x)
+ (symbol (setf it 'symbol))
+ (bit (setf it 'bit)))
+ x)
+ (bit))
+
+(deftest sctypecase.2
+ (handler-bind ((type-error (lambda (e) (store-value "OK" e))))
+ (let ((x (list 0)))
+ (sctypecase (car x)
+ (string (setf it :ok)))
+ x))
+ (:ok))
+
+(deftest acond.1
+ (acond (:foo))
+ :foo)
+
+(deftest acond.2
+ (acond ((null 1) (list :no it))
+ ((+ 1 2) (list :yes it))
+ (t :nono))
+ (:yes 3))
+
+(deftest acond.3
+ (acond ((= 1 2) :no)
+ (nil :nono)
+ (t :yes))
+ :yes)
+
+;; Test COND with multiple forms in the implicit progn.
+(deftest acond.4
+ (let ((foo))
+ (acond ((+ 2 2) (setf foo 38) (incf foo it) foo)
+ (t nil)))
+ 42)
+
+(deftest scond.1
+ (let ((x (list nil))
+ (y (list t)))
+ (scond ((car x) (setf it :nono))
+ ((car y) (setf it :yes)))
+ (values x y))
+ (nil)
+ (:yes))
+
+(deftest scond.2
+ (scond ((= 1 2) :no!))
+ nil)
+
+(deftest scond.3
+ (scond ((symbol-value '*default-pathname-defaults*)
+ (let ((tmp it))
+ (unwind-protect
+ (progn
+ (setf it (truename "/tmp/"))
+ (namestring *default-pathname-defaults*))
+ (setf it tmp)))))
+ "/tmp/")
+
+(deftest aprog.1
+ (aprog1 :yes
+ (unless (eql it :yes) (error "Broken."))
+ :no)
+ :yes)
--- /dev/null
+language: lisp
+
+env:
+ matrix:
+ - LISP=allegro
+ - LISP=ccl
+ - LISP=ccl32
+ - LISP=sbcl
+ - LISP=sbcl32
+ - LISP=abcl
+ - LISP=cmucl
+ - LISP=ecl
+
+matrix:
+ allow_failures:
+ - env: LISP=abcl
+ - env: LISP=cmucl
+ - env: LISP=ecl
+
+notifications:
+ email:
+ on_success: change
+ on_failure: always
+ irc:
+ channels:
+ - "chat.freenode.net#iolib"
+ on_success: change
+ on_failure: always
+ use_notice: true
+ skip_join: true
+
+install:
+ - curl -L https://github.com/sionescu/cl-travis/raw/master/install.sh | sh
+ - cl -e "(cl:in-package :cl-user)
+ (dolist (p '(:fiveam))
+ (ql:quickload p :verbose t))"
+
+script:
+ - cl -e "(cl:in-package :cl-user)
+ (prin1 (lisp-implementation-type)) (terpri) (prin1 (lisp-implementation-version)) (terpri)
+ (ql:quickload :bordeaux-threads/test :verbose t)
+ (uiop:quit (if (some (lambda (x) (typep x '5am::test-failure))
+ (5am:run :bordeaux-threads))
+ 1 0))"
--- /dev/null
+-*- outline -*-
+
+Based on original Bordeaux-MP spec by Dan Barlow <dan@telent.net>
+
+Contributors:
+
+* Attila Lendvai <attila.lendvai@gmail.com>
+ - better handling of unsupported Lisps
+* Vladimir Sekissov <svg@surnet.ru>
+ - fixes for CMUCL implementation
+* Pierre Thierry <nowhere.man@levallois.eu.org>
+ - added license information
+* Stelian Ionescu <sionescu@cddr.org>
+ - finished conversion from generic functions
+ - enabled running thread-safe code in unthreaded lisps
+* Douglas Crosher <dtc@scieneer.com>
+ - added Scieneer Common Lisp support
--- /dev/null
+Permission is hereby granted, free of charge, to any person
+obtaining a copy of this software and associated documentation
+files (the "Software"), to deal in the Software without
+restriction, including without limitation the rights to use,
+copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the
+Software is furnished to do so, subject to the following
+conditions:
+
+The above copyright notice and this permission notice shall be
+included in all copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
+OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
+OTHER DEALINGS IN THE SOFTWARE.
--- /dev/null
+You can find API documentation on the project's wiki:
+ http://trac.common-lisp.net/bordeaux-threads/wiki/ApiDocumentation
--- /dev/null
+;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
+
+#|
+Copyright 2006,2007 Greg Pfeil
+
+Distributed under the MIT license (see LICENSE file)
+|#
+
+#.(unless (or #+asdf3.1 (version<= "3.1" (asdf-version)))
+ (error "You need ASDF >= 3.1 to load this system correctly."))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ #+(or armedbear
+ (and allegro multiprocessing)
+ (and clisp mt)
+ (and openmcl openmcl-native-threads)
+ (and cmu mp)
+ corman
+ (and ecl threads)
+ mkcl
+ lispworks
+ (and digitool ccl-5.1)
+ (and sbcl sb-thread)
+ scl)
+ (pushnew :thread-support *features*))
+
+(defsystem :bordeaux-threads
+ :author "Greg Pfeil <greg@technomadic.org>"
+ :licence "MIT"
+ :description "Bordeaux Threads makes writing portable multi-threaded apps simple."
+ :version (:read-file-form "version.sexp")
+ :depends-on (:alexandria
+ #+(and allegro (version>= 9)) (:require "smputil")
+ #+(and allegro (not (version>= 9))) (:require "process")
+ #+corman (:require "threads"))
+ :components ((:module "src"
+ :serial t
+ :components
+ ((:file "pkgdcl")
+ (:file "bordeaux-threads")
+ (:file #+(and thread-support armedbear) "impl-abcl"
+ #+(and thread-support allegro) "impl-allegro"
+ #+(and thread-support clisp) "impl-clisp"
+ #+(and thread-support openmcl) "impl-clozure"
+ #+(and thread-support cmu) "impl-cmucl"
+ #+(and thread-support corman) "impl-corman"
+ #+(and thread-support ecl) "impl-ecl"
+ #+(and thread-support mkcl) "impl-mkcl"
+ #+(and thread-support lispworks) "impl-lispworks"
+ #+(and thread-support digitool) "impl-mcl"
+ #+(and thread-support sbcl) "impl-sbcl"
+ #+(and thread-support scl) "impl-scl"
+ #-thread-support "impl-null")
+ #+(and thread-support lispworks (not (or lispworks6 lispworks7)))
+ (:file "impl-lispworks-condition-variables")
+ #+(and thread-support digitool)
+ (:file "condition-variables")
+ (:file "default-implementations")))))
+
+(defsystem :bordeaux-threads/test
+ :author "Greg Pfeil <greg@technomadic.org>"
+ :description "Bordeaux Threads test suite."
+ :licence "MIT"
+ :version (:read-file-form "version.sexp")
+ :depends-on (:bordeaux-threads :fiveam)
+ :components ((:module "test"
+ :components ((:file "bordeaux-threads-test")))))
+
+(defmethod perform ((o test-op) (c (eql (find-system :bordeaux-threads))))
+ (load-system :bordeaux-threads/test :force '(:bordeaux-threads/test))
+ (symbol-call :5am :run! :bordeaux-threads))
--- /dev/null
+;;;; -*- indent-tabs-mode: nil -*-
+
+#|
+Copyright 2006, 2007 Greg Pfeil
+
+Distributed under the MIT license (see LICENSE file)
+|#
+
+(in-package #:bordeaux-threads)
+
+(defvar *supports-threads-p* nil
+ "This should be set to T if the running instance has thread support.")
+
+(defun mark-supported ()
+ (setf *supports-threads-p* t)
+ (pushnew :bordeaux-threads *features*))
+
+(define-condition bordeaux-mp-condition (error)
+ ((message :initarg :message :reader message))
+ (:report (lambda (condition stream)
+ (format stream (message condition)))))
+
+(defgeneric make-threading-support-error ()
+ (:documentation "Creates a BORDEAUX-THREADS condition which specifies
+ whether there is no BORDEAUX-THREADS support for the implementation, no
+ threads enabled for the system, or no support for a particular
+ function.")
+ (:method ()
+ (make-condition
+ 'bordeaux-mp-condition
+ :message (if *supports-threads-p*
+ "There is no support for this method on this implementation."
+ "There is no thread support in this instance."))))
+
+#-sbcl
+(define-condition timeout (serious-condition)
+ ((length :initform nil
+ :initarg :length
+ :reader timeout-length))
+ (:report (lambda (c s)
+ (if (timeout-length c)
+ (format s "A timeout set to ~A seconds occurred."
+ (timeout-length c))
+ (format s "A timeout occurred.")))))
+
+
+;;; Thread Creation
+
+;;; See default-implementations.lisp for MAKE-THREAD.
+
+;; Forms are evaluated in the new thread or in the calling thread?
+(defvar *default-special-bindings* nil
+ "This variable holds an alist associating special variable symbols
+ to forms to evaluate. Special variables named in this list will
+ be locally bound in the new thread before it begins executing user code.
+
+ This variable may be rebound around calls to MAKE-THREAD to
+ add/alter default bindings. The effect of mutating this list is
+ undefined, but earlier forms take precedence over later forms for
+ the same symbol, so defaults may be overridden by consing to the
+ head of the list.")
+
+(defmacro defbindings (name docstring &body initforms)
+ (check-type docstring string)
+ `(defparameter ,name
+ (list
+ ,@(loop for (special form) in initforms
+ collect `(cons ',special ',form)))
+ ,docstring))
+
+;; Forms are evaluated in the new thread or in the calling thread?
+(defbindings *standard-io-bindings*
+ "Standard bindings of printer/reader control variables as per CL:WITH-STANDARD-IO-SYNTAX."
+ (*package* (find-package :common-lisp-user))
+ (*print-array* t)
+ (*print-base* 10)
+ (*print-case* :upcase)
+ (*print-circle* nil)
+ (*print-escape* t)
+ (*print-gensym* t)
+ (*print-length* nil)
+ (*print-level* nil)
+ (*print-lines* nil)
+ (*print-miser-width* nil)
+ (*print-pprint-dispatch* (copy-pprint-dispatch nil))
+ (*print-pretty* nil)
+ (*print-radix* nil)
+ (*print-readably* t)
+ (*print-right-margin* nil)
+ (*read-base* 10)
+ (*read-default-float-format* 'single-float)
+ (*read-eval* t)
+ (*read-suppress* nil)
+ (*readtable* (copy-readtable nil)))
+
+(defun binding-default-specials (function special-bindings)
+ "Return a closure that binds the symbols in SPECIAL-BINDINGS and calls
+FUNCTION."
+ (let ((specials (remove-duplicates special-bindings :from-end t :key #'car)))
+ (lambda ()
+ (progv (mapcar #'car specials)
+ (loop for (nil . form) in specials collect (eval form))
+ (funcall function)))))
+
+;;; FIXME: This test won't work if CURRENT-THREAD
+;;; conses a new object each time
+(defun signal-error-if-current-thread (thread)
+ (when (eq thread (current-thread))
+ (error 'bordeaux-mp-condition
+ :message "Cannot destroy the current thread")))
+
+(defparameter *no-condition-wait-timeout-message*
+ "CONDITION-WAIT with :TIMEOUT is not available for this Lisp implementation.")
+
+(defun signal-error-if-condition-wait-timeout (timeout)
+ (when timeout
+ (error 'bordeaux-mp-condition
+ :message *no-condition-wait-timeout-message*)))
+
+(defmacro define-condition-wait-compiler-macro ()
+ `(define-compiler-macro condition-wait
+ (&whole whole condition-variable lock &key timeout)
+ (declare (ignore condition-variable lock))
+ (when timeout
+ (simple-style-warning *no-condition-wait-timeout-message*))
+ whole))
--- /dev/null
+;;;; -*- indent-tabs-mode: nil -*-
+
+#|
+Copyright 2006, 2007 Greg Pfeil
+
+Distributed under the MIT license (see LICENSE file)
+|#
+
+(in-package #:bordeaux-threads)
+
+;;; This file provides a portable implementation of condition
+;;; variables (given a working WITH-LOCK-HELD and THREAD-YIELD), and
+;;; should be used if there is no condition variable implementation in
+;;; the host Lisp.
+
+(defstruct condition-var
+ name
+ lock
+ active)
+
+(defun condition-wait (condition-variable lock &key timeout)
+ (signal-error-if-condition-wait-timeout timeout)
+ (check-type condition-variable condition-var)
+ (setf (condition-var-active condition-variable) nil)
+ (release-lock lock)
+ (do ()
+ ((when (condition-var-active condition-variable)
+ (acquire-lock lock)
+ t))
+ (thread-yield))
+ t)
+
+(define-condition-wait-compiler-macro)
+
+(defun condition-notify (condition-variable)
+ (check-type condition-variable condition-var)
+ (with-lock-held ((condition-var-lock condition-variable))
+ (setf (condition-var-active condition-variable) t)))
--- /dev/null
+;;;; -*- indent-tabs-mode: nil -*-
+
+(in-package #:bordeaux-threads)
+
+;;; Helper macros
+
+(defmacro defdfun (name args doc &body body)
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (unless (fboundp ',name)
+ (defun ,name ,args ,@body))
+ (setf (documentation ',name 'function)
+ (or (documentation ',name 'function) ,doc))))
+
+(defmacro defdmacro (name args doc &body body)
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (unless (fboundp ',name)
+ (defmacro ,name ,args ,@body))
+ (setf (documentation ',name 'function)
+ (or (documentation ',name 'function) ,doc))))
+
+;;; Thread Creation
+
+(defdfun start-multiprocessing ()
+ "If the host implementation uses user-level threads, start the
+scheduler and multiprocessing, otherwise do nothing.
+It is safe to call repeatedly."
+ nil)
+
+(defdfun make-thread (function &key name
+ (initial-bindings *default-special-bindings*))
+ "Creates and returns a thread named NAME, which will call the
+ function FUNCTION with no arguments: when FUNCTION returns, the
+ thread terminates. NAME defaults to \"Anonymous thread\" if unsupplied.
+
+ On systems that do not support multi-threading, MAKE-THREAD will
+ signal an error.
+
+ The interaction between threads and dynamic variables is in some
+ cases complex, and depends on whether the variable has only a global
+ binding (as established by e.g. DEFVAR/DEFPARAMETER/top-level SETQ)
+ or has been bound locally (e.g. with LET or LET*) in the calling
+ thread.
+
+ - Global bindings are shared between threads: the initial value of a
+ global variable in the new thread will be the same as in the
+ parent, and an assignment to such a variable in any thread will be
+ visible to all threads in which the global binding is visible.
+
+ - Local bindings, such as the ones introduced by INITIAL-BINDINGS,
+ are local to the thread they are introduced in, except that
+
+ - Local bindings in the the caller of MAKE-THREAD may or may not be
+ shared with the new thread that it creates: this is
+ implementation-defined. Portable code should not depend on
+ particular behaviour in this case, nor should it assign to such
+ variables without first rebinding them in the new thread."
+ (%make-thread (binding-default-specials function initial-bindings)
+ (or name "Anonymous thread")))
+
+(defdfun %make-thread (function name)
+ "The actual implementation-dependent function that creates threads."
+ (declare (ignore function name))
+ (error (make-threading-support-error)))
+
+(defdfun current-thread ()
+ "Returns the thread object for the calling
+ thread. This is the same kind of object as would be returned by
+ MAKE-THREAD."
+ nil)
+
+(defdfun threadp (object)
+ "Returns true if object is a thread, otherwise NIL."
+ (declare (ignore object))
+ nil)
+
+(defdfun thread-name (thread)
+ "Returns the name of the thread, as supplied to MAKE-THREAD."
+ (declare (ignore thread))
+ "Main thread")
+
+;;; Resource contention: locks and recursive locks
+
+(defdfun make-lock (&optional name)
+ "Creates a lock (a mutex) whose name is NAME. If the system does not
+ support multiple threads this will still return some object, but it
+ may not be used for very much."
+ ;; In CLIM-SYS this is a freshly consed list (NIL). I don't know if
+ ;; there's some good reason it should be said structure or that it
+ ;; be freshly consed - EQ comparison of locks?
+ (declare (ignore name))
+ (list nil))
+
+(defdfun acquire-lock (lock &optional wait-p)
+ "Acquire the lock LOCK for the calling thread.
+ WAIT-P governs what happens if the lock is not available: if WAIT-P
+ is true, the calling thread will wait until the lock is available
+ and then acquire it; if WAIT-P is NIL, ACQUIRE-LOCK will return
+ immediately. ACQUIRE-LOCK returns true if the lock was acquired and
+ NIL otherwise.
+
+ This specification does not define what happens if a thread
+ attempts to acquire a lock that it already holds. For applications
+ that require locks to be safe when acquired recursively, see instead
+ MAKE-RECURSIVE-LOCK and friends."
+ (declare (ignore lock wait-p))
+ t)
+
+(defdfun release-lock (lock)
+ "Release LOCK. It is an error to call this unless
+ the lock has previously been acquired (and not released) by the same
+ thread. If other threads are waiting for the lock, the
+ ACQUIRE-LOCK call in one of them will now be able to continue.
+
+ This function has no interesting return value."
+ (declare (ignore lock))
+ (values))
+
+(defdmacro with-lock-held ((place) &body body)
+ "Evaluates BODY with the lock named by PLACE, the value of which
+ is a lock created by MAKE-LOCK. Before the forms in BODY are
+ evaluated, the lock is acquired as if by using ACQUIRE-LOCK. After the
+ forms in BODY have been evaluated, or if a non-local control transfer
+ is caused (e.g. by THROW or SIGNAL), the lock is released as if by
+ RELEASE-LOCK.
+
+ Note that if the debugger is entered, it is unspecified whether the
+ lock is released at debugger entry or at debugger exit when execution
+ is restarted."
+ `(when (acquire-lock ,place t)
+ (unwind-protect
+ (locally ,@body)
+ (release-lock ,place))))
+
+(defdfun make-recursive-lock (&optional name)
+ "Create and return a recursive lock whose name is NAME. A recursive
+ lock differs from an ordinary lock in that a thread that already
+ holds the recursive lock can acquire it again without blocking. The
+ thread must then release the lock twice before it becomes available
+ for another thread."
+ (declare (ignore name))
+ (list nil))
+
+(defdfun acquire-recursive-lock (lock)
+ "As for ACQUIRE-LOCK, but for recursive locks."
+ (declare (ignore lock))
+ t)
+
+(defdfun release-recursive-lock (lock)
+ "Release the recursive LOCK. The lock will only
+ become free after as many Release operations as there have been
+ Acquire operations. See RELEASE-LOCK for other information."
+ (declare (ignore lock))
+ (values))
+
+(defdmacro with-recursive-lock-held ((place &key timeout) &body body)
+ "Evaluates BODY with the recursive lock named by PLACE, which is a
+reference to a recursive lock created by MAKE-RECURSIVE-LOCK. See
+WITH-LOCK-HELD etc etc"
+ (declare (ignore timeout))
+ `(when (acquire-recursive-lock ,place)
+ (unwind-protect
+ (locally ,@body)
+ (release-recursive-lock ,place))))
+
+;;; Resource contention: condition variables
+
+;;; A condition variable provides a mechanism for threads to put
+;;; themselves to sleep while waiting for the state of something to
+;;; change, then to be subsequently woken by another thread which has
+;;; changed the state.
+;;;
+;;; A condition variable must be used in conjunction with a lock to
+;;; protect access to the state of the object of interest. The
+;;; procedure is as follows:
+;;;
+;;; Suppose two threads A and B, and some kind of notional event
+;;; channel C. A is consuming events in C, and B is producing them.
+;;; CV is a condition-variable
+;;;
+;;; 1) A acquires the lock that safeguards access to C
+;;; 2) A threads and removes all events that are available in C
+;;; 3) When C is empty, A calls CONDITION-WAIT, which atomically
+;;; releases the lock and puts A to sleep on CV
+;;; 4) Wait to be notified; CONDITION-WAIT will acquire the lock again
+;;; before returning
+;;; 5) Loop back to step 2, for as long as threading should continue
+;;;
+;;; When B generates an event E, it
+;;; 1) acquires the lock guarding C
+;;; 2) adds E to the channel
+;;; 3) calls CONDITION-NOTIFY on CV to wake any sleeping thread
+;;; 4) releases the lock
+;;;
+;;; To avoid the "lost wakeup" problem, the implementation must
+;;; guarantee that CONDITION-WAIT in thread A atomically releases the
+;;; lock and sleeps. If this is not guaranteed there is the
+;;; possibility that thread B can add an event and call
+;;; CONDITION-NOTIFY between the lock release and the sleep - in this
+;;; case the notify call would not see A, which would be left sleeping
+;;; despite there being an event available.
+
+(defdfun thread-yield ()
+ "Allows other threads to run. It may be necessary or desirable to
+ call this periodically in some implementations; others may schedule
+ threads automatically. On systems that do not support
+ multi-threading, this does nothing."
+ (values))
+
+(defdfun make-condition-variable (&key name)
+ "Returns a new condition-variable object for use
+ with CONDITION-WAIT and CONDITION-NOTIFY."
+ (declare (ignore name))
+ nil)
+
+(defdfun condition-wait (condition-variable lock &key timeout)
+ "Atomically release LOCK and enqueue the calling
+ thread waiting for CONDITION-VARIABLE. The thread will resume when
+ another thread has notified it using CONDITION-NOTIFY; it may also
+ resume if interrupted by some external event or in other
+ implementation-dependent circumstances: the caller must always test
+ on waking that there is threading to be done, instead of assuming
+ that it can go ahead.
+
+ It is an error to call function this unless from the thread that
+ holds LOCK.
+
+ If TIMEOUT is nil or not provided, the system always reacquires LOCK
+ before returning to the caller. In this case T is returned.
+
+ If TIMEOUT is non-nil, the call will return after at most TIMEOUT
+ seconds (approximately), whether or not a notification has occurred.
+ Either NIL or T will be returned. A return of NIL indicates that the
+ lock is no longer held and that the timeout has expired. A return of
+ T indicates that the lock is held, in which case the timeout may or
+ may not have expired.
+
+ **NOTE**: The behavior of CONDITION-WAIT with TIMEOUT diverges from
+ the POSIX function pthread_cond_timedwait. The former may return
+ without the lock being held while the latter always returns with the
+ lock held.
+
+ In an implementation that does not support multiple threads, this
+ function signals an error."
+ (declare (ignore condition-variable lock timeout))
+ (error (make-threading-support-error)))
+
+(defdfun condition-notify (condition-variable)
+ "Notify at least one of the threads waiting for
+ CONDITION-VARIABLE. It is implementation-dependent whether one or
+ more than one (and possibly all) threads are woken, but if the
+ implementation is capable of waking only a single thread (not all
+ are) this is probably preferable for efficiency reasons. The order
+ of wakeup is unspecified and does not necessarily relate to the
+ order that the threads went to sleep in.
+
+ CONDITION-NOTIFY has no useful return value. In an implementation
+ that does not support multiple threads, it has no effect."
+ (declare (ignore condition-variable))
+ (values))
+
+;;; Timeouts
+
+(defdmacro with-timeout ((timeout) &body body)
+ "Execute `BODY' and signal a condition of type TIMEOUT if the execution of
+BODY does not complete within `TIMEOUT' seconds. On implementations which do not
+support WITH-TIMEOUT natively and don't support threads either it has no effect."
+ (declare (ignorable timeout))
+ #+thread-support
+ (let ((ok-tag (gensym "OK"))
+ (timeout-tag (gensym "TIMEOUT"))
+ (caller (gensym "CALLER"))
+ (sleeper (gensym "SLEEPER")))
+ (once-only (timeout)
+ `(let (,sleeper)
+ (multiple-value-prog1
+ (catch ',ok-tag
+ (catch ',timeout-tag
+ (let ((,caller (current-thread)))
+ (setf ,sleeper
+ (make-thread #'(lambda ()
+ (sleep ,timeout)
+ (interrupt-thread ,caller
+ #'(lambda ()
+ (ignore-errors
+ (throw ',timeout-tag nil)))))
+ :name (format nil "WITH-TIMEOUT thread serving: ~S."
+ (thread-name ,caller))))
+ (throw ',ok-tag (progn ,@body))))
+ (error 'timeout :length ,timeout))
+ (when (thread-alive-p ,sleeper)
+ (destroy-thread ,sleeper))))))
+ #-thread-support
+ `(progn
+ ,@body))
+
+;;; Introspection/debugging
+
+;;; The following functions may be provided for debugging purposes,
+;;; but are not advised to be called from normal user code.
+
+(defdfun all-threads ()
+ "Returns a sequence of all of the threads. This may not
+ be freshly-allocated, so the caller should not modify it."
+ (error (make-threading-support-error)))
+
+(defdfun interrupt-thread (thread function)
+ "Interrupt THREAD and cause it to evaluate FUNCTION
+ before continuing with the interrupted path of execution. This may
+ not be a good idea if THREAD is holding locks or doing anything
+ important. On systems that do not support multiple threads, this
+ function signals an error."
+ (declare (ignore thread function))
+ (error (make-threading-support-error)))
+
+(defdfun destroy-thread (thread)
+ "Terminates the thread THREAD, which is an object
+ as returned by MAKE-THREAD. This should be used with caution: it is
+ implementation-defined whether the thread runs cleanup forms or
+ releases its locks first.
+
+ Destroying the calling thread is an error."
+ (declare (ignore thread))
+ (error (make-threading-support-error)))
+
+(defdfun thread-alive-p (thread)
+ "Returns true if THREAD is alive, that is, if
+ DESTROY-THREAD has not been called on it."
+ (declare (ignore thread))
+ (error (make-threading-support-error)))
+
+(defdfun join-thread (thread)
+ "Wait until THREAD terminates. If THREAD
+ has already terminated, return immediately."
+ (declare (ignore thread))
+ (error (make-threading-support-error)))
--- /dev/null
+;;;; -*- indent-tabs-mode: nil -*-
+
+#|
+Copyright 2006, 2007 Greg Pfeil
+
+Reimplemented with java.util.concurrent.locks.ReentrantLock by Mark Evenson 2011.
+
+Distributed under the MIT license (see LICENSE file)
+|#
+
+(in-package #:bordeaux-threads)
+
+;;; the implementation of the Armed Bear thread interface can be found in
+;;; src/org/armedbear/lisp/LispThread.java
+
+(deftype thread ()
+ 'threads:thread)
+
+;;; Thread Creation
+
+(defun %make-thread (function name)
+ (threads:make-thread function :name name))
+
+(defun current-thread ()
+ (threads:current-thread))
+
+(defun thread-name (thread)
+ (threads:thread-name thread))
+
+(defun threadp (object)
+ (typep object 'thread))
+
+;;; Resource contention: locks and recursive locks
+
+(defstruct mutex name lock)
+(defstruct (mutex-recursive (:include mutex)))
+
+;; Making methods constants in this manner avoids the runtime expense of
+;; introspection involved in JCALL with string arguments.
+(defconstant +lock+
+ (jmethod "java.util.concurrent.locks.ReentrantLock" "lock"))
+(defconstant +try-lock+
+ (jmethod "java.util.concurrent.locks.ReentrantLock" "tryLock"))
+(defconstant +is-held-by-current-thread+
+ (jmethod "java.util.concurrent.locks.ReentrantLock" "isHeldByCurrentThread"))
+(defconstant +unlock+
+ (jmethod "java.util.concurrent.locks.ReentrantLock" "unlock"))
+(defconstant +get-hold-count+
+ (jmethod "java.util.concurrent.locks.ReentrantLock" "getHoldCount"))
+
+(defun make-lock (&optional name)
+ (make-mutex
+ :name (or name "Anonymous lock")
+ :lock (jnew "java.util.concurrent.locks.ReentrantLock")))
+
+(defun acquire-lock (lock &optional (wait-p t))
+ (check-type lock mutex)
+ (when (jcall +is-held-by-current-thread+ (mutex-lock lock))
+ (error "Non-recursive lock being reacquired by owner."))
+ (cond
+ (wait-p
+ (jcall +lock+ (mutex-lock lock))
+ t)
+ (t (jcall +try-lock+ (mutex-lock lock)))))
+
+(defun release-lock (lock)
+ (check-type lock mutex)
+ (unless (jcall +is-held-by-current-thread+ (mutex-lock lock))
+ (error "Attempt to release lock not held by calling thread."))
+ (jcall +unlock+ (mutex-lock lock))
+ (values))
+
+(defun make-recursive-lock (&optional name)
+ (make-mutex-recursive
+ :name (or name "Anonymous lock")
+ :lock (jnew "java.util.concurrent.locks.ReentrantLock")))
+
+(defun acquire-recursive-lock (lock &optional (wait-p t))
+ (check-type lock mutex-recursive)
+ (cond
+ (wait-p
+ (jcall +lock+ (mutex-recursive-lock lock))
+ t)
+ (t (jcall +try-lock+ (mutex-recursive-lock lock)))))
+
+(defun release-recursive-lock (lock)
+ (check-type lock mutex-recursive)
+ (unless (jcall +is-held-by-current-thread+ (mutex-lock lock))
+ (error "Attempt to release lock not held by calling thread."))
+ (jcall +unlock+ (mutex-lock lock))
+ (values))
+
+;;; Resource contention: condition variables
+
+(defun thread-yield ()
+ (java:jstatic "yield" "java.lang.Thread"))
+
+(defstruct condition-variable
+ (name "Anonymous condition variable"))
+
+(defun condition-wait (condition lock &key timeout)
+ (threads:synchronized-on condition
+ (release-lock lock)
+ (if timeout
+ ;; Since giving a zero time value to threads:object-wait means
+ ;; an indefinite wait, use some arbitrary small number.
+ (threads:object-wait condition
+ (if (zerop timeout)
+ least-positive-single-float
+ timeout))
+ (threads:object-wait condition)))
+ (acquire-lock lock)
+ t)
+
+(defun condition-notify (condition)
+ (threads:synchronized-on condition
+ (threads:object-notify condition)))
+
+;;; Introspection/debugging
+
+(defun all-threads ()
+ (let ((threads ()))
+ (threads:mapcar-threads (lambda (thread)
+ (push thread threads)))
+ (reverse threads)))
+
+(defun interrupt-thread (thread function &rest args)
+ (apply #'threads:interrupt-thread thread function args))
+
+(defun destroy-thread (thread)
+ (signal-error-if-current-thread thread)
+ (threads:destroy-thread thread))
+
+(defun thread-alive-p (thread)
+ (threads:thread-alive-p thread))
+
+(defun join-thread (thread)
+ (threads:thread-join thread))
+
+(mark-supported)
--- /dev/null
+;;;; -*- indent-tabs-mode: nil -*-
+
+#|
+Copyright 2006, 2007 Greg Pfeil
+
+Distributed under the MIT license (see LICENSE file)
+|#
+
+(in-package #:bordeaux-threads)
+
+;;; documentation on the Allegro Multiprocessing interface can be found at
+;;; http://www.franz.com/support/documentation/8.1/doc/multiprocessing.htm
+
+;;; Resource contention: locks and recursive locks
+
+(defun make-lock (&optional name)
+ (mp:make-process-lock :name (or name "Anonymous lock")))
+
+(defun make-recursive-lock (&optional name)
+ (mp:make-process-lock :name (or name "Anonymous recursive lock")))
+
+(defun acquire-lock (lock &optional (wait-p t))
+ (mp:process-lock lock mp:*current-process* "Lock" (if wait-p nil 0)))
+
+(defun release-lock (lock)
+ (mp:process-unlock lock))
+
+(defmacro with-lock-held ((place) &body body)
+ `(mp:with-process-lock (,place :norecursive t)
+ ,@body))
+
+(defmacro with-recursive-lock-held ((place &key timeout) &body body)
+ `(mp:with-process-lock (,place :timeout ,timeout)
+ ,@body))
+
+;;; Resource contention: condition variables
+
+(defun make-condition-variable (&key name)
+ (declare (ignorable name))
+ #-(version>= 9)
+ (mp:make-gate nil)
+ #+(version>= 9)
+ (mp:make-condition-variable :name name))
+
+(defun condition-wait (condition-variable lock &key timeout)
+ #-(version>= 9)
+ (progn
+ (release-lock lock)
+ (if timeout
+ (mp:process-wait-with-timeout "wait for message" timeout
+ #'mp:gate-open-p condition-variable)
+ (mp:process-wait "wait for message" #'mp:gate-open-p condition-variable))
+ (acquire-lock lock)
+ (mp:close-gate condition-variable))
+ #+(version>= 9)
+ (mp:condition-variable-wait condition-variable lock :timeout timeout)
+ t)
+
+(defun condition-notify (condition-variable)
+ #-(version>= 9)
+ (mp:open-gate condition-variable)
+ #+(version>= 9)
+ (mp:condition-variable-signal condition-variable))
+
+(defun thread-yield ()
+ (mp:process-allow-schedule))
+
+(deftype thread ()
+ 'mp:process)
+
+;;; Thread Creation
+
+(defun start-multiprocessing ()
+ (mp:start-scheduler))
+
+(defun %make-thread (function name)
+ #+smp
+ (mp:process-run-function name function)
+ #-smp
+ (mp:process-run-function
+ name
+ (lambda ()
+ (let ((return-values
+ (multiple-value-list (funcall function))))
+ (setf (getf (mp:process-property-list mp:*current-process*)
+ 'return-values)
+ return-values)
+ (values-list return-values)))))
+
+(defun current-thread ()
+ mp:*current-process*)
+
+(defun threadp (object)
+ (typep object 'mp:process))
+
+(defun thread-name (thread)
+ (mp:process-name thread))
+
+;;; Timeouts
+
+(defmacro with-timeout ((timeout) &body body)
+ (once-only (timeout)
+ `(mp:with-timeout (,timeout (error 'timeout :length ,timeout))
+ ,@body)))
+
+;;; Introspection/debugging
+
+(defun all-threads ()
+ mp:*all-processes*)
+
+(defun interrupt-thread (thread function &rest args)
+ (apply #'mp:process-interrupt thread function args))
+
+(defun destroy-thread (thread)
+ (signal-error-if-current-thread thread)
+ (mp:process-kill thread))
+
+(defun thread-alive-p (thread)
+ (mp:process-alive-p thread))
+
+(defun join-thread (thread)
+ #+smp
+ (values-list (mp:process-join thread))
+ #-smp
+ (progn
+ (mp:process-wait (format nil "Waiting for thread ~A to complete" thread)
+ (complement #'mp:process-alive-p)
+ thread)
+ (let ((return-values
+ (getf (mp:process-property-list thread) 'return-values)))
+ (values-list return-values))))
+
+(mark-supported)
--- /dev/null
+;;;; -*- indent-tabs-mode: nil -*-
+
+#|
+Copyright 2006, 2007 Greg Pfeil
+
+Distributed under the MIT license (see LICENSE file)
+|#
+
+(in-package #:bordeaux-threads)
+
+(deftype thread ()
+ 'mt:thread)
+
+;;; Thread Creation
+(defun %make-thread (function name)
+ (mt:make-thread function
+ :name name
+ :initial-bindings mt:*default-special-bindings*))
+
+(defun current-thread ()
+ (mt:current-thread))
+
+(defun threadp (object)
+ (mt:threadp object))
+
+(defun thread-name (thread)
+ (mt:thread-name thread))
+
+;;; Resource contention: locks and recursive locks
+
+(defun make-lock (&optional name)
+ (mt:make-mutex :name (or name "Anonymous lock")))
+
+(defun acquire-lock (lock &optional (wait-p t))
+ (mt:mutex-lock lock :timeout (if wait-p nil 0)))
+
+(defun release-lock (lock)
+ (mt:mutex-unlock lock))
+
+(defmacro with-lock-held ((place) &body body)
+ `(mt:with-mutex-lock (,place) ,@body))
+
+(defun make-recursive-lock (&optional name)
+ (mt:make-mutex :name (or name "Anonymous recursive lock")
+ :recursive-p t))
+
+(defmacro with-recursive-lock-held ((place) &body body)
+ `(mt:with-mutex-lock (,place) ,@body))
+
+;;; Resource contention: condition variables
+
+(defun make-condition-variable (&key name)
+ (mt:make-exemption :name (or name "Anonymous condition variable")))
+
+(defun condition-wait (condition-variable lock &key timeout)
+ (mt:exemption-wait condition-variable lock :timeout timeout)
+ t)
+
+(defun condition-notify (condition-variable)
+ (mt:exemption-signal condition-variable))
+
+(defun thread-yield ()
+ (mt:thread-yield))
+
+;;; Timeouts
+
+(defmacro with-timeout ((timeout) &body body)
+ (once-only (timeout)
+ `(mt:with-timeout (,timeout (error 'timeout :length ,timeout))
+ ,@body)))
+
+;;; Introspection/debugging
+
+;;; VTZ: mt:list-threads returns all threads that are not garbage collected.
+(defun all-threads ()
+ (delete-if-not #'mt:thread-active-p (mt:list-threads)))
+
+(defun interrupt-thread (thread function &rest args)
+ (mt:thread-interrupt thread :function function :arguments args))
+
+(defun destroy-thread (thread)
+ ;;; VTZ: actually we can kill ourselelf.
+ ;;; suicide is part of our contemporary life :)
+ (signal-error-if-current-thread thread)
+ (mt:thread-interrupt thread :function t))
+
+(defun thread-alive-p (thread)
+ (mt:thread-active-p thread))
+
+(defun join-thread (thread)
+ (mt:thread-join thread))
+
+(mark-supported)
--- /dev/null
+;;;; -*- indent-tabs-mode: nil -*-
+
+#|
+Copyright 2006, 2007 Greg Pfeil
+
+Distributed under the MIT license (see LICENSE file)
+|#
+
+(in-package #:bordeaux-threads)
+
+;;; documentation on the OpenMCL Threads interface can be found at
+;;; http://openmcl.clozure.com/Doc/Programming-with-Threads.html
+
+(deftype thread ()
+ 'ccl:process)
+
+;;; Thread Creation
+
+(defun %make-thread (function name)
+ (ccl:process-run-function name function))
+
+(defun current-thread ()
+ ccl:*current-process*)
+
+(defun threadp (object)
+ (typep object 'ccl:process))
+
+(defun thread-name (thread)
+ (ccl:process-name thread))
+
+;;; Resource contention: locks and recursive locks
+
+(defun make-lock (&optional name)
+ (ccl:make-lock (or name "Anonymous lock")))
+
+(defun acquire-lock (lock &optional (wait-p t))
+ (if wait-p
+ (ccl:grab-lock lock)
+ (ccl:try-lock lock)))
+
+(defun release-lock (lock)
+ (ccl:release-lock lock))
+
+(defmacro with-lock-held ((place) &body body)
+ `(ccl:with-lock-grabbed (,place)
+ ,@body))
+
+(defun make-recursive-lock (&optional name)
+ (ccl:make-lock (or name "Anonymous recursive lock")))
+
+(defun acquire-recursive-lock (lock)
+ (ccl:grab-lock lock))
+
+(defun release-recursive-lock (lock)
+ (ccl:release-lock lock))
+
+(defmacro with-recursive-lock-held ((place) &body body)
+ `(ccl:with-lock-grabbed (,place)
+ ,@body))
+
+;;; Resource contention: condition variables
+
+(defun make-condition-variable (&key name)
+ (declare (ignore name))
+ (ccl:make-semaphore))
+
+(defun condition-wait (condition-variable lock &key timeout)
+ (release-lock lock)
+ (unwind-protect
+ (if timeout
+ (ccl:timed-wait-on-semaphore condition-variable timeout)
+ (ccl:wait-on-semaphore condition-variable))
+ (acquire-lock lock t))
+ t)
+
+(defun condition-notify (condition-variable)
+ (ccl:signal-semaphore condition-variable))
+
+(defun thread-yield ()
+ (ccl:process-allow-schedule))
+
+;;; Introspection/debugging
+
+(defun all-threads ()
+ (ccl:all-processes))
+
+(defun interrupt-thread (thread function &rest args)
+ (declare (dynamic-extent args))
+ (apply #'ccl:process-interrupt thread function args))
+
+(defun destroy-thread (thread)
+ (signal-error-if-current-thread thread)
+ (ccl:process-kill thread))
+
+(defun thread-alive-p (thread)
+ (not (ccl:process-exhausted-p thread)))
+
+(defun join-thread (thread)
+ (ccl:join-process thread))
+
+(mark-supported)
--- /dev/null
+;;;; -*- indent-tabs-mode: nil -*-
+
+#|
+Copyright 2006, 2007 Greg Pfeil
+
+Distributed under the MIT license (see LICENSE file)
+|#
+
+(in-package #:bordeaux-threads)
+
+(deftype thread ()
+ 'mp::process)
+
+;;; Thread Creation
+
+(defun start-multiprocessing ()
+ (mp::startup-idle-and-top-level-loops))
+
+(defun %make-thread (function name)
+ #+#.(cl:if (cl:find-symbol (cl:string '#:process-join) :mp) '(and) '(or))
+ (mp:make-process function :name name)
+ #-#.(cl:if (cl:find-symbol (cl:string '#:process-join) :mp) '(and) '(or))
+ (mp:make-process (lambda ()
+ (let ((return-values
+ (multiple-value-list (funcall function))))
+ (setf (getf (mp:process-property-list mp:*current-process*)
+ 'return-values)
+ return-values)
+ (values-list return-values)))
+ :name name))
+
+(defun current-thread ()
+ mp:*current-process*)
+
+(defmethod threadp (object)
+ (mp:processp object))
+
+(defun thread-name (thread)
+ (mp:process-name thread))
+
+;;; Resource contention: locks and recursive locks
+
+(defun make-lock (&optional name)
+ (mp:make-lock (or name "Anonymous lock")
+ :kind :error-check))
+
+(defun acquire-lock (lock &optional (wait-p t))
+ (if wait-p
+ (mp::lock-wait lock "Lock wait")
+ (mp::lock-wait-with-timeout lock "Lock wait" 0)))
+
+(defun release-lock (lock)
+ (setf (mp::lock-process lock) nil))
+
+(defmacro with-lock-held ((place) &body body)
+ `(mp:with-lock-held (,place "Lock wait") ,@body))
+
+(defun make-recursive-lock (&optional name)
+ (mp:make-lock (or name "Anonymous recursive lock")
+ :kind :recursive))
+
+(defun acquire-recursive-lock (lock &optional (wait-p t))
+ (acquire-lock lock))
+
+(defun release-recursive-lock (lock)
+ (release-lock lock))
+
+(defmacro with-recursive-lock-held ((place &key timeout) &body body)
+ `(mp:with-lock-held (,place "Lock Wait" :timeout ,timeout) ,@body))
+
+;;; Note that the locks _are_ recursive, but not "balanced", and only
+;;; checked if they are being held by the same process by with-lock-held.
+;;; The default with-lock-held in bordeaux-mp.lisp sort of works, in that
+;;; it will wait for recursive locks by the same process as well.
+
+;;; Resource contention: condition variables
+
+;;; There's some stuff in x86-vm.lisp that might be worth investigating
+;;; whether to build on. There's also process-wait and friends.
+
+(defstruct condition-var
+ "CMUCL doesn't have conditions, so we need to create our own type."
+ name
+ lock
+ active)
+
+(defun make-condition-variable (&key name)
+ (make-condition-var :lock (make-lock)
+ :name (or name "Anonymous condition variable")))
+
+(defun condition-wait (condition-variable lock &key timeout)
+ (signal-error-if-condition-wait-timeout timeout)
+ (check-type condition-variable condition-var)
+ (with-lock-held ((condition-var-lock condition-variable))
+ (setf (condition-var-active condition-variable) nil))
+ (release-lock lock)
+ (mp:process-wait "Condition Wait"
+ #'(lambda () (condition-var-active condition-variable)))
+ (acquire-lock lock)
+ t)
+
+(define-condition-wait-compiler-macro)
+
+(defun condition-notify (condition-variable)
+ (check-type condition-variable condition-var)
+ (with-lock-held ((condition-var-lock condition-variable))
+ (setf (condition-var-active condition-variable) t))
+ (thread-yield))
+
+(defun thread-yield ()
+ (mp:process-yield))
+
+;;; Timeouts
+
+(defmacro with-timeout ((timeout) &body body)
+ (once-only (timeout)
+ `(mp:with-timeout (,timeout (error 'timeout :length ,timeout))
+ ,@body)))
+
+;;; Introspection/debugging
+
+(defun all-threads ()
+ (mp:all-processes))
+
+(defun interrupt-thread (thread function &rest args)
+ (flet ((apply-function ()
+ (if args
+ (lambda () (apply function args))
+ function)))
+ (declare (dynamic-extent #'apply-function))
+ (mp:process-interrupt thread (apply-function))))
+
+(defun destroy-thread (thread)
+ (signal-error-if-current-thread thread)
+ (mp:destroy-process thread))
+
+(defun thread-alive-p (thread)
+ (mp:process-active-p thread))
+
+(defun join-thread (thread)
+ #+#.(cl:if (cl:find-symbol (cl:string '#:process-join) :mp) '(and) '(or))
+ (mp:process-join thread)
+ #-#.(cl:if (cl:find-symbol (cl:string '#:process-join) :mp) '(and) '(or))
+ (progn
+ (mp:process-wait (format nil "Waiting for thread ~A to complete" thread)
+ (lambda () (not (mp:process-alive-p thread))))
+ (let ((return-values
+ (getf (mp:process-property-list thread) 'return-values)))
+ (values-list return-values))))
+
+(mark-supported)
--- /dev/null
+;;;; -*- indent-tabs-mode: nil -*-
+
+#|
+Copyright 2006, 2007 Greg Pfeil
+
+Distributed under the MIT license (see LICENSE file)
+|#
+
+(in-package #:bordeaux-threads)
+
+;;; Thread Creation
+
+(defun %make-thread (function name)
+ (declare (ignore name))
+ (threads:create-thread function))
+
+(defun current-thread ()
+ threads:*current-thread*)
+
+;;; Introspection/debugging
+
+(defun destroy-thread (thread)
+ (signal-error-if-current-thread thread)
+ (threads:terminate-thread thread))
+
+(mark-supported)
--- /dev/null
+;;;; -*- indent-tabs-mode: nil -*-
+
+#|
+Copyright 2006, 2007 Greg Pfeil
+
+Distributed under the MIT license (see LICENSE file)
+|#
+
+(in-package #:bordeaux-threads)
+
+;;; documentation on the ECL Multiprocessing interface can be found at
+;;; http://ecls.sourceforge.net/cgi-bin/view/Main/MultiProcessing
+
+(deftype thread ()
+ 'mp:process)
+
+;;; Thread Creation
+
+(defun %make-thread (function name)
+ (mp:process-run-function name function))
+
+(defun current-thread ()
+ mp::*current-process*)
+
+(defun threadp (object)
+ (typep object 'mp:process))
+
+(defun thread-name (thread)
+ (mp:process-name thread))
+
+;;; Resource contention: locks and recursive locks
+
+(defun make-lock (&optional name)
+ (mp:make-lock :name (or name "Anonymous lock")))
+
+(defun acquire-lock (lock &optional (wait-p t))
+ (mp:get-lock lock wait-p))
+
+(defun release-lock (lock)
+ (mp:giveup-lock lock))
+
+(defmacro with-lock-held ((place) &body body)
+ `(mp:with-lock (,place) ,@body))
+
+(defun make-recursive-lock (&optional name)
+ (mp:make-lock :name (or name "Anonymous recursive lock") :recursive t))
+
+(defun acquire-recursive-lock (lock &optional (wait-p t))
+ (mp:get-lock lock wait-p))
+
+(defun release-recursive-lock (lock)
+ (mp:giveup-lock lock))
+
+(defmacro with-recursive-lock-held ((place) &body body)
+ `(mp:with-lock (,place) ,@body))
+
+;;; Resource contention: condition variables
+
+(defun make-condition-variable (&key name)
+ (declare (ignore name))
+ (mp:make-condition-variable))
+
+(defun condition-wait (condition-variable lock &key timeout)
+ (if timeout
+ (mp:condition-variable-timedwait condition-variable lock timeout)
+ (mp:condition-variable-wait condition-variable lock))
+ t)
+
+(defun condition-notify (condition-variable)
+ (mp:condition-variable-signal condition-variable))
+
+(defun thread-yield ()
+ (mp:process-yield))
+
+;;; Introspection/debugging
+
+(defun all-threads ()
+ (mp:all-processes))
+
+(defun interrupt-thread (thread function &rest args)
+ (flet ((apply-function ()
+ (if args
+ (lambda () (apply function args))
+ function)))
+ (declare (dynamic-extent #'apply-function))
+ (mp:interrupt-process thread (apply-function))))
+
+(defun destroy-thread (thread)
+ (signal-error-if-current-thread thread)
+ (mp:process-kill thread))
+
+(defun thread-alive-p (thread)
+ (mp:process-active-p thread))
+
+(defun join-thread (thread)
+ (mp:process-join thread))
+
+(mark-supported)
--- /dev/null
+;;;; -*- indent-tabs-mode: nil -*-
+
+;; Lispworks condition support is simulated, albeit via a lightweight wrapper over
+;; its own polling-based wait primitive. Waiters register with the condition variable,
+;; and use MP:process-wait which queries for permission to proceed at its own (usspecified) interval.
+;; http://www.lispworks.com/documentation/lw51/LWRM/html/lwref-445.htm
+;; A wakeup callback (on notify) is provided to lighten this query to not have to do a hash lookup
+;; on every poll (or have to serialize on the condition variable) and a mechanism is put
+;; in place to unregister any waiter that exits wait for other reasons,
+;; and to resend any (single) notification that may have been consumed before this (corner
+;; case). Much of the complexity present is to support single notification (as recommended in
+;; the spec); but a distinct condition-notify-all is provided for reference.
+;; Single-notification follows a first-in first-out ordering
+;;
+;; Performance: With 1000 threads waiting on one condition-variable, the steady-state hit (at least
+;; as tested on a 3GHz Win32 box) is noise - hovering at 0% on Task manager.
+;; While not true zero like a true native solution, the use of the Lispworks native checks appear
+;; fast enough to be an equivalent substitute (thread count will cause issue before the
+;; waiting overhead becomes significant)
+(defstruct (condition-variable (:constructor make-lw-condition (name)))
+ name
+ (lock (mp:make-lock :name "For condition-variable") :type mp:lock :read-only t)
+ (wait-tlist (cons nil nil) :type cons :read-only t)
+ (wait-hash (make-hash-table :test 'eq) :type hash-table :read-only t)
+ ;; unconsumed-notifications is to track :remove-from-consideration
+ ;; for entries that may have exited prematurely - notification is sent through
+ ;; to someone else, and offender is removed from hash and list
+ (unconsumed-notifications (make-hash-table :test 'eq) :type hash-table :read-only t))
+
+(defun make-condition-variable (&key name)
+ (make-lw-condition name))
+
+(defmacro with-cv-access (condition-variable &body body)
+ (let ((cv-sym (gensym))
+ (slots '(lock wait-tlist wait-hash unconsumed-notifications)))
+ `(let ((,cv-sym ,condition-variable))
+ (with-slots ,slots
+ ,cv-sym
+ (macrolet ((locked (&body body) `(mp:with-lock (lock) ,@body)))
+ (labels ((,(gensym) () ,@slots))) ; Trigger expansion of the symbol-macrolets to ignore
+ ,@body)))))
+
+(defmacro defcvfun (function-name (condition-variable &rest args) &body body)
+ `(defun ,function-name (,condition-variable ,@args)
+ (with-cv-access ,condition-variable
+ ,@body)))
+#+lispworks (editor:setup-indent "defcvfun" 2 2 7) ; indent defcvfun
+
+; utility function thath assumes process is locked on condition-variable's lock.
+(defcvfun do-notify-single (condition-variable) ; assumes already locked
+ (let ((id (caar wait-tlist)))
+ (when id
+ (pop (car wait-tlist))
+ (unless (car wait-tlist) ; check for empty
+ (setf (cdr wait-tlist) nil))
+ (funcall (gethash id wait-hash)) ; call waiter-wakeup
+ (remhash id wait-hash) ; absence of entry = permission to proceed
+ (setf (gethash id unconsumed-notifications) t))))
+
+;; Added for completeness/to show how it's done in this paradigm; but
+;; The symbol for this call is not exposed in the api
+(defcvfun condition-notify-all (condition-variable)
+ (locked
+ (loop for waiter-wakeup being the hash-values in wait-hash do (funcall waiter-wakeup))
+ (clrhash wait-hash)
+ (clrhash unconsumed-notifications) ; don't care as everyone just got notified
+ (setf (car wait-tlist) nil)
+ (setf (cdr wait-tlist) nil)))
+
+;; Currently implemented so as to notify only one waiting thread
+(defcvfun condition-notify (condition-variable)
+ (locked (do-notify-single condition-variable)))
+
+(defun delete-from-tlist (tlist element)
+ (let ((deleter
+ (lambda ()
+ (setf (car tlist) (cdar tlist))
+ (unless (car tlist)
+ (setf (cdr tlist) nil)))))
+ (loop for cons in (car tlist) do
+ (if (eq element (car cons))
+ (progn
+ (funcall deleter)
+ (return nil))
+ (let ((cons cons))
+ (setq deleter
+ (lambda ()
+ (setf (cdr cons) (cddr cons))
+ (unless (cdr cons)
+ (setf (cdr tlist) cons)))))))))
+
+(defun add-to-tlist-tail (tlist element)
+ (let ((new-link (cons element nil)))
+ (cond
+ ((car tlist)
+ (setf (cddr tlist) new-link)
+ (setf (cdr tlist) new-link))
+ (t
+ (setf (car tlist) new-link)
+ (setf (cdr tlist) new-link)))))
+
+(defcvfun condition-wait (condition-variable lock- &key timeout)
+ (signal-error-if-condition-wait-timeout timeout)
+ (mp:process-unlock lock-)
+ (unwind-protect ; for the re-taking of the lock. Guarding all of the code
+ (let ((wakeup-allowed-to-proceed nil)
+ (wakeup-lock (mp:make-lock :name "wakeup lock for condition-wait")))
+ ;; wakeup-allowed-to-proceed is an optimisation to avoid having to serialize all waiters and
+ ;; search the hashtable. That it is locked is for safety/completeness, although
+ ;; as wakeup-allowed-to-proceed only transitions nil -> t, and that missing it once or twice is
+ ;; moot in this situation, it would be redundant even if ever a Lispworks implementation ever became
+ ;; non-atomic in its assigments
+ (let ((id (cons nil nil))
+ (clean-exit nil))
+ (locked
+ (add-to-tlist-tail wait-tlist id)
+ (setf (gethash id wait-hash) (lambda () (mp:with-lock (wakeup-lock) (setq wakeup-allowed-to-proceed t)))))
+ (unwind-protect
+ (progn
+ (mp:process-wait
+ "Waiting for notification"
+ (lambda ()
+ (when (mp:with-lock (wakeup-lock) wakeup-allowed-to-proceed)
+ (locked (not (gethash id wait-hash))))))
+ (locked (remhash id unconsumed-notifications))
+ (setq clean-exit t)) ; Notification was consumed
+ ;; Have to call remove-from-consideration just in case process was interrupted
+ ;; rather than having condition met
+ (unless clean-exit ; clean-exit is just an optimization
+ (locked
+ (when (gethash id wait-hash) ; not notified - must have been interrupted
+ ;; Have to unsubscribe
+ (remhash id wait-hash)
+ (delete-from-tlist wait-tlist id))
+ ;; note - it's possible to be removed from wait-hash/wait-tlist (in notify-single); but still have an unconsumed notification!
+ (when (gethash id unconsumed-notifications) ; Must have exited for reasons unrelated to notification
+ (remhash id unconsumed-notifications) ; Have to pass on the notification to an eligible waiter
+ (do-notify-single condition-variable)))))))
+ (mp:process-lock lock-))
+ t)
+
+(define-condition-wait-compiler-macro)
--- /dev/null
+;;;; -*- indent-tabs-mode: nil -*-
+
+#|
+Copyright 2006, 2007 Greg Pfeil
+
+Distributed under the MIT license (see LICENSE file)
+|#
+
+(in-package #:bordeaux-threads)
+
+;;; documentation on the LispWorks Multiprocessing interface can be found at
+;;; http://www.lispworks.com/documentation/lw445/LWUG/html/lwuser-156.htm
+
+(deftype thread ()
+ 'mp:process)
+
+;;; Thread Creation
+
+(defun start-multiprocessing ()
+ (mp:initialize-multiprocessing))
+
+(defun %make-thread (function name)
+ (mp:process-run-function
+ name nil
+ (lambda ()
+ (let ((return-values
+ (multiple-value-list (funcall function))))
+ (setf (mp:process-property 'return-values)
+ return-values)
+ (values-list return-values)))))
+
+(defun current-thread ()
+ #-#.(cl:if (cl:find-symbol (cl:string '#:get-current-process) :mp) '(and) '(or))
+ mp:*current-process*
+ ;; introduced in LispWorks 5.1
+ #+#.(cl:if (cl:find-symbol (cl:string '#:get-current-process) :mp) '(and) '(or))
+ (mp:get-current-process))
+
+(defun threadp (object)
+ (mp:process-p object))
+
+(defun thread-name (thread)
+ (mp:process-name thread))
+
+;;; Resource contention: locks and recursive locks
+
+(defun make-lock (&optional name)
+ (mp:make-lock :name (or name "Anonymous lock")
+ #-(or lispworks4 lispworks5) :recursivep
+ #-(or lispworks4 lispworks5) nil))
+
+(defun acquire-lock (lock &optional (wait-p t))
+ (mp:process-lock lock nil
+ (cond ((null wait-p) 0)
+ ((numberp wait-p) wait-p)
+ (t nil))))
+
+(defun release-lock (lock)
+ (mp:process-unlock lock))
+
+(defmacro with-lock-held ((place) &body body)
+ `(mp:with-lock (,place) ,@body))
+
+(defun make-recursive-lock (&optional name)
+ (mp:make-lock :name (or name "Anonymous recursive lock")
+ #-(or lispworks4 lispworks5) :recursivep
+ #-(or lispworks4 lispworks5) t))
+
+(defun acquire-recursive-lock (lock &optional (wait-p t))
+ (acquire-lock lock wait-p))
+
+(defun release-recursive-lock (lock)
+ (release-lock lock))
+
+(defmacro with-recursive-lock-held ((place) &body body)
+ `(mp:with-lock (,place) ,@body))
+
+;;; Resource contention: condition variables
+
+#+(or lispworks6 lispworks7)
+(defun make-condition-variable (&key name)
+ (mp:make-condition-variable :name (or name "Anonymous condition variable")))
+
+#+(or lispworks6 lispworks7)
+(defun condition-wait (condition-variable lock &key timeout)
+ (mp:condition-variable-wait condition-variable lock :timeout timeout)
+ t)
+
+#+(or lispworks6 lispworks7)
+(defun condition-notify (condition-variable)
+ (mp:condition-variable-signal condition-variable))
+
+(defun thread-yield ()
+ (mp:process-allow-scheduling))
+
+;;; Introspection/debugging
+
+(defun all-threads ()
+ (mp:list-all-processes))
+
+(defun interrupt-thread (thread function &rest args)
+ (apply #'mp:process-interrupt thread function args))
+
+(defun destroy-thread (thread)
+ (signal-error-if-current-thread thread)
+ (mp:process-kill thread))
+
+(defun thread-alive-p (thread)
+ (mp:process-alive-p thread))
+
+(declaim (inline %join-thread))
+(defun %join-thread (thread)
+ #-#.(cl:if (cl:find-symbol (cl:string '#:process-join) :mp) '(and) '(or))
+ (mp:process-wait (format nil "Waiting for thread ~A to complete" thread)
+ (complement #'mp:process-alive-p)
+ thread)
+ #+#.(cl:if (cl:find-symbol (cl:string '#:process-join) :mp) '(and) '(or))
+ (mp:process-join thread))
+
+(defun join-thread (thread)
+ (%join-thread thread)
+ (let ((return-values
+ (mp:process-property 'return-values thread)))
+ (values-list return-values)))
+
+(mark-supported)
--- /dev/null
+;;;; -*- indent-tabs-mode: nil -*-
+
+#|
+Copyright 2006, 2007 Greg Pfeil
+
+Distributed under the MIT license (see LICENSE file)
+|#
+
+(in-package #:bordeaux-threads)
+
+(deftype thread ()
+ 'ccl::process)
+
+;;; Thread Creation
+
+(defun %make-thread (function name)
+ (ccl:process-run-function name function))
+
+(defun current-thread ()
+ ccl:*current-process*)
+
+(defun threadp (object)
+ (ccl::processp object))
+
+(defun thread-name (thread)
+ (ccl:process-name thread))
+
+;;; Resource contention: locks and recursive locks
+
+(defun make-lock (&optional name)
+ (ccl:make-lock (or name "Anonymous lock")))
+
+(defun acquire-lock (lock &optional (wait-p t))
+ (if wait-p
+ (ccl:process-lock lock ccl:*current-process*)
+ ;; this is broken, but it's better than a no-op
+ (ccl:without-interrupts
+ (when (null (ccl::lock.value lock))
+ (ccl:process-lock lock ccl:*current-process*)))))
+
+(defun release-lock (lock)
+ (ccl:process-unlock lock))
+
+(defmacro with-lock-held ((place) &body body)
+ `(ccl:with-lock-grabbed (,place) ,@body))
+
+(defun thread-yield ()
+ (ccl:process-allow-schedule))
+
+;;; Introspection/debugging
+
+(defun all-threads ()
+ ccl:*all-processes*)
+
+(defun interrupt-thread (thread function &rest args)
+ (declare (dynamic-extent args))
+ (apply #'ccl:process-interrupt thread function args))
+
+(defun destroy-thread (thread)
+ (signal-error-if-current-thread thread)
+ (ccl:process-kill thread))
+
+(mark-supported)
--- /dev/null
+;;;; -*- indent-tabs-mode: nil -*-
+
+#|
+Copyright 2006, 2007 Greg Pfeil
+Copyright 2010 Jean-Claude Beaudoin.
+
+Distributed under the MIT license (see LICENSE file)
+|#
+
+(in-package #:bordeaux-threads)
+
+(deftype thread ()
+ 'mt:thread)
+
+;;; Thread Creation
+
+(defun %make-thread (function name)
+ (mt:thread-run-function name function))
+
+(defun current-thread ()
+ mt::*thread*)
+
+(defun threadp (object)
+ (typep object 'mt:thread))
+
+(defun thread-name (thread)
+ (mt:thread-name thread))
+
+;;; Resource contention: locks and recursive locks
+
+(defun make-lock (&optional name)
+ (mt:make-lock :name (or name "Anonymous lock")))
+
+(defun acquire-lock (lock &optional (wait-p t))
+ (mt:get-lock lock wait-p))
+
+(defun release-lock (lock)
+ (mt:giveup-lock lock))
+
+(defmacro with-lock-held ((place) &body body)
+ `(mt:with-lock (,place) ,@body))
+
+(defun make-recursive-lock (&optional name)
+ (mt:make-lock :name (or name "Anonymous recursive lock") :recursive t))
+
+(defun acquire-recursive-lock (lock &optional (wait-p t))
+ (mt:get-lock lock wait-p))
+
+(defun release-recursive-lock (lock)
+ (mt:giveup-lock lock))
+
+(defmacro with-recursive-lock-held ((place) &body body)
+ `(mt:with-lock (,place) ,@body))
+
+;;; Resource contention: condition variables
+
+(defun make-condition-variable (&key name)
+ (declare (ignore name))
+ (mt:make-condition-variable))
+
+(defun condition-wait (condition-variable lock &key timeout)
+ (signal-error-if-condition-wait-timeout timeout)
+ (mt:condition-wait condition-variable lock)
+ t)
+
+(define-condition-wait-compiler-macro)
+
+(defun condition-notify (condition-variable)
+ (mt:condition-signal condition-variable))
+
+(defun thread-yield ()
+ (mt:thread-yield))
+
+;;; Introspection/debugging
+
+(defun all-threads ()
+ (mt:all-threads))
+
+(defun interrupt-thread (thread function &rest args)
+ (flet ((apply-function ()
+ (if args
+ (lambda () (apply function args))
+ function)))
+ (declare (dynamic-extent #'apply-function))
+ (mt:interrupt-thread thread (apply-function))))
+
+(defun destroy-thread (thread)
+ (signal-error-if-current-thread thread)
+ (mt:thread-kill thread))
+
+(defun thread-alive-p (thread)
+ (mt:thread-active-p thread))
+
+(defun join-thread (thread)
+ (mt:thread-join thread))
+
+(mark-supported)
--- /dev/null
+;;;; -*- indent-tabs-mode: nil -*-
+
+(in-package #:bordeaux-threads)
--- /dev/null
+;;;; -*- indent-tabs-mode: nil -*-
+
+#|
+Copyright 2006, 2007 Greg Pfeil
+
+Distributed under the MIT license (see LICENSE file)
+|#
+
+(in-package #:bordeaux-threads)
+
+;;; documentation on the SBCL Threads interface can be found at
+;;; http://www.sbcl.org/manual/Threading.html
+
+(deftype thread ()
+ 'sb-thread:thread)
+
+;;; Thread Creation
+
+(defun %make-thread (function name)
+ (sb-thread:make-thread function :name name))
+
+(defun current-thread ()
+ sb-thread:*current-thread*)
+
+(defun threadp (object)
+ (typep object 'sb-thread:thread))
+
+(defun thread-name (thread)
+ (sb-thread:thread-name thread))
+
+;;; Resource contention: locks and recursive locks
+
+(defun make-lock (&optional name)
+ (sb-thread:make-mutex :name (or name "Anonymous lock")))
+
+(defun acquire-lock (lock &optional (wait-p t))
+ #+#.(cl:if (cl:find-symbol (cl:string '#:grab-mutex) :sb-thread) '(and) '(or))
+ (sb-thread:grab-mutex lock :waitp wait-p)
+ #-#.(cl:if (cl:find-symbol (cl:string '#:grab-mutex) :sb-thread) '(and) '(or))
+ (sb-thread:get-mutex lock nil wait-p))
+
+(defun release-lock (lock)
+ (sb-thread:release-mutex lock))
+
+(defmacro with-lock-held ((place) &body body)
+ `(sb-thread:with-mutex (,place) ,@body))
+
+(defun make-recursive-lock (&optional name)
+ (sb-thread:make-mutex :name (or name "Anonymous recursive lock")))
+
+;;; XXX acquire-recursive-lock and release-recursive-lock are actually
+;;; complicated because we can't use control stack tricks. We need to
+;;; actually count something to check that the acquire/releases are
+;;; balanced
+
+(defmacro with-recursive-lock-held ((place) &body body)
+ `(sb-thread:with-recursive-lock (,place)
+ ,@body))
+
+;;; Resource contention: condition variables
+
+(defun make-condition-variable (&key name)
+ (sb-thread:make-waitqueue :name (or name "Anonymous condition variable")))
+
+(defun condition-wait (condition-variable lock &key timeout)
+ (sb-thread:condition-wait condition-variable lock :timeout timeout))
+
+(defun condition-notify (condition-variable)
+ (sb-thread:condition-notify condition-variable))
+
+(defun thread-yield ()
+ (sb-thread:release-foreground))
+
+;;; Timeouts
+
+(deftype timeout ()
+ 'sb-ext:timeout)
+
+(defmacro with-timeout ((timeout) &body body)
+ `(sb-ext:with-timeout ,timeout
+ ,@body))
+
+;;; Introspection/debugging
+
+(defun all-threads ()
+ (sb-thread:list-all-threads))
+
+(defun interrupt-thread (thread function &rest args)
+ (flet ((apply-function ()
+ (if args
+ (lambda () (apply function args))
+ function)))
+ (declare (dynamic-extent #'apply-function))
+ (sb-thread:interrupt-thread thread (apply-function))))
+
+(defun destroy-thread (thread)
+ (signal-error-if-current-thread thread)
+ (sb-thread:terminate-thread thread))
+
+(defun thread-alive-p (thread)
+ (sb-thread:thread-alive-p thread))
+
+(defun join-thread (thread)
+ (sb-thread:join-thread thread))
+
+(mark-supported)
--- /dev/null
+;;;; -*- indent-tabs-mode: nil -*-
+
+#|
+Copyright 2008 Scieneer Pty Ltd
+
+Distributed under the MIT license (see LICENSE file)
+|#
+
+(in-package #:bordeaux-threads)
+
+(deftype thread ()
+ 'thread:thread)
+
+(defun %make-thread (function name)
+ (thread:thread-create function :name name))
+
+(defun current-thread ()
+ thread:*thread*)
+
+(defun threadp (object)
+ (typep object 'thread:thread))
+
+(defun thread-name (thread)
+ (thread:thread-name thread))
+
+;;; Resource contention: locks and recursive locks
+
+(defun make-lock (&optional name)
+ (thread:make-lock (or name "Anonymous lock")))
+
+(defun acquire-lock (lock &optional (wait-p t))
+ (thread::acquire-lock lock nil wait-p))
+
+(defun release-lock (lock)
+ (thread::release-lock lock))
+
+(defmacro with-lock-held ((place) &body body)
+ `(thread:with-lock-held (,place) ,@body))
+
+(defun make-recursive-lock (&optional name)
+ (thread:make-lock (or name "Anonymous recursive lock")
+ :type :recursive))
+
+;;; XXX acquire-recursive-lock and release-recursive-lock are actually
+;;; complicated because we can't use control stack tricks. We need to
+;;; actually count something to check that the acquire/releases are
+;;; balanced
+
+(defmacro with-recursive-lock-held ((place) &body body)
+ `(thread:with-lock-held (,place)
+ ,@body))
+
+;;; Resource contention: condition variables
+
+(defun make-condition-variable (&key name)
+ (thread:make-cond-var (or name "Anonymous condition variable")))
+
+(defun condition-wait (condition-variable lock &key timeout)
+ (if timeout
+ (thread:cond-var-timedwait condition-variable lock timeout)
+ (thread:cond-var-wait condition-variable lock))
+ t)
+
+(defun condition-notify (condition-variable)
+ (thread:cond-var-broadcast condition-variable))
+
+(defun thread-yield ()
+ (mp:process-yield))
+
+;;; Introspection/debugging
+
+(defun all-threads ()
+ (mp:all-processes))
+
+(defun interrupt-thread (thread function &rest args)
+ (flet ((apply-function ()
+ (if args
+ (lambda () (apply function args))
+ function)))
+ (declare (dynamic-extent #'apply-function))
+ (thread:thread-interrupt thread (apply-function))))
+
+(defun destroy-thread (thread)
+ (thread:destroy-thread thread))
+
+(defun thread-alive-p (thread)
+ (mp:process-alive-p thread))
+
+(defun join-thread (thread)
+ (mp:process-wait (format nil "Waiting for thread ~A to complete" thread)
+ (lambda () (not (mp:process-alive-p thread)))))
+
+(mark-supported)
--- /dev/null
+;;;; -*- indent-tabs-mode: nil -*-
+
+(cl:defpackage :bordeaux-threads
+ (:nicknames #:bt)
+ (:use #:cl #:alexandria)
+ #+abcl
+ (:import-from :java #:jnew #:jcall #:jmethod)
+ (:export #:thread #:make-thread #:current-thread #:threadp #:thread-name
+ #:start-multiprocessing
+ #:*default-special-bindings* #:*standard-io-bindings*
+ #:*supports-threads-p*
+
+ #:make-lock #:acquire-lock #:release-lock #:with-lock-held
+ #:make-recursive-lock #:acquire-recursive-lock
+ #:release-recursive-lock #:with-recursive-lock-held
+
+ #:make-condition-variable #:condition-wait #:condition-notify
+
+ #:with-timeout #:timeout
+
+ #:all-threads #:interrupt-thread #:destroy-thread #:thread-alive-p
+ #:join-thread #:thread-yield)
+ (:documentation "BORDEAUX-THREADS is a proposed standard for a minimal
+ MP/threading interface. It is similar to the CLIM-SYS threading and
+ lock support, but for the following broad differences:
+
+ 1) Some behaviours are defined in additional detail: attention has
+ been given to special variable interaction, whether and when
+ cleanup forms are run. Some behaviours are defined in less
+ detail: an implementation that does not support multiple
+ threads is not required to use a new list (nil) for a lock, for
+ example.
+
+ 2) Many functions which would be difficult, dangerous or inefficient
+ to provide on some implementations have been removed. Chiefly
+ these are functions such as thread-wait which expect for
+ efficiency that the thread scheduler is written in Lisp and
+ 'hookable', which can't sensibly be done if the scheduler is
+ external to the Lisp image, or the system has more than one CPU.
+
+ 3) Unbalanced ACQUIRE-LOCK and RELEASE-LOCK functions have been
+ added.
+
+ 4) Posix-style condition variables have been added, as it's not
+ otherwise possible to implement them correctly using the other
+ operations that are specified.
+
+ Threads may be implemented using whatever applicable techniques are
+ provided by the operating system: user-space scheduling,
+ kernel-based LWPs or anything else that does the job.
+
+ Some parts of this specification can also be implemented in a Lisp
+ that does not support multiple threads. Thread creation and some
+ thread inspection operations will not work, but the locking
+ functions are still present (though they may do nothing) so that
+ thread-safe code can be compiled on both multithread and
+ single-thread implementations without need of conditionals.
+
+ To avoid conflict with existing MP/threading interfaces in
+ implementations, these symbols live in the BORDEAUX-THREADS package.
+ Implementations and/or users may also make them visible or exported
+ in other more traditionally named packages."))
--- /dev/null
+#|
+Copyright 2006,2007 Greg Pfeil
+
+Distributed under the MIT license (see LICENSE file)
+|#
+
+(defpackage bordeaux-threads/test
+ (:use #:cl #:bordeaux-threads #:fiveam)
+ (:shadow #:with-timeout))
+
+(in-package #:bordeaux-threads/test)
+
+(def-suite :bordeaux-threads)
+(def-fixture using-lock ()
+ (let ((lock (make-lock)))
+ (&body)))
+(in-suite :bordeaux-threads)
+
+(test should-have-current-thread
+ (is (current-thread)))
+
+(test current-thread-identity
+ (let* ((box (list nil))
+ (thread (make-thread (lambda ()
+ (setf (car box) (current-thread))))))
+ (join-thread thread)
+ (is (eql (car box) thread))))
+
+(test join-thread-return-value
+ (is (eql 0 (join-thread (make-thread (lambda () 0))))))
+
+(test should-identify-threads-correctly
+ (is (threadp (current-thread)))
+ (is (threadp (make-thread (lambda () t) :name "foo")))
+ (is (not (threadp (make-lock)))))
+
+(test should-retrieve-thread-name
+ (is (equal "foo" (thread-name (make-thread (lambda () t) :name "foo")))))
+
+(test interrupt-thread
+ (let* ((box (list nil))
+ (thread (make-thread (lambda ()
+ (setf (car box)
+ (catch 'new-thread
+ (sleep 60)
+ 'not-interrupted))))))
+ (sleep 1)
+ (interrupt-thread thread (lambda ()
+ (throw 'new-thread 'interrupted)))
+ (join-thread thread)
+ (is (eql 'interrupted (car box)))))
+
+(test should-lock-without-contention
+ (with-fixture using-lock ()
+ (is (acquire-lock lock t))
+ (release-lock lock)
+ (is (acquire-lock lock nil))
+ (release-lock lock)))
+
+(defun set-equal (set-a set-b)
+ (and (null (set-difference set-a set-b))
+ (null (set-difference set-b set-a))))
+
+(test default-special-bindings
+ (locally (declare (special *a* *c*))
+ (let* ((the-as 50) (the-bs 150) (*b* 42)
+ some-a some-b some-other-a some-other-b
+ (*default-special-bindings*
+ `((*a* . (funcall ,(lambda () (incf the-as))))
+ (*b* . (funcall ,(lambda () (incf the-bs))))
+ ,@*default-special-bindings*))
+ (threads (list (make-thread
+ (lambda ()
+ (setf some-a *a* some-b *b*)))
+ (make-thread
+ (lambda ()
+ (setf some-other-a *a*
+ some-other-b *b*))))))
+ (declare (special *b*))
+ (thread-yield)
+ (is (not (boundp '*a*)))
+ (loop while (some #'thread-alive-p threads)
+ do (thread-yield))
+ (is (set-equal (list some-a some-other-a) '(51 52)))
+ (is (set-equal (list some-b some-other-b) '(151 152)))
+ (is (not (boundp '*a*))))))
+
+
+(defparameter *shared* 0)
+(defparameter *lock* (make-lock))
+
+(test should-have-thread-interaction
+ ;; this simple test generates N process. Each process grabs and
+ ;; releases the lock until SHARED has some value, it then
+ ;; increments SHARED. the outer code first sets shared 1 which
+ ;; gets the thing running and then waits for SHARED to reach some
+ ;; value. this should, i think, stress test locks.
+ (setf *shared* 0)
+ (flet ((worker (i)
+ (loop
+ do (with-lock-held (*lock*)
+ (when (= i *shared*)
+ (incf *shared*)
+ (return)))
+ (thread-yield)
+ (sleep 0.001))))
+ (let* ((procs (loop
+ for i from 1 upto 2
+ ;; create a new binding to protect against implementations that
+ ;; mutate instead of binding the loop variable
+ collect (let ((i i))
+ (make-thread (lambda ()
+ (funcall #'worker i))
+ :name (format nil "Proc #~D" i))))))
+ (with-lock-held (*lock*)
+ (incf *shared*))
+ (block test
+ (loop
+ until (with-lock-held (*lock*)
+ (= (1+ (length procs)) *shared*))
+ do (with-lock-held (*lock*)
+ (is (>= (1+ (length procs)) *shared*)))
+ (thread-yield)
+ (sleep 0.001))))))
+
+
+(defparameter *condition-variable* (make-condition-variable))
+
+(test condition-variable
+ (setf *shared* 0)
+ (flet ((worker (i)
+ (with-lock-held (*lock*)
+ (loop
+ until (= i *shared*)
+ do (condition-wait *condition-variable* *lock*))
+ (incf *shared*))
+ (condition-notify *condition-variable*)))
+ (let ((num-procs 100))
+ (dotimes (i num-procs)
+ ;; create a new binding to protect against implementations that
+ ;; mutate instead of binding the loop variable
+ (let ((i i))
+ (make-thread (lambda ()
+ (funcall #'worker i))
+ :name (format nil "Proc #~D" i))))
+ (with-lock-held (*lock*)
+ (loop
+ until (= num-procs *shared*)
+ do (condition-wait *condition-variable* *lock*)))
+ (is (equal num-procs *shared*)))))
+
+;; Generally safe sanity check for the locks and single-notify
+#+(and lispworks (not lispworks6))
+(test condition-variable-lw
+ (let ((condition-variable (make-condition-variable :name "Test"))
+ (test-lock (make-lock))
+ (completed nil))
+ (dotimes (id 6)
+ (let ((id id))
+ (make-thread (lambda ()
+ (with-lock-held (test-lock)
+ (condition-wait condition-variable test-lock)
+ (push id completed)
+ (condition-notify condition-variable))))))
+ (sleep 2)
+ (if completed
+ (print "Failed: Premature passage through condition-wait")
+ (print "Successfully waited on condition"))
+ (condition-notify condition-variable)
+ (sleep 2)
+ (if (and completed
+ (eql (length completed) 6)
+ (equal (sort completed #'<)
+ (loop for id from 0 to 5 collect id)))
+ (print "Success: All elements notified")
+ (print (format nil "Failed: Of 6 expected elements, only ~A proceeded" completed)))
+ (bt::with-cv-access condition-variable
+ (if (and
+ (not (or (car wait-tlist) (cdr wait-tlist)))
+ (zerop (hash-table-count wait-hash))
+ (zerop (hash-table-count unconsumed-notifications)))
+ (print "Success: condition variable restored to initial state")
+ (print "Error: condition variable retains residue from completed waiters")))
+ (setq completed nil)
+ (dotimes (id 6)
+ (let ((id id))
+ (make-thread (lambda ()
+ (with-lock-held (test-lock)
+ (condition-wait condition-variable test-lock)
+ (push id completed))))))
+ (sleep 2)
+ (condition-notify condition-variable)
+ (sleep 2)
+ (if (= (length completed) 1)
+ (print "Success: Notify-single only notified a single waiter to restart")
+ (format t "Failure: Notify-single restarted ~A items" (length completed)))
+ (condition-notify condition-variable)
+ (sleep 2)
+ (if (= (length completed) 2)
+ (print "Success: second Notify-single only notified a single waiter to restart")
+ (format t "Failure: Two Notify-singles restarted ~A items" (length completed)))
+ (loop for i from 0 to 5 do (condition-notify condition-variable))
+ (print "Note: In the case of any failures, assume there are outstanding waiting threads")
+ (values)))
+
+#+(or abcl allegro clisp clozure ecl lispworks6 sbcl scl)
+(test condition-wait-timeout
+ (let ((lock (make-lock))
+ (cvar (make-condition-variable))
+ (flag nil))
+ (make-thread (lambda () (sleep 0.4) (setf flag t)))
+ (with-lock-held (lock)
+ (condition-wait cvar lock :timeout 0.2)
+ (is (null flag))
+ (sleep 0.4)
+ (is (eq t flag)))))
--- /dev/null
+;; -*- lisp -*-
+"0.8.5"
--- /dev/null
+Version 0.7.4
+2016-07-10
+Merge pull request #13 from vibs29/master (Hans Hübner)
+Make copy-stream work for CMUCL Gray Streams (vibs29)
+
+Version 0.7.3
+2014-11-28
+remove version from cl-fad-test system (Hans Huebner)
+update support information (Hans Huebner)
+
+Version 0.7.2
+2013-07-03
+Fix documentation glitch (inconsistent download link) (Luís Oliveira)
+
+Version 0.7.1
+2013-02-18
+Fix for LispWorks (R. Wilker)
+Add :description to .asd file
+
+Version 0.7.0
+2013-01-23
+Tests, pathname manipulation functions (Marco Baringer)
+Temporary files (merged by Marco Baringer)
+Fix symlink behaviour for some platforms (Mihai Bazon and Janis Dzerins)
+
+Version 0.6.4
+2010-11-18
+Adapt to newer ClozureCL version (patch from Zach Beane, thanks to Chun Tian and Ralph Moritz as well)
+
+Version 0.6.3
+2009-09-30
+Removed dependency on :SB-EXECUTABLE (thanks to Attila Lendvai and Tobias Rittweiler)
+
+Version 0.6.2
+2008-03-12
+Never version of OpenMCL have %RMDIR (thanks to Dmitri Hrapof)
+
+Version 0.6.1
+2007-12-29
+Integrated CLISP patch for LIST-DIRECTORY sent by Dan Muller
+
+Version 0.6.0
+2007-05-28
+Support for Scieneer CL (patch from Douglas Crosher)
+
+Version 0.5.2
+2007-05-15
+Fix for (newer versions of) ECL (patch from Dustin Long)
+
+Version 0.5.1
+2006-08-11
+Added CHECKP to COPY-STREAM
+
+Version 0.5.0
+2006-04-21
+Added :BREADTH-FIRST option to WALK-DIRECTORY (thanks to Mac Chan)
+
+Version 0.4.3
+2006-03-15
+For CMUCL use TRUENAME with UNIX-RMDIR to cope with search lists (reported by Pawel Ostrowski)
+
+Version 0.4.2
+2006-01-04
+WALK-DIRECTORY now catches circular symbolic links (thanks to Gary King)
+
+Version 0.4.1
+2006-01-03
+Be more careful in DIRECTORY-WILDCARD (thanks to Gary King)
+Patches for MCL (thanks to Gary King)
+
+Version 0.4.0
+2005-12-10
+Exported COPY-STREAM (suggested by Chris Dean)
+
+Version 0.3.3
+2005-11-14
+Fixed %RMDIR for newer versions of OpenMCL (thanks to James Bielman)
+
+Version 0.3.2
+2005-09-11
+Fixed docs (correct name DELETE-DIRECTORY-AND-FILES)
+Fixed docs (OVERWRITE was missing in COPY-FILE signature)
+Added Debian link
+
+Version 0.3.1
+2005-06-02
+Fixed typo in fad.lisp (thanks to Jack D. Unrue)
+
+Version 0.3.0
+2005-06-01
+Support for ABCL (thanks to Jack D. Unrue)
+
+Version 0.2.0
+2005-05-29
+Support for ECL (thanks to Maciek Pasternacki)
+
+Version 0.1.3
+2005-04-27
+Changed implementation of DIRECTORY-EXISTS-P for LispWorks
+
+Version 0.1.2
+2005-03-17
+Fixed typo in cl-fad.system (tanks to Andrew Philpot)
+
+Version 0.1.1
+2005-01-22
+Fixed typos and versioning
+
+Version 0.1.0
+2005-01-22
+Initial release
--- /dev/null
+;;; Copyright (c) 2004, Peter Seibel. All rights reserved.
+;;; Copyright (c) 2004-2010, Dr. Edmund Weitz. All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;; * Redistributions of source code must retain the above copyright
+;;; notice, this list of conditions and the following disclaimer.
+
+;;; * 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 BY THE AUTHORS 'AS IS' AND ANY EXPRESSED
+;;; 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 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.
--- /dev/null
+Complete documentation for CL-FAD can be found in the 'doc'
+directory.
+
+CL-FAD also supports Nikodemus Siivola's HYPERDOC, see
+<http://common-lisp.net/project/hyperdoc/> and
+<http://www.cliki.net/hyperdoc>.
+
+1. Installation
+
+1.1. Probably the easiest way is
+
+ (load "/path/to/cl-fad/load.lisp")
+
+ This should compile and load CL-FAD on most Common Lisp
+ implementations.
+
+1.2. With MK:DEFSYSTEM you can make a symbolic link from
+ 'cl-fad.system' and 'cl-fad-test.system' to your central registry
+ (which by default is in '/usr/local/lisp/Registry/') and then issue
+ the command
+
+ (mk:compile-system "cl-fad")
+
+ Note that this relies on TRUENAME returning the original file a
+ symbolic link is pointing to. This will only work with AllegroCL
+ 6.2 if you've applied all patches with (SYS:UPDATE-ALLEGRO).
+
+1.3. You can also use ASDF instead of MK:DEFSYSTEM in a similar way
+ (use the .asd files instead of the .system files).
+
+2. Test
+
+CL-FAD comes with a small test suite. To start it just load the file
+"test.lisp" and evaluate (CL-FAD-TEST:TEST).
--- /dev/null
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/cl-fad/cl-fad.asd,v 1.21 2009/09/30 14:23:09 edi Exp $
+
+;;; Copyright (c) 2004-2010, Dr. Edmund Weitz. All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;; * Redistributions of source code must retain the above copyright
+;;; notice, this list of conditions and the following disclaimer.
+
+;;; * 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 BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; 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 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.
+
+#+:allegro (cl:require :osi)
+
+(asdf:defsystem #:cl-fad
+ :version "0.7.4"
+ :description "Portable pathname library"
+ :serial t
+ :components ((:file "packages")
+ #+:cormanlisp (:file "corman")
+ #+:openmcl (:file "openmcl")
+ (:file "fad")
+ (:file "path" :depends-on ("fad"))
+ (:file "temporary-files" :depends-on ("fad")))
+ :depends-on (#+sbcl :sb-posix :bordeaux-threads :alexandria))
+
+(asdf:defsystem #:cl-fad-test
+ :serial t
+ :components ((:file "packages.test")
+ (:file "fad.test" :depends-on ("packages.test"))
+ (:file "temporary-files.test" :depends-on ("packages.test")))
+ :depends-on (:cl-fad :unit-test :cl-ppcre))
--- /dev/null
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/cl-fad/cl-fad.system,v 1.8 2008/03/12 00:10:43 edi Exp $
+
+;;; Copyright (c) 2005-2008, Dr. Edmund Weitz. All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;; * Redistributions of source code must retain the above copyright
+;;; notice, this list of conditions and the following disclaimer.
+
+;;; * 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 BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; 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 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.
+
+(in-package #:cl-user)
+
+(defparameter *cl-fad-base-directory*
+ (make-pathname :name nil :type nil :version nil
+ :defaults (parse-namestring *load-truename*)))
+
+#+:allegro (require :osi)
+#+:sbcl (require :sb-executable)
+#+:sbcl (require :sb-posix)
+
+(mk:defsystem #:cl-fad
+ :source-pathname *cl-fad-base-directory*
+ :source-extension "lisp"
+ :components ((:file "packages")
+ #+:cormanlisp (:file "corman" :depends-on ("packages"))
+ #+:openmcl (:file "openmcl" :depends-on ("packages"))
+ (:file "fad" :depends-on ("packages"
+ #+:cormanlisp "corman"
+ #+:openmcl "openmcl"))))
--- /dev/null
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/cl-fad/corman.lisp,v 1.5 2009/09/30 14:23:09 edi Exp $
+
+;;; Copyright (c) 2004-2010, Dr. Edmund Weitz. All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;; * Redistributions of source code must retain the above copyright
+;;; notice, this list of conditions and the following disclaimer.
+
+;;; * 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 BY THE AUTHORS 'AS IS' AND ANY EXPRESSED
+;;; 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 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.
+
+(in-package :cl)
+
+(defun wild-pathname-p (pathspec &optional field)
+ (unless (pathnamep pathspec)
+ (setq pathspec (pathname pathspec)))
+ (labels ((name-wild-p (name)
+ (or (eq :wild name)
+ (and (stringp name)
+ (string= "*" name))))
+ (dir-wild-p (dir)
+ (or (find :wild dir)
+ (find :wild-inferiors dir)
+ (find "*" dir :test #'string=))))
+ (case field
+ ((:name)
+ (name-wild-p (pathname-name pathspec)))
+ ((:type)
+ (name-wild-p (pathname-type pathspec)))
+ ((:directory)
+ (dir-wild-p (pathname-directory pathspec)))
+ ((nil)
+ (or (name-wild-p (pathname-name pathspec))
+ (name-wild-p (pathname-type pathspec))
+ (dir-wild-p (pathname-directory pathspec))))
+ (t nil))))
+
+(defun file-namestring (pathspec)
+ (flet ((string-list-for-component (component)
+ (cond ((eq component :wild)
+ (list "*"))
+ (component
+ (list component))
+ (t nil))))
+ (let* ((pathname (pathname pathspec))
+ (name (pathnames::pathname-internal-name pathname))
+ (type (pathnames::pathname-internal-type pathname)))
+ (format nil "~{~A~}~{.~A~}"
+ (string-list-for-component name)
+ (string-list-for-component type)))))
+
+(in-package :win32)
+
+(defwinapi RemoveDirectory
+ ((lpPathName LPCSTR))
+ :return-type BOOL
+ :library-name "Kernel32"
+ :entry-name "RemoveDirectoryA"
+ :linkage-type :pascal)
+
+(defun delete-directory (pathspec)
+ "Deletes the empty directory denoted by the pathname designator
+PATHSPEC. Returns true if successful, NIL otherwise."
+ (win:RemoveDirectory
+ (ct:lisp-string-to-c-string
+ (namestring (pathname pathspec)))))
+
+(export 'delete-directory)
--- /dev/null
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN">
+<html>
+
+<head>
+ <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
+ <title>CL-FAD - A portable pathname library for Common Lisp</title>
+ <style type="text/css">
+ pre { padding:5px; background-color:#e0e0e0 }
+ h3, h4, h5 { text-decoration: underline; }
+ a { text-decoration: none; padding: 1px 2px 1px 2px; }
+ a:visited { text-decoration: none; padding: 1px 2px 1px 2px; }
+ a:hover { text-decoration: none; padding: 1px 1px 1px 1px; border: 1px solid #000000; }
+ a:focus { text-decoration: none; padding: 1px 2px 1px 2px; border: none; }
+ a.none { text-decoration: none; padding: 0; }
+ a.none:visited { text-decoration: none; padding: 0; }
+ a.none:hover { text-decoration: none; border: none; padding: 0; }
+ a.none:focus { text-decoration: none; border: none; padding: 0; }
+ a.noborder { text-decoration: none; padding: 0; }
+ a.noborder:visited { text-decoration: none; padding: 0; }
+ a.noborder:hover { text-decoration: none; border: none; padding: 0; }
+ a.noborder:focus { text-decoration: none; border: none; padding: 0; }
+ pre.none { padding:5px; background-color:#ffffff }
+ </style>
+</head>
+
+<body bgcolor=white>
+
+<h2>CL-FAD - A portable pathname library for Common Lisp</h2>
+
+<blockquote>
+<br> <br><h3><a name=abstract class=none>Abstract</a></h3>
+
+CL-FAD (for "<font color=red>F</font>iles <font color=red>a</font>nd
+<font color=red>D</font>irectories") is a thin layer atop Common
+Lisp's standard pathname functions. It is intended to provide some
+unification between current CL implementations on Windows, OS X,
+Linux, and Unix. Most of the code was written by Peter Seibel for his book <a href="http://www.gigamonkeys.com/book/"><em>Practical Common Lisp</em></a>.
+
+<p>
+
+CL-FAD comes with a <a
+href="http://www.opensource.org/licenses/bsd-license.php">BSD-style
+license</a> so you can basically do with it whatever you want.
+
+<p>
+<font color=red>Download shortcut:</font> <a href="http://weitz.de/files/cl-fad.tar.gz">http://weitz.de/files/cl-fad.tar.gz</a>.
+</blockquote>
+
+<br> <br><h3><a class=none name="contents">Contents</a></h3>
+<ol>
+ <li><a href="#download">Download and installation</a>
+ <li><a href="#implementations">Supported Lisp implementations</a>
+ <li><a href="#dictionary">The CL-FAD dictionary</a>
+ <ol>
+ <li><a href="#querying">Querying files, directories and pathnames</a>
+ <ol>
+ <li><a href="#directory-exists-p"><code>directory-exists-p</code> [function]</a>
+ <li><a href="#directory-pathname-p"><code>directory-pathname-p</code> [function]</a>
+ <li><a href="#file-exists-p"><code>file-exists-p</code> [function]</a>
+ <li><a href="#pathname-absolute-p"><code>pathname-absolute-p</code> [function]</a>
+ <li><a href="#pathname-equal"><code>pathname-equal</code> [function]</a>
+ <li><a href="#pathname-relative-p"><code>pathname-relative-p</code> [function]</a>
+ <li><a href="#pathname-root-p"><code>pathname-root-p</code> [function]</a>
+ </ol> </li>
+ <li><a href="#manipulating">Manipulating pathnames</a>
+ <ol>
+ <li><a href="#canonical-pathname"><code>canonical-pathname</code> [function]</a>
+ <li><a href="#merge-pathnames-as-directory"><code>merge-pathnames-as-directory</code> [function]</a>
+ <li><a href="#merge-pathnames-as-file"><code>merge-pathnames-as-file</code> [function]</a>
+ <li><a href="#pathname-as-directory"><code>pathname-as-directory</code> [function]</a>
+ <li><a href="#pathname-as-file"><code>pathname-as-file</code> [function]</a>
+ <li><a href="#pathname-directory-pathname"><code>pathname-directory-pathname</code> [function]</a>
+ <li><a href="#pathname-parent-directory"><code>pathname-parent-directory</code> [function]</a>
+ </ol> </li>
+ <li><a href="#traversing">Traversing directories</a>
+ <ol>
+ <li><a href="#list-directory"><code>list-directory</code> [function]</a>
+ <li><a href="#walk-directory"><code>walk-directory</code> [function]</a>
+ </ol> </li>
+ <li><a href="#temporary-files">Temporary Files</a>
+ <ol>
+ <li><a href="#open-temporary"><code>open-temporary</code> [function]</a>
+ <li><a href="#with-output-to-temporary-file"><code>with-output-to-temporary-file</code> [macro]</a>
+ <li><a href="#with-open-temporary-file"><code>with-open-temporary-file</code> [macro]</a>
+ <li><a href="#star-default-template-star"><code>*default-template*</code> [variable]</a>
+ <li><a href="#cannot-create-temporary-file"><code>cannot-create-temporary-file</code> [condition]</a>
+ <li><a href="#invalid-temporary-pathname-template"><code>invalid-temporary-pathname-template</code> [condition]</a>
+ <li><a href="#missing-temp-environment-variable"><code>missing-temp-environment-variable</code> [condition]</a>
+ <li><a href="#lp-host-temporary-files"><code>temporary-files</code> [logical pathname host]</a>
+ </ol>
+ </li>
+ <li><a href="#modifying">Modifying the file system</a>
+ <ol>
+ <li><a href="#copy-file"><code>copy-file</code> [function]</a>
+ <li><a href="#copy-stream"><code>copy-stream</code> [function]</a>
+ <li><a href="#delete-directory-and-files"><code>delete-directory-and-files</code> [function]</a>
+ </ol> </li>
+ <li><a href="#package-path"><code>path</code> [package]</a>
+ </ol>
+ <li><a href="#ack">Acknowledgements</a>
+</ol>
+
+
+
+<br> <br><h3><a class=none name="download">Download and installation</a></h3>
+
+CL-FAD together with this documentation can be downloaded from <a
+href="http://weitz.de/files/cl-fad.tar.gz">http://weitz.de/files/cl-fad.tar.gz</a>. The
+current version is 0.7.2.
+<p>
+CL-FAD comes with simple system definitions for <a
+href="http://www.cliki.net/mk-defsystem">MK:DEFSYSTEM</a> and <a
+href="http://www.cliki.net/asdf">asdf</a> so you can either adapt it
+to your needs or just unpack the archive and from within the CL-FAD
+directory start your Lisp image and evaluate the form
+<code>(mk:compile-system "cl-fad")</code> - or <code>(asdf:oos 'asdf:load-op :cl-fad)</code> for asdf - which should compile and load the whole
+system.
+Installation via <a
+href="http://www.cliki.net/asdf-install">asdf-install</a> should as well
+be possible. Plus, there are ports
+for <a href="http://www.gentoo.org/proj/en/common-lisp/index.xml">Gentoo Linux</a> thanks to Matthew Kennedy
+and for <a href="http://packages.debian.org/cgi-bin/search_packages.pl?keywords=cl-fad&searchon=names&subword=1&version=all&release=all">Debian Linux</a> thanks to René van Bevern.
+<p>
+If for some reason you can't or don't want to use MK:DEFSYSTEM or asdf you
+can just <code>LOAD</code> the file <code>load.lisp</code>.
+<p>
+The latest version of the source code lives in the github repository <a href="https://github.com/edicl/cl-fad">edicl/cl-fad</a>.
+
+If you want to send patches,
+please <a href="http://weitz.de/patches.html">read this first</a>.
+Please submit your changes
+as <a href="https://github.com/edicl/cl-fad/pulls">GitHub pull
+request"</a>.
+
+<br> <br><h3><a class=none name="implementations">Supported Lisp implementations</a></h3>
+
+<p>
+The following Common Lisp implementations are currently supported:
+<ul>
+<li><a href="http://armedbear.org/abcl.html">Armed Bear Common Lisp</a>
+<li><a href="http://www.cons.org/cmucl/">CMUCL</a>
+<li><a href="http://www.cormanlisp.com/">Corman Common Lisp</a>
+<li><a href="http://ecls.sf.net/">ECL</a>
+<li><a href="http://www.franz.com/products/allegrocl/">Franz AllegroCL</a>
+<li><a href="http://clisp.cons.org/">GNU CLISP</a>
+<li><a href="http://www.lispworks.com/">LispWorks</a>
+<li><a href="http://www.digitool.com/">Macintosh Common Lisp</a>
+<li><a href="http://openmcl.clozure.com/">OpenMCL</a>
+<li><a href="http://www.scieneer.com/scl/">Scieneer Common Lisp</a>
+<li><a href="http://sbcl.sourceforge.net/">Steel Bank Common Lisp</a>
+</ul>
+
+I'll gladly accepts patches to make CL-FAD work on other platforms.
+
+
+<br> <br><h3><a class=none name="dictionary">The CL-FAD dictionary</a></h3>
+
+<h4><a class=none name="querying">Querying files, directories and pathnames</a></h4>
+
+<p><br>[Function]
+<br><a class=none name="directory-exists-p"><b>directory-exists-p</b> <i> pathspec </i> => <i> generalized-boolean</i></a>
+
+<blockquote><br>
+Checks whether the file named by the <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_p.htm#pathname_designator">pathname designator</a> <code><i>pathspec</i></code>
+exists and if it is a directory. Returns its <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_t.htm#truename">truename</a> if this is the
+case, <code>NIL</code> otherwise. The truename is returned in <em>directory form</em> as if
+by <a href="#pathname-as-directory"><code>PATHNAME-AS-DIRECTORY</code></a>.
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="directory-pathname-p"><b>directory-pathname-p</b> <i> pathspec </i> => <i> generalized-boolean</i></a>
+
+<blockquote><br>
+Returns <code>NIL</code> if <code><i>pathspec</i></code> (a <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_p.htm#pathname_designator">pathname designator</a>) does not designate
+a directory, <code><i>pathspec</i></code> otherwise. It is irrelevant whether the file or
+directory designated by <code><i>pathspec</i></code> does actually exist.
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="file-exists-p"><b>file-exists-p</b> <i> pathspec </i> => <i> generalized-boolean</i></a>
+
+<blockquote><br>
+Checks whether the file named by the <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_p.htm#pathname_designator">pathname designator</a> <code><i>pathspec</i></code>
+exists and returns its <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_t.htm#truename">truename</a> if this is the case, <code>NIL</code> otherwise.
+The truename is returned in "canonical" form, i.e. the truename of a
+directory is returned in <em>directory form</em> as if by <a href="#pathname-as-directory"><code>PATHNAME-AS-DIRECTORY</code></a>.
+</blockquote>
+
+<p><br>[Function]<br><a class=none name='pathname-absolute-p'><b>pathname-absolute-p</b> <i>a</i> => <i>result</i></a>
+<blockquote>
+<p>Returns true if <code><i>a</i></code> is an absolute pathname. This simply
+tests if <code><i>a</i></code>'s directory list starts with <code>:ABSOLUTE</code></p>
+</blockquote>
+
+<p><br>[Function]<br><a class=none name='pathname-equal'><b>pathname-equal</b> <i>a b</i> => <i>result</i></a>
+<blockquote>
+
+<p>Returns <em>true</em> if <code><i>a</i></code> and <code><i>b</i></code>
+represent the same pathname. This function does not access the
+filesystem, it only looks at the components of the two pathnames to
+test if they are the same (though by passing both <code><i>a</i></code>
+and <code><i>b</i></code> to probe-file one can make this function test for
+file 'sameness'.</p>
+
+<p>Equality is defined as:</p>
+
+<ul>
+ <li>strings that are <code>string=</code>
+ <li>symbols (including <code>nil</code> and keywords) which are <code>eql</code>
+ <li>lists of the same length with equal (as per these rules) elements.
+</ul>
+
+<p>If any of these tree conditions is false for any of the components in
+<code><i>a</i></code> and <code><i>b</i></code> then <code><i>a</i></code>
+and <code><i>b</i></code> are different, otherwise they are the same.</p>
+
+<p><em>NB:</em> This function does not convert name strings to pathnames. So
+"foo.txt" and #P"foo.txt" are different pathnames.</p>
+
+</blockquote>
+
+<p><br>[Function]<br><a class=none name='pathname-relative-p'><b>pathname-relative-p</b> <i>a</i> => <i>result</i></a>
+<blockquote>
+<p>Returns true if <code><i>a</i></code> is a relative pathname. This simply
+tests if <code><i>a</i></code>'s directory starts
+with <code>:RELATIVE</code>.</p>
+</blockquote>
+
+<p><br>[Function]<br><a class=none name='pathname-root-p'><b>pathname-root-p</b> <i>a</i> => <i>result</i></a>
+<blockquote>
+<p>Returns <em>true</em> if <code><i>pathname</i></code> is the root
+directory (in other words, a directory which is its own parent).</p>
+</blockquote>
+
+<h4><a class=none name="manipulating">Manipulating pathnames</a></h4>
+
+<p><br>[Function]<br><a class=none name='canonical-pathname'><b>canonical-pathname</b> <i>pathname</i> => <i>result</i></a>
+<blockquote>
+<p>Remove reduntant information from PATHNAME.</p>
+
+<p>This simply walks down <code>PATHNAME</code>'s
+pathname-directory and drops "." directories, removes :back
+and its preceding element.</p>
+
+<p>NB: This function does not access the filesystem, it only looks at the
+values in the pathname and works on their known (or assumed)
+meanings.</p>
+
+<p>NB: Since this function does not access the filesystem it will only
+remove <code>:BACK</code> elements from the path (not <code>:UP</code>
+elements). Since some lisps, ccl/sbcl/clisp convert ".." in
+pathnames to <code>:UP</code>, and not <code>:BACK</code>, the actual
+utility of the function is limited.</p>
+</blockquote>
+
+<p><br>[Function]<br><a class=none name='merge-pathnames-as-directory'><b>merge-pathnames-as-directory</b> <i><tt>&rest</tt> pathnames</i> => <i>result</i></a>
+<blockquote>
+<p>Given a list of, probably relative, pathnames returns a single
+directory pathname containing the logical concatenation of them all.</p>
+
+<p>The returned value is the current directory if one were to cd into
+each of <code><i>pathnames</i></code> in order. For this reason an
+absolute pathname will, effectively, cancel the affect of any previous
+relative pathnames.</p>
+
+<p>The returned value's defaults are taken from the first element of
+<code><i>pathnames</i></code> (host, version and device).</p>
+
+<p><em>NB:</em> Since this function only looks at directory names the name and
+type of the elements of <code><i>pathnames</i></code> are ignored. Make sure to properly
+use either trailing #\/s, or <a href="#pathname-as-directory">pathname-as-directory</a>, to get the
+expected results.</p>
+
+<p>Examples:</p>
+
+<pre>
+ (merge-pathnames-as-directory #P"foo/" #P"bar/") == #P"foo/bar/"
+
+ (merge-pathnames-as-directory #P"foo/" #P"./bar/") == #P"foo/./bar/"
+
+ (merge-pathnames-as-directory #P"foo/" #P"/bar/") == #P"/bar/"
+
+ (merge-pathnames-as-directory #P"foo/" #P"/bar/" #P'quux/file.txt) == #P"/bar/quux/"
+</pre>
+
+</blockquote>
+
+<p><br>[Function]<br><a class=none name='merge-pathnames-as-file'><b>merge-pathnames-as-file</b> <i><tt>&rest</tt> pathnames</i> => <i>result</i></a>
+<blockquote>
+<p>Given a list of, probably relative, pathnames returns a single
+filename pathname containing the logical concatenation of them all.</p>
+
+<p>The returned value's defaults are taken from the first element of
+<code><i>pathnames</i></code> (host, version and device). The returned
+values's name, type and version are taken from the last element
+of <code><i>pathnames</i></code>. The intervening elements are used only for
+their pathname-directory values.</p>
+
+Examples:
+
+<pre>
+ (merge-pathnames-as-file #P"foo/" #P"bar.txt") == #P"foo/bar.txt"
+
+ (merge-pathnames-as-file #P"foo/" #P"./bar.txt") == #P"foo/./bar.txt"
+
+ (merge-pathnames-as-file #P"foo/" #P"/bar/README") == #P"/bar/README"
+
+ (merge-pathnames-as-file #P"/foo/" #P"/bar/" #P'quux/file.txt) == #P"/bar/quux/file.txt"
+</pre>
+
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="pathname-as-directory"><b>pathname-as-directory</b> <i> pathspec </i> => <i> pathname</i></a>
+<blockquote><br>
+Converts the <em>non-wild</em> <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_p.htm#pathname_designator">pathname designator</a> <code><i>pathspec</i></code> to <em>directory form</em>, i.e. it returns a <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_p.htm#pathname">pathname</a> which would return a <em>true</em> value if fed to <a href="#directory-pathname-p"><code>DIRECTORY-PATHNAME-P</code></a>.
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="pathname-as-file"><b>pathname-as-file</b> <i> pathspec </i> => <i> pathname</i></a>
+
+<blockquote><br>
+Converts the <em>non-wild</em> <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_p.htm#pathname_designator">pathname designator</a> <code><i>pathspec</i></code> to <em>file form</em>, i.e. it returns a <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_p.htm#pathname">pathname</a> which would return a <code>NIL</code> value if fed to <a href="#directory-pathname-p"><code>DIRECTORY-PATHNAME-P</code></a>.
+</blockquote>
+
+<p><br>[Function]<br><a class=none name='pathname-directory-pathname'><b>pathname-directory-pathname</b> <i>pathname</i> => <i>result</i></a>
+<blockquote>
+<p>Returns a complete pathname representing the directory of
+<code><i>pathname</i></code>. If <code><i>pathname</i></code> is
+already a directory pathname
+(<code>name</code> <code>nil</code>, <code>type</code>
+<code>nil</code>) returns a pathname equal (as
+per <a href="#pathname-equal">pathname-equal</a>) to it.</p>
+</blockquote>
+
+<p><br>[Function]<br><a class=none name='pathname-parent-directory'><b>pathname-parent-directory</b> <i>pathname</i> => <i>result</i></a>
+<blockquote>
+
+<p>Returns a pathname which would, by name at least,
+contain <code><i>pathname</i></code> as one of its direct
+children. Symlinks can make the parent/child relationship a like
+opaque, but generally speaking the value returned by this function is
+a directory name which contains <code><i>pathname</i></code>.</p>
+
+<p>The root directory, #P"/", is its own parent. The parent
+directory of a filename is the parent of the filename's
+dirname.</p>
+
+</blockquote>
+
+<h4><a class=none name="traversing">Traversing directories</a></h4>
+
+<p><br>[Function]
+<br><a class=none name="list-directory"><b>list-directory</b> <i> dirname <tt>&key</tt> follow-symlinks</i> => <i> list</i></a>
+
+<blockquote><br>
+<p>
+Returns a <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_f.htm#fresh">fresh</a> list of pathnames corresponding to
+all files within the directory named by the non-wild <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_p.htm#pathname_designator">pathname designator</a> <code><i>dirname</i></code>. The pathnames of sub-directories are returned in
+<em>directory form</em> - see <a href="#pathname-as-directory"><code>PATHNAME-AS-DIRECTORY</code></a>.
+</p>
+<p>
+ If <code><i>follow-symlinks</i></code> is true (which is the
+ default), then the returned list contains truenames (symlinks will
+ be resolved) which essentially means that it might also return files
+ from <b>outside</b> the directory. This works on all platforms.
+</p>
+<p>
+ When <code><i>follow-symlinks</i></code> is <code>NIL</code>, it should return the actual directory
+ contents, which might include symlinks. (This is currently implemented only on SBCL and CCL.)
+</p>
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="walk-directory"><b>walk-directory</b> <i> dirname fn <tt>&key</tt> directories if-does-not-exist test follow-symlinks</i> => |</a>
+
+<blockquote><br>
+<p>
+ Recursively applies the function designated by the <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_f.htm#function_designator">function
+ designator</a> <code><i>fn</i></code> to all files within the directory named
+ by the non-wild <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_p.htm#pathname_designator">pathname
+ designator</a> <code><i>dirname</i></code> and all of its sub-directories. <code><i>fn</i></code>
+ will only be applied to files for which the function <code><i>test</i></code>
+ returns a <em>true</em> value. (The default value for <code><i>test</i></code>
+ always returns <em>true</em>.) If <code><i>directories</i></code> is not <code>NIL</code>,
+ <code><i>fn</i></code> and <code><i>test</i></code> are applied to directories
+ as well. If <code><i>directories</i></code> is <code>:DEPTH-FIRST</code>, <code><i>fn</i></code>
+ will be applied to the directory's contents first. If <code><i>directories</i></code>
+ is <code>:BREADTH-FIRST</code> and <code><i>test</i></code> returns <code>NIL</code>, the
+ directory's content will be skipped. <code><i>if-does-not-exist</i></code> must
+ be one of <code>:ERROR</code> or <code>:IGNORE</code> where <code>:ERROR</code>
+ (the default) means that an error will be signaled if the directory <code><i>dirname</i></code>
+ does not exist.
+</p>
+<p>
+ If <code><i>follow-symlinks</i></code> is true (which is
+ the default), then your callback will receive truenames. Otherwise
+ you should get the actual directory contents, which might include
+ symlinks. This might not be supported on all platforms. See
+ <a href="#list-directory"><code>LIST-DIRECTORY</code></a>.
+</p>
+</blockquote>
+
+<h4><a class=none name="temporary-files">Temporary Files</a></h4>
+
+<h5>Synopsis</h5>
+
+ <p>
+ Create a temporary file and return its name:
+<pre>CL-USER> (temporary-file:<code xmlns=""><a href="#with-output-to-temporary-file">with-output-to-temporary-file</a></code> (foo)
+ (print "hello" foo))
+#P"/var/folders/Yu/YuNMNBNPGoqs9G-1Wmj1dk+++TI/-Tmp-/temp-yjck024x"</pre>
+ </p>
+ <p>
+ Create a temporary file, read and write it, have it be deleted
+ automatically:
+<pre>CL-USER> (temporary-file:<code xmlns=""><a href="#with-open-temporary-file">with-open-temporary-file</a></code> (foo :direction :io)
+ (print "hello" foo)
+ (file-position foo 0)
+ (read foo))
+"hello"</pre>
+ </p>
+
+ <h5><a class="none" name="default-temporary-directory">Default temporary file directory</a></h5>
+ By default, temporary files are created in a system specific
+ directory that defaults based on operating system conventions. On
+ Unix and Unix-like systems, the directory <tt>/tmp/</tt> is used
+ by default. It can be overridden by setting the <tt>TMPDIR</tt>
+ environment variable. On Windows, the value of the environment
+ variable <tt>TEMP</tt> is used. If it is not set, temporary file
+ creation will fail.
+
+ <h5><a class="none" name="defining-temporary-directory">Defining the temporary file directory</a></h5>
+ <p>
+ The Lisp application can set the default directory in which
+ temporary files are created by the way of the
+ <code xmlns=""><a href="#temporary-files">temporary-files</a></code> logical pathname host:
+
+<pre>(setf (<a xmlns="" href="http://www.lispworks.com/documentation/HyperSpec/Body/f_logica.htm">logical-pathname-translations</a> "<code xmlns=""><a href="#temporary-files">temporary-files</a></code>") '(("*.*.*" "/var/tmp/")))</pre>
+
+ This would set the directory for temporary files to
+ <tt>/var/tmp/</tt>. For more information about logical
+ pathnames, please refer to <a href="http://www.cs.cmu.edu/afs/cs/project/ai-repository/ai/html/cltl/clm/node208.html#SECTION002715000000000000000">Common
+ Lisp the Language, 2nd Edition</a> and the <a href="http://clhs.lisp.se/Body/19_.htm">Common Lisp
+ HyperSpec</a>.
+ </p>
+ <p>
+ Physical path names have restrictions regarding the permitted
+ character in file names. If these restrictions conflict with
+ your desired naming scheme, you can pass a physical pathname as
+ TEMPLATE parameter to the temporary file generation function.
+ </p>
+ <p>
+ Here are a few examples:
+<pre>CL-USER> (<a xmlns="" href="http://www.lispworks.com/documentation/HyperSpec/Body/f_logica.htm">logical-pathname-translations</a> "temporary-files")
+(("*.*.*" #P"/var/folders/Yu/YuNMNBNPGoqs9G-1Wmj1dk+++TI/-Tmp-/"))
+CL-USER> (temporary-file:<code xmlns=""><a href="#with-open-temporary-file">with-open-temporary-file</a></code> (foo)
+ (<a xmlns="" href="http://www.lispworks.com/documentation/HyperSpec/Body/f_pn.htm">pathname</a> foo))
+#P"/var/folders/Yu/YuNMNBNPGoqs9G-1Wmj1dk+++TI/-Tmp-/temp-6rdqdkd1"</pre>
+
+ This used the temporary directory established in the TMPDIR
+ environment variable, by the way of the definition of the
+ temporary-files logical host definition.
+
+<pre>CL-USER> (temporary-file:<code xmlns=""><a href="#with-open-temporary-file">with-open-temporary-file</a></code> (foo :template "/tmp/file.with.dots.in.name.%.txt")
+ (<a xmlns="" href="http://www.lispworks.com/documentation/HyperSpec/Body/f_pn.htm">pathname</a> foo))
+#P"/tmp/file.with.dots.in.name.2EF04KUJ.txt"</pre>
+
+ Here, a physical pathname was used for the
+ <code xmlns=""><i>:template</i></code> keyword argument so that a
+ filename containing multiple dots could be generated.
+
+<pre>CL-USER> (temporary-file:<code xmlns=""><a href="#with-open-temporary-file">with-open-temporary-file</a></code> (foo :template "temporary-files:blah-%.txt")
+ (<a xmlns="" href="http://www.lispworks.com/documentation/HyperSpec/Body/f_pn.htm">pathname</a> foo))
+#P"/var/folders/Yu/YuNMNBNPGoqs9G-1Wmj1dk+++TI/-Tmp-/blah-72mj450d.txt"</pre>
+
+ This used the temporary-files logical pathname host, but changed
+ the filename slightly.
+
+<pre>CL-USER> *default-pathname-defaults*
+#P"/Users/hans/"
+CL-USER> (temporary-file:<code xmlns=""><a href="#with-open-temporary-file">with-open-temporary-file</a></code> (foo :template "blah-%.txt")
+ (<a xmlns="" href="http://www.lispworks.com/documentation/HyperSpec/Body/f_pn.htm">pathname</a> foo))
+#P"/Users/hans/blah-5OEJELG2.txt"</pre>
+
+ Here, a relative pathname was used in the template, which
+ caused the file to be generated in the directory established
+ by <a xmlns="" href="http://www.lispworks.com/documentation/HyperSpec/Body/v_defaul.htm">*default-pathname-defaults*</a>.
+ </p>
+ <p>
+ Alternatively, the <code xmlns=""><a href="#*default-template*">*default-template*</a></code>
+ special variable can be set to define a custom default template
+ for generating names.
+ </p>
+
+ <h5 xmlns=""><a class="none" name="security">Security</a></h5>
+ The TEMPORARY-FILE library does not directly address security
+ issues. The application that uses it needs to take additional
+ measures if it is important that files created by one process
+ cannot be accessed by other, unrelated processes. This can be
+ done by using the system dependent security mechanisms like
+ default file permissions or access control lists.
+
+ <h5>Dictionary</h5>
+
+
+ <p xmlns="">[Function]<br><a class="none" name="open-temporary"><b>open-temporary</b> <i><clix:lambda-list xmlns:clix="http://bknr.net/clixdoc">&rest open-arguments &key template generate-random-string max-tries &allow-other-keys</clix:lambda-list></i>
+ =>
+ <i>stream</i></a><blockquote><clix:description xmlns:clix="http://bknr.net/clixdoc">
+ <p xmlns="http://www.w3.org/1999/xhtml">
+ Create a file with a randomly generated name and return the
+ opened stream. The resulting pathname is generated from
+ <code xmlns=""><i>template</i></code>, which is a string
+ representing a pathname template. A percent sign (%) in
+ that string is replaced by a randomly generated string to
+ make the filename unique. The default for
+ <code xmlns=""><i>template</i></code> places temporary files in the
+ <code xmlns=""><a href="#temporary-files">temporary-files</a></code> logical pathname host,
+ which is automatically set up in a system specific manner.
+ The file name generated from <code xmlns=""><i>template</i></code>
+ is merged with <a xmlns="" href="http://www.lispworks.com/documentation/HyperSpec/Body/v_defaul.htm">*default-pathname-defaults*</a>,
+ so random pathnames relative to that directory can be
+ generated by not specifying a directory in
+ <code xmlns=""><i>template</i></code>.
+ </p>
+ <p xmlns="http://www.w3.org/1999/xhtml">
+ <code xmlns=""><i>generate-random-string</i></code> can be passed to
+ override the default function that generates the random name
+ component. It should return a random string consisting of
+ characters that are permitted in a pathname (logical or
+ physical, depending on <code xmlns=""><i>template</i></code>).
+ </p>
+ <p xmlns="http://www.w3.org/1999/xhtml">
+ The name of the temporary file can be accessed calling the
+ <a xmlns="" href="http://www.lispworks.com/documentation/HyperSpec/Body/f_pn.htm">pathname</a>
+ function on <code xmlns=""><i>stream</i></code>. For convenience,
+ the temporary file is opened on the physical pathname,
+ i.e. if the <code xmlns=""><i>template</i></code> designate a
+ logical pathname the translation to a physical pathname is
+ performed before opening the stream.
+ </p>
+ <p xmlns="http://www.w3.org/1999/xhtml">
+ In order to create a unique file name,
+ <code xmlns=""><a href="#open-temporary">open-temporary</a></code> may loop internally up
+ to <code xmlns=""><i>max-tries</i></code> times before giving up and
+ signalling a
+ <code xmlns=""><a href="#cannot-create-temporary-file">cannot-create-temporary-file</a></code> condition.
+ </p>
+ <p xmlns="http://www.w3.org/1999/xhtml">
+ Any unrecognized keyword arguments are passed to the call to
+ <a xmlns="" href="http://www.lispworks.com/documentation/HyperSpec/Body/f_open.htm">open</a>.
+ </p>
+ </clix:description></blockquote></p>
+ <p xmlns="">[Macro]<br><a class="none" name="with-output-to-temporary-file"><b>with-output-to-temporary-file</b> <i><clix:lambda-list xmlns:clix="http://bknr.net/clixdoc">(stream &rest args) &body body</clix:lambda-list></i>
+ =>
+ <i>pathname</i></a><blockquote><clix:description xmlns:clix="http://bknr.net/clixdoc">
+ Create a temporary file using
+ <code xmlns=""><a href="#open-temporary">open-temporary</a></code> with
+ <code xmlns=""><i>args</i></code> and run <code xmlns=""><i>body</i></code>
+ with <code xmlns=""><i>stream</i></code> bound to the temporary file
+ stream. Returns the pathname of the file that has been
+ created. See <code xmlns=""><a href="#open-temporary">open-temporary</a></code> for
+ permitted options.
+ </clix:description></blockquote></p>
+ <p xmlns="">[Macro]<br><a class="none" name="with-open-temporary-file"><b>with-open-temporary-file</b> <i><clix:lambda-list xmlns:clix="http://bknr.net/clixdoc">(stream &rest args &key keep &allow-other-keys) &body body</clix:lambda-list></i>
+ =>
+ <i>values</i></a><blockquote><clix:description xmlns:clix="http://bknr.net/clixdoc">
+ Create a temporary file using
+ <code xmlns=""><a href="#open-temporary">open-temporary</a></code> with
+ <code xmlns=""><i>args</i></code> and run <code xmlns=""><i>body</i></code>
+ with <code xmlns=""><i>stream</i></code> bound to the temporary file
+ stream. Returns the values returned by
+ <code xmlns=""><i>body</i></code>. By default, the file is deleted
+ when <code xmlns=""><i>body</i></code> is exited. If a true value is
+ passed in <code xmlns=""><i>keep</i></code>, the file is not deleted
+ when the body is exited. See
+ <code xmlns=""><a href="#open-temporary">open-temporary</a></code> for more permitted
+ options.
+ </clix:description></blockquote></p>
+ <p xmlns="">
+ [Special variable]<br><a class="none" name="*default-template*"><b>*default-template*</b></a><blockquote><clix:description xmlns:clix="http://bknr.net/clixdoc">
+ This variable can be set to a string representing the desired
+ default template for temporary file name generation. See
+ <code xmlns=""><a href="#open-temporary">open-temporary</a></code> for a description of the
+ template string format.
+ </clix:description></blockquote></p>
+ <p xmlns="">
+ [Condition type]<br><a class="none" name="cannot-create-temporary-file"><b>cannot-create-temporary-file</b></a><blockquote><clix:description xmlns:clix="http://bknr.net/clixdoc">
+ Signalled when an attempt to create unique temporary file name
+ failed after the established number of retries.
+ </clix:description></blockquote></p>
+ <p xmlns="">
+ [Condition type]<br><a class="none" name="invalid-temporary-pathname-template"><b>invalid-temporary-pathname-template</b></a><blockquote><clix:description xmlns:clix="http://bknr.net/clixdoc">
+ Signalled when the <code xmlns=""><i>template</i></code> argument to
+ <code xmlns=""><a href="#open-temporary">open-temporary</a></code> does not contain a valid
+ template string. The template string must contain a percent
+ sign, which is replaced by the generated random string to
+ yield the filename.
+ </clix:description></blockquote></p>
+ <p xmlns="">
+ [Condition type]<br><a class="none" name="missing-temp-environment-variable"><b>missing-temp-environment-variable</b></a><blockquote><clix:description xmlns:clix="http://bknr.net/clixdoc">
+ (Windows only) Signalled when the TEMP environment variable is
+ not set.
+ </clix:description></blockquote></p>
+ <p xmlns="">
+ [Logical Pathname Host]<br><a class="none" name="lp-host-temporary-files"><b>temporary-files</b></a><blockquote><clix:description xmlns:clix="http://bknr.net/clixdoc">
+ This logical pathname host defines where temporary files are
+ stored by default. It is initialized in a suitable system
+ specific fashion: On Unix and Unix-like systems, the directory
+ specified in the TMPDIR environment variable is used. If that
+ variable is not set, /tmp is used as the default. On Windows,
+ the directory specified in the TEMP environment variable is
+ used. If it is not set, a
+ <code xmlns=""><a href="#missing-temp-environment-variable">missing-temp-environment-variable</a></code> error
+ is signalled.
+ </clix:description></blockquote></p>
+
+
+<h4><a class=none name="modifying">Modifying the file system</a></h4>
+
+<p><br>[Function]
+<br><a class=none name="copy-file"><b>copy-file</b> <i> from to <tt>&key</tt> overwrite</i> => |</a>
+
+<blockquote><br>
+Copies the file designated by the non-wild <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_p.htm#pathname_designator">pathname designator</a> <code><i>from</i></code> to the
+file designated by the non-wild <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_p.htm#pathname_designator">pathname designator</a> <code><i>to</i></code>. If <code><i>overwrite</i></code> is <em>true</em> (the default is <code>NIL</code>)
+overwrites the file designtated by <code><i>to</i></code> if it exists.
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="copy-stream"><b>copy-stream</b> <i> from to <tt>&optional</tt> checkp</i> => |</a>
+
+<blockquote><br> Copies into <code><i>to</i></code> (a stream)
+from <code><i>from</i></code> (also a stream) until the end
+of <code><i>from</i></code> is reached. The streams should have the
+same <a
+href="http://www.lispworks.com/documentation/HyperSpec/Body/f_stm_el.htm">element
+type</a> unless they are bivalent. If <code><i>checkp</i></code> is
+true (which is the default), the function will signal an error if the
+element types aren't the same.
+</blockquote>
+<p><br>[Function]
+<br><a class=none name="delete-directory-and-files"><b>delete-directory-and-files</b> <i> dirname<tt>&key</tt> if-does-not-exist</i> => |</a>
+
+<blockquote><br>
+<p>
+Recursively deletes all files and directories within the directory
+designated by the non-wild <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_p.htm#pathname_designator">pathname designator</a> <code><i>dirname</i></code> including
+<code><i>dirname</i></code> itself. <code><i>if-does-not-exist</i></code> must be one of <code>:ERROR</code> or <code>:IGNORE</code>
+where <code>:ERROR</code> (the default) means that an error will be signaled if the directory
+<code><i>dirname</i></code> does not exist.
+</p>
+<p>
+ <b>Warning:</b> this function <em>might</em> remove files from outside the
+ directory, if the directory that you are deleting contains links to
+ external files. This is currently fixed for SBCL and CCL.
+</p>
+</blockquote>
+
+<h4>The <code>PATH</code> package</h4>
+
+<p><br>[Package]
+<br><a class=none name="package-path">(defpackage <b>path</b>)</a>
+
+<blockquote>
+Provides a set of short names for commonly used pathname manipulation
+functions (these are all functions from the <code>cl-fad</code>
+package which are being exported under different names):
+<dl>
+ <dt><code>dirname</code></dt> <dd><a href="#pathname-as-directory">pathname-as-directory</a></dd>
+ <dt><code>basename</code></dt> <dd><code>cl:file-namestring</code></dd>
+ <dt><code>-e</code></dt> <dd><a href="#file-exists-p">file-exists-p</a></dd>
+ <dt><code>-d</code></dt> <dd><a href="#directory-exists-p">directory-exists-p</a></dd>
+ <dt><code>catfile</code></dt> <dd><a href="#merge-pathnames-as-file">merge-pathnames-as-file</a></dd>
+ <dt><code>catdir</code></dt> <dd><a href="#merge-pathnames-as-directory">merge-pathnames-as-directory</a></dd>
+ <dt><code>rm-r</code></dt> <dd><a href="#delete-directory-and-files">delete-directory-and-files</a></dd>
+ <dt><code>=</code></dt> <dd><a href="#pathname-equal">pathname-equal</a></dd>
+ <dt><code>absolute-p</code></dt> <dd><a href="#pathname-absolute-p">pathname-absolute-p</a></dd>
+ <dt><code>relative-p</code></dt> <dd><a href="#pathname-relative-p">pathname-relative-p</a></dd>
+ <dt><code>root-p</code></dt> <dd><a href="#pathname-root-p">pathname-root-p</a></dd>
+</dl>
+</blockquote>
+
+
+<br> <br><h3><a class=none name="ack">Acknowledgements</a></h3>
+
+The original code for this library was written by Peter Seibel for his
+book <a href="http://www.gigamonkeys.com/book/"><em>Practical Common
+Lisp</em></a>. I added some stuff and made sure it worked properly on
+Windows, specifically with CCL. Thanks to James Bielman, Maciek
+Pasternacki, Jack D. Unrue, Gary King, and Douglas Crosher who sent
+patches for OpenMCL, ECL, ABCL, MCL, and Scieneer CL.
+
+<p>
+$Header: /usr/local/cvsrep/cl-fad/doc/index.html,v 1.33 2009/09/30 14:23:12 edi Exp $
+<p><a href="http://weitz.de/index.html">BACK TO MY HOMEPAGE</a>
+
+</body>
+</html>
+
--- /dev/null
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-FAD; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/cl-fad/fad.lisp,v 1.35 2009/09/30 14:23:10 edi Exp $
+
+;;; Copyright (c) 2004, Peter Seibel. All rights reserved.
+;;; Copyright (c) 2004-2010, Dr. Edmund Weitz. All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;; * Redistributions of source code must retain the above copyright
+;;; notice, this list of conditions and the following disclaimer.
+
+;;; * 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 BY THE AUTHORS 'AS IS' AND ANY EXPRESSED
+;;; 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 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.
+
+(in-package :cl-fad)
+
+(defun component-present-p (value)
+ "Helper function for DIRECTORY-PATHNAME-P which checks whether VALUE
+ is neither NIL nor the keyword :UNSPECIFIC."
+ (and value (not (eql value :unspecific))))
+
+(defun directory-pathname-p (pathspec)
+ "Returns NIL if PATHSPEC \(a pathname designator) does not designate
+a directory, PATHSPEC otherwise. It is irrelevant whether file or
+directory designated by PATHSPEC does actually exist."
+ (and
+ (not (component-present-p (pathname-name pathspec)))
+ (not (component-present-p (pathname-type pathspec)))
+ pathspec))
+
+(defun pathname-as-directory (pathspec)
+ "Converts the non-wild pathname designator PATHSPEC to directory
+form."
+ (let ((pathname (pathname pathspec)))
+ (when (wild-pathname-p pathname)
+ (error "Can't reliably convert wild pathnames."))
+ (cond ((not (directory-pathname-p pathspec))
+ (make-pathname :directory (append (or (pathname-directory pathname)
+ (list :relative))
+ (list (file-namestring pathname)))
+ :name nil
+ :type nil
+ :defaults pathname))
+ (t pathname))))
+
+(defun directory-wildcard (dirname)
+ "Returns a wild pathname designator that designates all files within
+the directory named by the non-wild pathname designator DIRNAME."
+ (when (wild-pathname-p dirname)
+ (error "Can only make wildcard directories from non-wildcard directories."))
+ (make-pathname :name #-:cormanlisp :wild #+:cormanlisp "*"
+ :type #-(or :clisp :cormanlisp) :wild
+ #+:clisp nil
+ #+:cormanlisp "*"
+ :defaults (pathname-as-directory dirname)))
+
+#+:clisp
+(defun clisp-subdirectories-wildcard (wildcard)
+ "Creates a wild pathname specifically for CLISP such that
+sub-directories are returned by DIRECTORY."
+ (make-pathname :directory (append (pathname-directory wildcard)
+ (list :wild))
+ :name nil
+ :type nil
+ :defaults wildcard))
+
+(defun list-directory (dirname &key (follow-symlinks t))
+ "Returns a fresh list of pathnames corresponding to all files within
+ the directory named by the non-wild pathname designator DIRNAME.
+ The pathnames of sub-directories are returned in directory form -
+ see PATHNAME-AS-DIRECTORY.
+
+ If FOLLOW-SYMLINKS is true, then the returned list contains
+truenames (symlinks will be resolved) which essentially means that it
+might also return files from *outside* the directory. This works on
+all platforms.
+
+ When FOLLOW-SYMLINKS is NIL, it should return the actual directory
+contents, which might include symlinks. Currently this works on SBCL
+and CCL."
+ (declare (ignorable follow-symlinks))
+ (when (wild-pathname-p dirname)
+ (error "Can only list concrete directory names."))
+ #+:ecl
+ (let ((dir (pathname-as-directory dirname)))
+ (concatenate 'list
+ (directory (merge-pathnames (pathname "*/") dir))
+ (directory (merge-pathnames (pathname "*.*") dir))))
+ #-:ecl
+ (let ((wildcard (directory-wildcard dirname)))
+ #+:abcl (system::list-directory dirname)
+ #+:sbcl (directory wildcard :resolve-symlinks follow-symlinks)
+ #+(or :cmu :scl :lispworks) (directory wildcard)
+ #+(or :openmcl :digitool) (directory wildcard :directories t :follow-links follow-symlinks)
+ #+:allegro (directory wildcard :directories-are-files nil)
+ #+:clisp (nconc (directory wildcard :if-does-not-exist :keep)
+ (directory (clisp-subdirectories-wildcard wildcard)))
+ #+:cormanlisp (nconc (directory wildcard)
+ (cl::directory-subdirs dirname)))
+ #-(or :sbcl :cmu :scl :lispworks :openmcl :allegro :clisp :cormanlisp :ecl :abcl :digitool)
+ (error "LIST-DIRECTORY not implemented"))
+
+(defun pathname-as-file (pathspec)
+ "Converts the non-wild pathname designator PATHSPEC to file form."
+ (let ((pathname (pathname pathspec)))
+ (when (wild-pathname-p pathname)
+ (error "Can't reliably convert wild pathnames."))
+ (cond ((directory-pathname-p pathspec)
+ (let* ((directory (pathname-directory pathname))
+ (name-and-type (pathname (first (last directory)))))
+ (make-pathname :directory (butlast directory)
+ :name (pathname-name name-and-type)
+ :type (pathname-type name-and-type)
+ :defaults pathname)))
+ (t pathname))))
+
+(defun file-exists-p (pathspec)
+ "Checks whether the file named by the pathname designator PATHSPEC
+exists and returns its truename if this is the case, NIL otherwise.
+The truename is returned in `canonical' form, i.e. the truename of a
+directory is returned as if by PATHNAME-AS-DIRECTORY."
+ #+(or :sbcl :lispworks :openmcl :ecl :digitool) (probe-file pathspec)
+ #+:allegro (or (excl:probe-directory (pathname-as-directory pathspec))
+ (probe-file pathspec))
+ #+(or :cmu :scl :abcl) (or (probe-file (pathname-as-directory pathspec))
+ (probe-file pathspec))
+ #+:cormanlisp (or (and (ccl:directory-p pathspec)
+ (pathname-as-directory pathspec))
+ (probe-file pathspec))
+ #+:clisp (or (ignore-errors
+ (let ((directory-form (pathname-as-directory pathspec)))
+ (when (ext:probe-directory directory-form)
+ directory-form)))
+ (ignore-errors
+ (probe-file (pathname-as-file pathspec))))
+ #-(or :sbcl :cmu :scl :lispworks :openmcl :allegro :clisp :cormanlisp :ecl :abcl :digitool)
+ (error "FILE-EXISTS-P not implemented"))
+
+(defun directory-exists-p (pathspec)
+ "Checks whether the file named by the pathname designator PATHSPEC
+exists and if it is a directory. Returns its truename if this is the
+case, NIL otherwise. The truename is returned in directory form as if
+by PATHNAME-AS-DIRECTORY."
+ #+:allegro
+ (and (excl:probe-directory pathspec)
+ (pathname-as-directory (truename pathspec)))
+ #+:lispworks
+ (and (lw:file-directory-p pathspec)
+ (pathname-as-directory (truename pathspec)))
+ #-(or :allegro :lispworks)
+ (let ((result (file-exists-p pathspec)))
+ (and result
+ (directory-pathname-p result)
+ result)))
+
+(defun walk-directory (dirname fn &key directories
+ (if-does-not-exist :error)
+ (test (constantly t))
+ (follow-symlinks t))
+ "Recursively applies the function FN to all files within the
+directory named by the non-wild pathname designator DIRNAME and all of
+its sub-directories. FN will only be applied to files for which the
+function TEST returns a true value. If DIRECTORIES is not NIL, FN and
+TEST are applied to directories as well. If DIRECTORIES
+is :DEPTH-FIRST, FN will be applied to the directory's contents first.
+If DIRECTORIES is :BREADTH-FIRST and TEST returns NIL, the directory's
+content will be skipped. IF-DOES-NOT-EXIST must be one of :ERROR
+or :IGNORE where :ERROR means that an error will be signaled if the
+directory DIRNAME does not exist. If FOLLOW-SYMLINKS is T, then your
+callback will receive truenames. Otherwise you should get the actual
+directory contents, which might include symlinks. This might not be
+supported on all platforms. See LIST-DIRECTORY."
+ (labels ((walk (name)
+ (cond
+ ((directory-pathname-p name)
+ ;; the code is written in a slightly awkward way for
+ ;; backward compatibility
+ (cond ((not directories)
+ (dolist (file (list-directory name :follow-symlinks follow-symlinks))
+ (walk file)))
+ ((eql directories :breadth-first)
+ (when (funcall test name)
+ (funcall fn name)
+ (dolist (file (list-directory name :follow-symlinks follow-symlinks))
+ (walk file))))
+ ;; :DEPTH-FIRST is implicit
+ (t (dolist (file (list-directory name :follow-symlinks follow-symlinks))
+ (walk file))
+ (when (funcall test name)
+ (funcall fn name)))))
+ ((funcall test name)
+ (funcall fn name)))))
+ (let ((pathname-as-directory (pathname-as-directory dirname)))
+ (case if-does-not-exist
+ ((:error)
+ (cond ((not (file-exists-p pathname-as-directory))
+ (error "File ~S does not exist."
+ pathname-as-directory))
+ (t (walk pathname-as-directory))))
+ ((:ignore)
+ (when (file-exists-p pathname-as-directory)
+ (walk pathname-as-directory)))
+ (otherwise
+ (error "IF-DOES-NOT-EXIST must be one of :ERROR or :IGNORE."))))
+ (values)))
+
+(defvar *stream-buffer-size* 8192)
+
+(defun copy-stream (from to &optional (checkp t))
+ "Copies into TO \(a stream) from FROM \(also a stream) until the end
+of FROM is reached, in blocks of *stream-buffer-size*. The streams
+should have the same element type. If CHECKP is true, the streams are
+checked for compatibility of their types."
+ (when checkp
+ (unless (subtypep (stream-element-type to) (stream-element-type from))
+ (error "Incompatible streams ~A and ~A." from to)))
+ (let ((buf (make-array *stream-buffer-size*
+ :element-type (stream-element-type from))))
+ (loop
+ (let ((pos #-:clisp (read-sequence buf from)
+ #+:clisp (ext:read-byte-sequence buf from :no-hang nil)))
+ (when (zerop pos) (return))
+ (write-sequence buf to :end pos))))
+ (values))
+
+(defun copy-file (from to &key overwrite)
+ "Copies the file designated by the non-wild pathname designator FROM
+to the file designated by the non-wild pathname designator TO. If
+OVERWRITE is true overwrites the file designtated by TO if it exists."
+ #+:allegro (excl.osi:copy-file from to :overwrite overwrite)
+ #-:allegro
+ (let ((element-type #-:cormanlisp '(unsigned-byte 8)
+ #+:cormanlisp 'unsigned-byte))
+ (with-open-file (in from :element-type element-type)
+ (with-open-file (out to :element-type element-type
+ :direction :output
+ :if-exists (if overwrite
+ :supersede
+ #-:cormanlisp :error
+ #+:cormanlisp nil))
+ #+:cormanlisp
+ (unless out
+ (error (make-condition 'file-error
+ :pathname to
+ :format-control "File already exists.")))
+ (copy-stream in out))))
+ (values))
+
+(defun delete-directory-and-files (dirname &key (if-does-not-exist :error))
+ "Recursively deletes all files and directories within the directory
+designated by the non-wild pathname designator DIRNAME including
+DIRNAME itself. IF-DOES-NOT-EXIST must be one of :ERROR or :IGNORE
+where :ERROR means that an error will be signaled if the directory
+DIRNAME does not exist.
+
+NOTE: this function is dangerous if the directory that you are
+removing contains symlinks to files outside of it - the target files
+might be removed instead! This is currently fixed for SBCL and CCL."
+
+ #+:allegro (excl.osi:delete-directory-and-files dirname
+ :if-does-not-exist if-does-not-exist)
+
+ #+:sbcl
+ (if (directory-exists-p dirname)
+ (sb-ext:delete-directory dirname :recursive t)
+ (ecase if-does-not-exist
+ (:error (error "~S is not a directory" dirname))
+ (:ignore nil)))
+
+ #+:ccl-has-delete-directory
+ (if (directory-exists-p dirname)
+ (ccl:delete-directory dirname)
+ (ecase if-does-not-exist
+ (:error (error "~S is not a directory" dirname))
+ (:ignore nil)))
+
+ #-(or :allegro :sbcl :ccl-has-delete-directory)
+ (walk-directory dirname
+ (lambda (file)
+ (cond ((directory-pathname-p file)
+ #+:lispworks (lw:delete-directory file)
+ #+:cmu (multiple-value-bind (ok err-number)
+ (unix:unix-rmdir (namestring (truename file)))
+ (unless ok
+ (error "Error number ~A when trying to delete ~A"
+ err-number file)))
+ #+:scl (multiple-value-bind (ok errno)
+ (unix:unix-rmdir (ext:unix-namestring (truename file)))
+ (unless ok
+ (error "~@<Error deleting ~S: ~A~@:>"
+ file (unix:get-unix-error-msg errno))))
+ #+:clisp (ext:delete-dir file)
+ #+:openmcl (cl-fad-ccl:delete-directory file)
+ #+:cormanlisp (win32:delete-directory file)
+ #+:ecl (si:rmdir file)
+ #+(or :abcl :digitool) (delete-file file))
+ (t (delete-file file))))
+ :follow-symlinks nil
+ :directories t
+ :if-does-not-exist if-does-not-exist)
+ (values))
+
+(defun pathname-directory-pathname (pathname)
+ "Returns a complete pathname representing the directory of
+PATHNAME. If PATHNAME is already a directory pathname (name NIL, type
+NIL) returns a pathname equal (as per pathname=) to it."
+ (make-pathname :defaults pathname
+ :name nil :type nil))
+
+(defun pathname-parent-directory (pathname)
+ "Returns a pathname which would, by name at least, contain PATHNAME
+as one of its direct children. Symlinks can make the parent/child
+relationship a like opaque, but generally speaking the value returned
+by this function is a directory name which contains PATHNAME.
+
+The root directory, #P\"/\", is its own parent. The parent directory
+of a filename is the parent of the filename's dirname."
+ (canonical-pathname
+ (make-pathname :defaults pathname
+ :directory (if (pathname-root-p pathname)
+ (list :absolute)
+ (append (or (pathname-directory pathname)
+ (list :relative))
+ (list :back))))))
+
+(defun canonical-pathname (pathname)
+ "Remove reduntant information from PATHNAME.
+
+This simply walks down PATHNAME's pathname-directory and drops \".\"
+directories, removes :back and its preceding element.
+
+NB: This function does not access the filesystem, it only looks at the
+values in the pathname and works on their known (or assumed)
+meanings.
+
+NB: Since this function does not access the filesystem it will only
+remove :BACK elements from the path (not :UP elements). Since some
+lisps, ccl/sbcl/clisp convert \"..\" in pathnames to :UP, and
+not :BACK, the actual utility of the function is limited."
+ (let ((pathname (pathname pathname))) ;; just make sure to get a pathname object
+ (loop
+ with full-dir = (or (pathname-directory pathname)
+ (list :relative))
+ with canon-dir = (if (member (first full-dir) '(:relative :absolute))
+ (list (pop full-dir))
+ (list :relative))
+ while full-dir
+ do (cond
+ ((string= "." (first full-dir))
+ (pop full-dir))
+ ((eql :back (second full-dir))
+ (pop full-dir)
+ (pop full-dir))
+ (t (push (pop full-dir) canon-dir)))
+ finally (return (make-pathname :defaults pathname :directory (nreverse canon-dir))))))
+
+(defun merge-pathnames-as-directory (&rest pathnames)
+ "Given a list of, probably relative, pathnames returns a single
+directory pathname containing the logical concatenation of them all.
+
+The returned value is the current directory if one were to cd into
+each of PATHNAMES in order. For this reason an absolute pathname will,
+effectively, cancel the affect of any previous relative pathnames.
+
+The returned value's defaults are taken from the first element of
+PATHNAMES (host, version and device).
+
+NB: Since this function only looks at directory names the name and
+type of the elements of PATHNAMES are ignored. Make sure to properly
+use either trailing #\\/s, or pathname-as-directory, to get the
+expected results.
+
+Examples:
+
+ (merge-pathnames-as-directory #P\"foo/\" #P\"bar/\") == #P\"foo/bar/\"
+ (merge-pathnames-as-directory #P\"foo/\" #P\"./bar/\") == #P\"foo/./bar/\"
+ (merge-pathnames-as-directory #P\"foo/\" #P\"/bar/\") == #P\"/bar/\"
+ (merge-pathnames-as-directory #P\"foo/\" #P\"/bar/\" #P'quux/file.txt) == #P\"/bar/quux/\"
+"
+ (when (null pathnames)
+ (return-from merge-pathnames-as-directory
+ (make-pathname :defaults *default-pathname-defaults* :directory nil :name nil :type nil)))
+ (let* ((pathnames (mapcar #'pathname pathnames)))
+ (loop
+ with defaults = (first pathnames)
+ with dir = (pathname-directory defaults)
+ for pathname in (rest pathnames)
+ for type = (first (pathname-directory pathname))
+ do (ecase type
+ ((nil) ;; this is equivalent to (:relative) == ".", so, for this function, just do nothing.
+ )
+ (:absolute
+ (setf dir (pathname-directory pathname)))
+ (:relative
+ (setf dir (append dir (rest (pathname-directory pathname))))))
+ finally (return (make-pathname :defaults defaults :directory dir :name nil :type nil)))))
+
+(defun merge-pathnames-as-file (&rest pathnames)
+ "Given a list of, probably relative, pathnames returns a single
+filename pathname containing the logical concatenation of them all.
+
+The returned value's defaults are taken from the first element of
+PATHNAMES (host, version and device). The returned values's name, type
+and version are taken from the last element of PATHNAMES. The
+intervening elements are used only for their pathname-directory
+values.
+
+Examples:
+
+ (merge-pathnames-as-file #P\"foo/\" #P\"bar.txt\") == #P\"foo/bar.txt\"
+ (merge-pathnames-as-file #P\"foo/\" #P\"./bar.txt\") == #P\"foo/./bar.txt\"
+ (merge-pathnames-as-file #P\"foo/\" #P\"/bar/README\") == #P\"/bar/README\"
+ (merge-pathnames-as-file #P\"/foo/\" #P\"/bar/\" #P'quux/file.txt) == #P\"/bar/quux/file.txt\"
+"
+ (case (length pathnames)
+ (0
+ (when (null pathnames)
+ (make-pathname :defaults *default-pathname-defaults*
+ :directory nil
+ :name nil
+ :type nil)))
+ (1
+ (pathname-as-file (first pathnames)))
+ (t
+ (let* ((defaults (pop pathnames))
+ (file-name-part (first (last pathnames)))
+ (file-name-directory (make-pathname :defaults file-name-part
+ :name nil :type nil))
+ (pathnames (butlast pathnames)))
+ (make-pathname :defaults (apply #'merge-pathnames-as-directory (append (list defaults) pathnames (list file-name-directory)))
+ :name (pathname-name file-name-part)
+ :type (pathname-type file-name-part)
+ :version (pathname-version file-name-part))))))
+
+(defmacro with-component-testers ((a b key) &body body)
+ (let ((k (gensym)))
+ `(let* ((,k ,key)
+ (,a (funcall ,k ,a))
+ (,b (funcall ,k ,b)))
+ (labels ((components-are (test)
+ (and (funcall test ,a) (funcall test ,b)))
+
+ (components-are-member (values)
+ (and (member ,a values :test #'eql)
+ (member ,b values :test #'eql)
+ (eql ,a ,b)))
+
+ (components-are-string= ()
+ (and (stringp ,a) (stringp ,b) (string= ,a ,b)))
+
+ (components-are-every (test)
+ (and (consp ,a)
+ (consp ,b)
+ (every test ,a ,b))))
+
+
+ (if (or ,@body)
+ (values t ,a ,b)
+ nil)))))
+
+(defun pathname-host-equal (a b)
+ (with-component-testers (a b #'pathname-host)
+ (eq a b)
+ (components-are-member '(nil :unspecific))
+ (components-are-string=)
+ (and (consp a)
+ (consp b)
+ (components-are-every #'string=))))
+
+(defun pathname-device-equal (a b)
+ (with-component-testers (a b #'pathname-device)
+ (components-are-member '(nil :unspecific))
+ (components-are-string=)))
+
+(defun pathname-directory-equal (a b)
+ (with-component-testers (a b #'pathname-directory)
+ (and (null a) (null b))
+ (and (= (length a) (length b))
+ (every (lambda (a b)
+ (or (and (stringp a) (stringp b) (string= a b))
+ (and (null a) (null b))
+ (and (keywordp a) (keywordp b) (eql a b))))
+ a b))))
+
+(defun pathname-name-equal (a b)
+ (with-component-testers (a b #'pathname-name)
+ (components-are-member '(nil :wild :unspecific))
+ (components-are-string=)))
+
+(defun pathname-type-equal (a b)
+ (with-component-testers (a b #'pathname-type)
+ (components-are-member '(nil :wild :unspecific))
+ (components-are-string=)))
+
+(defun pathname-version-equal (a b)
+ (with-component-testers (a b #'pathname-version)
+ (and (null a) (null b))
+ (components-are-member '(:wild :newest :unspecific))
+ (and (integerp a) (integerp b) (= a b))))
+
+(defun pathname-equal (a b)
+ "Returns T if A and B represent the same pathname. This function
+does not access the filesystem, it only looks at the components of the
+two pathnames to test if they are the same (though by
+passing both A and B to probe-file one can make this function test for file 'sameness'.
+
+Equality is defined as:
+
+ - strings that are string equal
+ - symbol (including nil) or keywords which are eql
+ - lists of the same length with equal (as per these rules) elements.
+
+if any of these tree conditions is false for any of the components in
+A and B then A and B are different, otherwise they are the same.
+
+NB: This function does not convert name strings to pathnames. So
+\"foo.txt\" and #P\"foo.txt\" are different pathnames."
+ (if (and a b)
+ (if (and (pathname-host-equal a b)
+ (pathname-device-equal a b)
+ (pathname-directory-equal a b)
+ (pathname-name-equal a b)
+ (pathname-type-equal a b)
+ (pathname-version-equal a b))
+ (values t a b)
+ (values nil))
+ (values nil)))
+
+(defun pathname-absolute-p (a)
+ "Returns true if A is an absolute pathname.
+
+This simply tests if A's directory list starts with :ABSOLUTE"
+ (eql :absolute (first (pathname-directory (pathname a)))))
+
+(defun pathname-relative-p (a)
+ "Returns true if A is a relative pathname.
+
+This simply tests if A's directory starts with :RELATIVE."
+ (let ((dir (pathname-directory (pathname a))))
+ (or (null dir) (eql :relative (first dir)))))
+
+(defun pathname-root-p (a)
+ (let ((dir (pathname-directory (pathname a))))
+ (and (eql :absolute (first dir))
+ (= 1 (length dir)))))
+
+(pushnew :cl-fad *features*)
+
+;; stuff for Nikodemus Siivola's HYPERDOC
+;; see <http://common-lisp.net/project/hyperdoc/>
+;; and <http://www.cliki.net/hyperdoc>
+;; also used by LW-ADD-ONS
+
+#-:abcl
+(defvar *hyperdoc-base-uri* "http://weitz.de/cl-fad/")
+
+#-:abcl
+(let ((exported-symbols-alist
+ (loop for symbol being the external-symbols of :cl-fad
+ collect (cons symbol
+ (concatenate 'string
+ "#"
+ (string-downcase symbol))))))
+ (defun hyperdoc-lookup (symbol type)
+ (declare (ignore type))
+ (cdr (assoc symbol
+ exported-symbols-alist
+ :test #'eq))))
--- /dev/null
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-FAD-TEST; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/cl-fad/test.lisp,v 1.12 2009/09/30 14:23:10 edi Exp $
+
+;;; Copyright (c) 2004-2010, Dr. Edmund Weitz. All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;; * Redistributions of source code must retain the above copyright
+;;; notice, this list of conditions and the following disclaimer.
+
+;;; * 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 BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; 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 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.
+
+(in-package #:cl-fad-test)
+
+(defparameter *tmp-dir*
+ #+(or :win32 :mswindows :windows) "c:\\tmp\\"
+ #-(or :win32 :mswindows :windows) "/tmp/")
+
+(defvar *test-counter* 0)
+
+(defmacro assert* (form)
+ `(progn
+ (format t "Trying to assert ~A~%" ',form)
+ (assert ,form)
+ (format t "Test ~A passed.~%" (incf *test-counter*))))
+
+(defun test ()
+ (setq *test-counter* 0)
+
+ (assert* (path:= (path:catdir) #P""))
+ (assert* (path:= (path:catdir #P"/") #P"/"))
+ (assert* (path:= (path:catdir #P"a/" #P"b/") #P"a/b/"))
+ (assert* (path:= (path:catdir #P"/a/" #P"/b/" #P"c/" #P"./d/" #P"e" #P"f/") #P"/b/c/./d/f/"))
+
+ (assert* (path:= (path:catfile) #P""))
+ (assert* (path:= (path:catfile #P"R.txt") #P"R.txt"))
+ (assert* (path:= (path:catfile #P"a/" #P"/b/" #P"R.txt") #P"/b/R.txt"))
+
+
+ (let ((fad-dir (merge-pathnames (pathname-as-directory "fad-test")
+ *tmp-dir*)))
+ (delete-directory-and-files fad-dir :if-does-not-exist :ignore)
+ (assert* (directory-pathname-p fad-dir))
+ (assert* (directory-pathname-p (pathname *tmp-dir*)))
+ (let ((foo-file (merge-pathnames "foo.lisp"
+ fad-dir)))
+ (assert* (not (directory-pathname-p foo-file)))
+ (assert* (not (file-exists-p foo-file)))
+ (assert* (not (file-exists-p fad-dir)))
+ (with-open-file (out (ensure-directories-exist foo-file)
+ :direction :output
+ :if-does-not-exist :create)
+ (write-string "NIL" out))
+ (assert* (file-exists-p foo-file))
+ (assert* (not (directory-exists-p foo-file)))
+ (assert* (file-exists-p fad-dir))
+ (assert* (directory-exists-p fad-dir))
+ (assert* (equal fad-dir
+ (pathname-as-directory fad-dir)))
+ (assert* (equal foo-file
+ (pathname-as-file foo-file)))
+ (assert* (not (equal fad-dir
+ (pathname-as-file fad-dir))))
+ (assert* (not (equal foo-file
+ (pathname-as-directory foo-file))))
+ (dolist (name '("bar" "baz"))
+ (let ((dir (merge-pathnames (pathname-as-directory name)
+ fad-dir)))
+ (dolist (name '("foo.text" "bar.lisp"))
+ (let ((file (merge-pathnames name dir)))
+ (with-open-file (out (ensure-directories-exist file)
+ :direction :output
+ :if-does-not-exist :create)
+ (write-string "NIL" out))))))
+ ;; /tmp/fad-test/foo.lisp
+ ;; /tmp/fad-test/bar/bar.lisp
+ ;; /tmp/fad-test/bar/foo.text
+ ;; /tmp/fad-test/baz/bar.lisp
+ ;; /tmp/fad-test/baz/foo.text
+ ;; files : 5
+ ;; dirs : 3
+ (let ((file-counter 0)
+ (file-and-dir-counter 0)
+ (bar-counter 0))
+ (walk-directory fad-dir
+ (lambda (file)
+ (declare (ignore file))
+ (incf file-counter)))
+ ;; file-counter => 5
+ (walk-directory fad-dir
+ (lambda (file)
+ (declare (ignore file))
+ (incf file-and-dir-counter))
+ :directories t)
+ ;; file-and-dir-counter => 5 + 3
+ (walk-directory fad-dir
+ (lambda (file)
+ (declare (ignore file))
+ (incf bar-counter))
+ :test (lambda (file)
+ (string= (pathname-name file)
+ "bar"))
+ :directories t)
+ ;; do not traverse the baz directory
+ (walk-directory fad-dir
+ (lambda (file)
+ (declare (ignore file))
+ (incf file-and-dir-counter))
+ :test (lambda (file)
+ (not (and (directory-pathname-p file)
+ (string= (first (last (pathname-directory file)))
+ "baz"))))
+ :directories :breadth-first)
+ ;; file-and-dir-counter => 5 + 3 + 2 dirs + 3 files
+ (assert* (= 5 file-counter))
+ (assert* (= 13 file-and-dir-counter))
+ (assert* (= 2 bar-counter)))
+ (let ((bar-file (merge-pathnames "bar.lisp" fad-dir)))
+ (copy-file foo-file bar-file)
+ (assert* (file-exists-p bar-file))
+ (with-open-file (foo-stream foo-file :element-type '(unsigned-byte 8))
+ (with-open-file (bar-stream bar-file :element-type '(unsigned-byte 8))
+ (assert* (= (file-length foo-stream)
+ (file-length bar-stream)))
+ (loop for foo-byte = (read-byte foo-stream nil nil)
+ for bar-byte = (read-byte bar-stream nil nil)
+ while (and foo-byte bar-byte)
+ do (assert* (eql foo-byte bar-byte))))))
+ (let ((baz-dir (merge-pathnames (pathname-as-directory "baz")
+ fad-dir))
+ (list (mapcar #'namestring (list-directory fad-dir))))
+ (assert* (find (namestring (truename foo-file)) list :test #'string=))
+ (assert* (find (namestring (truename baz-dir)) list :test #'string=))
+ (assert* (not (find (namestring (pathname-as-file baz-dir))
+ list
+ :test #'string=)))))
+ (delete-directory-and-files fad-dir :if-does-not-exist :error)
+ (assert* (not (file-exists-p fad-dir)))
+ (assert* (not (directory-exists-p fad-dir))))
+ (format t "All tests passed.~%"))
--- /dev/null
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/cl-fad/load.lisp,v 1.9 2009/09/30 14:23:10 edi Exp $
+
+;;; Copyright (c) 2004-2010, Dr. Edmund Weitz. All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;; * Redistributions of source code must retain the above copyright
+;;; notice, this list of conditions and the following disclaimer.
+
+;;; * 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 BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; 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 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.
+
+(in-package :cl-user)
+
+(defparameter *cl-fad-base-directory*
+ (make-pathname :name nil :type nil :version nil
+ :defaults (parse-namestring *load-truename*)))
+
+#+:allegro (require :osi)
+#+:sbcl (require :sb-executable)
+#+:sbcl (require :sb-posix)
+
+(let ((cl-fad-base-directory
+ (make-pathname :name nil :type nil :version nil
+ :defaults (parse-namestring *load-truename*))))
+ (let (must-compile)
+ #+:cormanlisp (declare (ignore must-compile))
+ (dolist (file '("packages"
+ #+:cormanlisp "corman"
+ #+:openmcl "openmcl"
+ "fad"))
+ (let ((pathname (make-pathname :name file :type "lisp" :version nil
+ :defaults cl-fad-base-directory)))
+ ;; don't use COMPILE-FILE in Corman Lisp, it's broken - LOAD
+ ;; will yield compiled functions anyway
+ #-:cormanlisp
+ (let ((compiled-pathname (compile-file-pathname pathname)))
+ (unless (and (not must-compile)
+ (probe-file compiled-pathname)
+ (< (file-write-date pathname)
+ (file-write-date compiled-pathname)))
+ (setq must-compile t)
+ (compile-file pathname))
+ (setq pathname compiled-pathname))
+ (load pathname)))))
--- /dev/null
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CCL; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/cl-fad/openmcl.lisp,v 1.6 2009/09/30 14:23:10 edi Exp $
+
+;;; Copyright (c) 2004-2010, Dr. Edmund Weitz. All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;; * Redistributions of source code must retain the above copyright
+;;; notice, this list of conditions and the following disclaimer.
+
+;;; * 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 BY THE AUTHORS 'AS IS' AND ANY EXPRESSED
+;;; 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 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.
+
+(in-package :cl-fad)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (flet ((ccl-function-feature (symbol-name feature)
+ (let ((symbol (find-symbol symbol-name :ccl)))
+ (when (and symbol (fboundp symbol))
+ (pushnew feature *features*)))))
+ (ccl-function-feature "%RMDIR" :ccl-has-%rmdir)
+ (ccl-function-feature "DELETE-DIRECTORY" :ccl-has-delete-directory)))
+
+(defpackage :cl-fad-ccl
+ (:use :cl)
+ (:export delete-directory)
+ (:import-from :ccl
+ :%realpath
+ :signal-file-error
+ :native-translated-namestring
+ :with-cstrs)
+ #+ccl-has-%rmdir
+ (:import-from :ccl :%rmdir)
+ #+ccl-has-delete-directory
+ (:import-from :ccl :delete-directory))
+
+(in-package :cl-fad-ccl)
+
+#-ccl-has-%rmdir
+(defun %rmdir (name)
+ (with-cstrs ((n name))
+ (#_rmdir n)))
+
+;;; ClozureCL 1.6 introduced ccl:delete-directory with semantics that
+;;; are acceptably similar to this "legacy" definition.
+;;;
+;;; Except this legacy definition is not recursive, hence this function is
+;;; used only if there is no :CCL-HAS-DELETE-DIRECTORY feature.
+
+#-ccl-has-delete-directory
+(defun delete-directory (path)
+ (let* ((namestring (native-translated-namestring path)))
+ (when (%realpath namestring)
+ (let* ((err (%rmdir namestring)))
+ (or (eql 0 err) (signal-file-error err path))))))
+
--- /dev/null
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/cl-fad/packages.lisp,v 1.12 2009/09/30 14:23:10 edi Exp $
+
+;;; Copyright (c) 2004-2010, Dr. Edmund Weitz. All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;; * Redistributions of source code must retain the above copyright
+;;; notice, this list of conditions and the following disclaimer.
+
+;;; * 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 BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; 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 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.
+
+(in-package #:cl-user)
+
+(defpackage :cl-fad
+ (:nicknames :fad)
+ (:use :cl)
+ #+:allegro
+ (:shadow :copy-file
+ :delete-directory-and-files)
+ #+:abcl
+ (:shadow :list-directory)
+ (:export :copy-file
+ :copy-stream
+ :delete-directory-and-files
+ :directory-exists-p
+ :directory-pathname-p
+ :file-exists-p
+ :list-directory
+ :pathname-as-directory
+ :pathname-as-file
+ :pathname-directory-pathname
+ :pathname-equal
+ :pathname-parent-directory
+ :pathname-absolute-p
+ :pathname-relative-p
+ :pathname-root-p
+
+ :canonical-pathname
+ :merge-pathnames-as-directory
+ :merge-pathnames-as-file
+
+ :walk-directory
+
+ :open-temporary
+ :with-output-to-temporary-file
+ :with-open-temporary-file
+ :*default-template*
+ :invalid-temporary-pathname-template
+ :cannot-create-temporary-file
+ #+win32 #:missing-temp-environment-variable))
+
+(defpackage :path
+ (:use)
+ (:documentation "Rexporting certain functions from the cl-fad package with shorter names.
+
+This package provides no functionality, it serves only to make file
+system intensive code easier to read (for unix people at least).")
+ (:export #:dirname
+ #:basename
+ #:-e
+ #:-d
+ #:catfile
+ #:catdir
+ #:rm-r
+ #:=
+
+ #:absolute-p
+ #:relative-p
+ #:root-p))
--- /dev/null
+(in-package :common-lisp-user)
+
+(defpackage :cl-fad-test
+ (:use :cl :cl-fad :unit-test)
+ (:export :test))
--- /dev/null
+(in-package :cl-fad)
+
+(defmacro defalias (name args realname)
+ `(progn
+ (defun ,name ,args
+ ,(if (eql '&rest (first args))
+ `(apply #',realname ,(second args))
+ `(,realname ,@args)))
+ (define-compiler-macro ,name (&rest args)
+ (list* ',realname args))))
+
+(defalias path:dirname (pathname) cl-fad:pathname-directory-pathname)
+
+(defun path:basename (pathname) (pathname (file-namestring pathname)))
+
+(defalias path:-e (pathname) cl-fad:file-exists-p)
+
+(defalias path:-d (directory) cl-fad:directory-exists-p)
+
+(defalias path:catfile (&rest pathnames) cl-fad:merge-pathnames-as-file)
+
+(defalias path:catdir (&rest pathnames) cl-fad:merge-pathnames-as-directory)
+
+(defalias path:= (a b) cl-fad:pathname-equal)
+
+(defalias path:absolute-p (pathname) cl-fad:pathname-absolute-p)
+
+(defalias path:relative-p (pathname) cl-fad:pathname-relative-p)
+
+(defalias path:root-p (pathname) cl-fad:pathname-root-p)
+
+(defalias path:rm-r (pathname) cl-fad:delete-directory-and-files)
--- /dev/null
+(in-package :cl-fad)
+
+(defparameter *default-template* "TEMPORARY-FILES:TEMP-%")
+
+(defparameter *max-tries* 10000)
+
+(defvar *name-random-state* (make-random-state t))
+
+;; from XCVB
+(eval-when (:load-toplevel :execute)
+ (defun getenv (x)
+ "Query the libc runtime environment. See getenv(3)."
+ (declare (ignorable x))
+ #+(or abcl clisp xcl) (ext:getenv x)
+ #+allegro (sys:getenv x)
+ #+clozure (ccl:getenv x)
+ #+(or cmu scl) (cdr (assoc x ext:*environment-list* :test #'string=))
+ #+cormanlisp
+ (let* ((buffer (ct:malloc 1))
+ (cname (ct:lisp-string-to-c-string x))
+ (needed-size (win:getenvironmentvariable cname buffer 0))
+ (buffer1 (ct:malloc (1+ needed-size))))
+ (prog1 (if (zerop (win:getenvironmentvariable cname buffer1 needed-size))
+ nil
+ (ct:c-string-to-lisp-string buffer1))
+ (ct:free buffer)
+ (ct:free buffer1)))
+ #+ecl (si:getenv x)
+ #+gcl (system:getenv x)
+ #+lispworks (lispworks:environment-variable x)
+ #+mcl (ccl:with-cstrs ((name x))
+ (let ((value (_getenv name)))
+ (unless (ccl:%null-ptr-p value)
+ (ccl:%get-cstring value))))
+ #+sbcl (sb-ext:posix-getenv x)
+ #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl lispworks mcl sbcl scl xcl)
+ (error "~S is not supported on your implementation" 'getenv))
+
+ (defun directory-from-environment (environment-variable-name)
+ (let ((string (getenv environment-variable-name)))
+ (when (plusp (length string))
+ (pathname-as-directory string))))
+
+ #+win32
+ (define-condition missing-temp-environment-variable (error)
+ ()
+ (:report (lambda (condition stream)
+ (declare (ignore condition))
+ (format stream "the TEMP environment variable has not been found, cannot continue"))))
+
+ #+win32
+ (defun get-default-temporary-directory ()
+ (or (directory-from-environment "TEMP")
+ (error 'missing-temp-environment-variable)))
+
+ #-win32
+ (defun get-default-temporary-directory ()
+ (or (directory-from-environment "TMPDIR")
+ #-clisp
+ (probe-file #P"/tmp/")
+ #+clisp
+ (and (ext:probe-directory #P"/tmp/")
+ #P"/tmp/")))
+
+ (handler-case
+ (logical-pathname-translations "TEMPORARY-FILES")
+ (error ()
+ (alexandria:if-let (default-temporary-directory (get-default-temporary-directory))
+ (setf (logical-pathname-translations "TEMPORARY-FILES") `(("*.*.*" ,default-temporary-directory)))
+ (warn "could not automatically determine a default mapping for TEMPORARY-FILES")))))
+
+;; locking for multi-threaded operation with unsafe random function
+
+(defvar *create-file-name-lock* (bordeaux-threads:make-lock "Temporary File Name Creation Lock"))
+
+(defmacro with-file-name-lock-held (() &body body)
+ `(bordeaux-threads:with-lock-held (*create-file-name-lock*)
+ ,@body))
+
+(defun generate-random-string ()
+ (with-file-name-lock-held ()
+ (format nil "~:@(~36,8,'0R~)" (random (expt 36 8) *name-random-state*))))
+
+(define-condition invalid-temporary-pathname-template (error)
+ ((string :initarg :string))
+ (:report (lambda (condition stream)
+ (with-slots (string) condition
+ (format stream "invalid temporary file name template ~S, must contain a percent sign that is to be replaced by a random string" string)))))
+
+(defun generate-random-pathname (template random-string-generator)
+ (let ((percent-position (or (position #\% template)
+ (error 'invalid-temporary-pathname-template :string template))))
+ (merge-pathnames (concatenate 'string
+ (subseq template 0 percent-position)
+ (funcall random-string-generator)
+ (subseq template (1+ percent-position))))))
+
+(define-condition cannot-create-temporary-file (error)
+ ((template :initarg :template)
+ (max-tries :initarg :max-tries))
+ (:report (lambda (condition stream)
+ (with-slots (template max-tries) condition
+ (format stream "cannot create temporary file with template ~A, giving up after ~D attempt~:P"
+ template max-tries)))))
+
+(defun open-temporary (&rest open-arguments
+ &key
+ (template *default-template*)
+ (generate-random-string 'generate-random-string)
+ (max-tries *max-tries*)
+ (direction :output)
+ &allow-other-keys)
+ "Create a file with a randomly generated name and return the opened
+ stream. The resulting pathname is generated from TEMPLATE, which
+ is a string representing a pathname template. A percent sign (%)
+ in that string is replaced by a randomly generated string to make
+ the filename unique. The default for TEMPLATE places temporary
+ files in the TEMPORARY-FILES logical pathname host, which is
+ automatically set up in a system specific manner. The file name
+ generated from TEMPLATE is merged with *DEFAULT-PATHNAME-DEFAULTS*,
+ so random pathnames relative to that directory can be generated by
+ not specifying a directory in TEMPLATE.
+
+ GENERATE-RANDOM-STRING can be passed to override the default
+ function that generates the random name component. It should
+ return a random string consisting of characters that are permitted
+ in a pathname (logical or physical, depending on TEMPLATE).
+
+ The name of the temporary file can be accessed calling the PATHNAME
+ function on STREAM. For convenience, the temporary file is opened
+ on the physical pathname, i.e. if the TEMPLATE designate a logical
+ pathname the translation to a physical pathname is performed before
+ opening the stream.
+
+ In order to create a unique file name, OPEN-TEMPORARY may loop
+ internally up to MAX-TRIES times before giving up and signalling a
+ CANNOT-CREATE-TEMPORARY-FILE condition."
+ (loop thereis (apply #'open
+ (translate-logical-pathname (generate-random-pathname template generate-random-string))
+ :direction direction
+ :if-exists nil
+ (alexandria:remove-from-plist open-arguments :template :generate-random-string :max-tries))
+ repeat max-tries
+ finally (error 'cannot-create-temporary-file
+ :template template
+ :max-tries max-tries)))
+
+(defmacro with-output-to-temporary-file ((stream &rest args) &body body)
+ "Create a temporary file using OPEN-TEMPORARY with ARGS and run BODY
+ with STREAM bound to the temporary file stream. Returns the
+ pathname of the file that has been created. See OPEN-TEMPORARY for
+ permitted options."
+ `(with-open-stream (,stream (open-temporary ,@args))
+ ,@body
+ (pathname ,stream)))
+
+(defmacro with-open-temporary-file ((stream &rest args &key keep &allow-other-keys) &body body)
+ "Create a temporary file using OPEN-TEMPORARY with ARGS and run BODY
+ with STREAM bound to the temporary file stream. Returns the values
+ returned by BODY. By default, the file is deleted when BODY is
+ exited. If a true value is passed in KEEP, the file is not deleted
+ when the body is exited. See OPEN-TEMPORARY for more permitted
+ options."
+ `(with-open-stream (,stream (open-temporary ,@(alexandria:remove-from-plist args :keep)))
+ #+sbcl
+ (declare (sb-ext:muffle-conditions sb-ext:code-deletion-note))
+ ,(if (and (constantp keep)
+ keep)
+ `(progn ,@body)
+ `(unwind-protect
+ (progn ,@body)
+ (unless ,keep
+ (close ,stream)
+ (delete-file (pathname ,stream)))))))
--- /dev/null
+(in-package :cl-fad-test)
+
+(deftest 'temporary-file 'with-output-to-temporary-file ()
+ (let ((pathname (with-output-to-temporary-file (f)
+ (write-string "hello" f))))
+ (test-assert (probe-file pathname))
+ (test-equal (alexandria:read-file-into-string pathname) "hello")
+ (delete-file pathname)))
+
+(deftest 'temporary-file 'with-open-temporary-file-keep ()
+
+ (let ((pathname (with-open-temporary-file (f :keep nil)
+ (pathname f))))
+ (test-assert (null (probe-file pathname))))
+ (let ((pathname (with-open-temporary-file (f :keep t)
+ (pathname f))))
+ (test-assert (probe-file pathname))
+ (delete-file pathname))
+
+ (let* ((keep nil)
+ (pathname (with-open-temporary-file (f :keep keep)
+ (pathname f))))
+ (test-assert (null (probe-file pathname))))
+ (let* ((keep t)
+ (pathname (with-open-temporary-file (f :keep keep)
+ (pathname f))))
+ (test-assert (probe-file pathname))
+ (delete-file pathname)))
+
+(deftest 'temporary-file 'template-tests ()
+ ;; error is signalled when template does not contain a percent sign.
+ (let ((*default-template* "foo"))
+ (test-condition (with-open-temporary-file (f :keep nil))
+ 'invalid-temporary-pathname-template))
+ ;; file name template occurs in generated file name (for logical path name)
+ (let* ((*default-template* "temporary-files:bla%.txt")
+ (pathname (with-open-temporary-file (f :keep nil)
+ (pathname f))))
+ (test-assert (cl-ppcre:scan "(?i)bla.*\\.txt$" (namestring pathname))))
+ ;; file name template occurs in generated file name (for pysical path name)
+ (let* ((*default-template* (concatenate 'string
+ (namestring (translate-logical-pathname "temporary-files:"))
+ "bla%.txt"))
+ (pathname (with-open-temporary-file (f :keep nil)
+ (pathname f))))
+ (test-assert (cl-ppcre:scan "(?i)bla.*\\.txt$" (namestring pathname)))))
+
+
+
--- /dev/null
+*.fasl
+*~
+.#*
+*#
--- /dev/null
+Version 0.0.3
+2009-05-18
+Updated to use add-hook and run-hooks functions defined in the my-util package
+Fixed the content-type function to make it work with Ubuntu 9.04
+
+Version 0.0.2
+2009-04-06
+Updated to use my-util package
+
+Version 0.0.1
+2009-03-23
+Initial public release
--- /dev/null
+History
+====================
+This HTTP Server used to be a part of web4r, a common lisp web application
+framework. I haven't done much tests on it after dividing it from web4r system.
+(All the written unit tests passed though.)
+
+Library dependencies
+====================
+my-util - http://github.com/tomoyuki28jp/my-util/tree/master
+usocket - http://common-lisp.net/project/usocket/
+bordeaux-threads - http://common-lisp.net/project/bordeaux-threads/
+cl-fad - http://www.weitz.de/cl-fad/
+trivial-shell - http://common-lisp.net/project/trivial-shell/
+flexi-streams - http://www.weitz.de/flexi-streams/
+rfc2388-binary - http://common-lisp.net/project/ucw/repos/rfc2388-binary/
--- /dev/null
+(in-package :cl-user)
+
+(defpackage :cl-http-server-tests-asd (:use :cl :asdf))
+
+(in-package :cl-http-server-tests-asd)
+
+(defsystem :cl-http-server-tests
+ :name "cl-http-server-tests"
+ :author "Tomoyuki Matsumoto <tomoyuki28jp@gmail.com>"
+ :licence "BSD"
+ :description "tests for cl-http-server"
+ :depends-on (:cl-http-server :my-util :fiveam :drakma)
+ :components ((:module "tests"
+ :serial t
+ :components ((:file "package")
+ (:file "specials")
+ (:file "util")
+ (:file "server")))))
--- /dev/null
+(in-package :cl-user)
+
+(defpackage :cl-http-server-asd (:use :cl :asdf))
+
+(in-package :cl-http-server-asd)
+
+(defsystem :cl-http-server
+ :version "0.0.3"
+ :name "cl-http-server"
+ :author "Tomoyuki Matsumoto <tomoyuki28jp@gmail.com>"
+ :licence "BSD"
+ :description "Common Lisp HTTP Server"
+ :depends-on (:my-util :usocket :bordeaux-threads :cl-fad
+ :trivial-shell :flexi-streams :rfc2388-binary)
+ :components ((:module "src"
+ :serial t
+ :components
+ ((:file "package")
+ (:file "specials")
+ (:file "util")
+ (:file "server")))))
--- /dev/null
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (asdf:oos 'asdf:load-op :cl-http-server))
+
+(in-package :cl-user)
+(defpackage :cl-http-server-test (:use :cl :cl-http-server))
+(in-package :cl-http-server-test)
+
+; http://localhost:8080/test
+(defpage test ()
+ (html :title "Test page title"
+ :body "Hello, world!"))
+
+; http://localhost:8080/get?get1=hello&get2=world
+(defpage get (:get get1 get2)
+ (html :body (concatenate 'string "get1: " get1 " get2: " get2)))
+
+(defparameter *srv* (start-server))
+;(stop-server *srv*)
--- /dev/null
+(in-package :cl-user)
+
+(defpackage :cl-http-server
+ (:use :cl :my-util :usocket :cl-fad :flexi-streams)
+ (:export :html
+ :*server*
+ :*request*
+ :*response*
+ :*http-stream*
+ :*http-char-stream*
+ :*http-binary-stream*
+ :*sid*p
+ :get-route
+ :add-route
+ :rem-route
+ :destroy-session
+ :route-static
+ :route-regex
+ :make-server
+ :validate-server
+ :start-server
+ :stop-server
+ :server-is-running-p
+ :access-log
+ :error-log
+ :debug-log
+ :get-cookies
+ :get-cookie
+ :set-cookie
+ :get-cookie-sid
+ :get-session
+ :rem-session
+ :set-session
+ :session-file
+ :session-name
+ :generate-sid
+ :valid-sid-p
+ :add-header
+ :status-page
+ :add-hook
+ :get-page
+ :set-page
+ :serve-file
+ :public-file-p
+ :image-type
+ :host-uri
+ :page-uri
+ :page-lambda
+ :defpage
+ :default-page
+ :page
+ :uri-path
+ :get-params
+ :get-param
+ :post-params
+ :post-param
+ :header-fields
+ :header-field
+ :redirect
+ :exit
+ :public-dir
+ :req-uri
+ :get-file-data
+ :file-name
+ :file-type
+ :file-tmp-name
+ :file-size
+ :file-save-name
+ ))
+
+;(asdf-version<= :my-util "0.0.4")
--- /dev/null
+(in-package :cl-http-server)
+
+; --- URI rewrite rule ------------------------------------------
+
+; Sample rewrite rule (You can also use add-route function):
+;(defun sample-rewrite-rule (uri)
+; (when (aand (scan-to-strings "(\.ico|\.gif|\.jpeg|\.jpg|\.png|)$" uri)
+; (not (string= it "")))
+; "/test.html"))
+
+(defun rewrote-uri ()
+ (let ((script (request-script-name *request*)))
+ (awhen (server-rewrite-rule *server*)
+ (aif (funcall it (request-uri *request*))
+ (return-from rewrote-uri it)))
+ script))
+
+; --- Route -----------------------------------------------------
+
+(defstruct route
+ (static (make-hash-table :test 'equal) :type hash-table)
+ (regex (make-hash-table :test 'equal) :type hash-table))
+
+(defun get-route (server type)
+ (case type
+ (:static (route-static (server-route server)))
+ (:regex (route-regex (server-route server)))
+ (otherwise (error "invalid route type: ~A" type))))
+
+(defun add-route (server type route dispatcher)
+ (unless (or (functionp dispatcher) (fboundp dispatcher))
+ (error "invalid dispatcher function"))
+ (setf (gethash route (get-route server type)) dispatcher))
+
+(defun rem-route (server type route)
+ (remhash route (get-route server type)))
+
+(defun matched-route (uri)
+ (aif (gethash uri (get-route *server* :static))
+ it
+ (maphash #'(lambda (regex dispatcher)
+ (when (scan-to-strings regex uri)
+ (return-from matched-route dispatcher)))
+ (get-route *server* :regex))))
+
+; --- Server ----------------------------------------------------
+
+(defstruct server
+ (host "127.0.0.1" :type string)
+ (port 8080 :type integer)
+ (reuse-address t :type boolean)
+ (backlog 5 :type integer)
+ (public-dir "/tmp/cl-srv/public/" :type string)
+ (rewrite-rule nil :type symbol)
+ (route (make-route) :type route)
+ (session-save-dir "/tmp/cl-srv/session/" :type string)
+ (log-save-dir "/tmp/cl-srv/log/" :type string)
+ (upload-tmp-dir "/tmp/cl-srv/tmp/" :type string)
+ (session-gc-lifetime 1440 :type integer)
+ (session-gc-probability 100 :type integer)
+ (session-name "sid" :type string)
+ (session-cookie-path "/" :type string)
+ (timeout-sec 30 :type integer)
+ (thread))
+
+(defmacro ensure-directories (&rest dirs)
+ "ensure directories end with a slash and exist"
+ `(progn
+ ,@(loop for d in dirs
+ collect `(unless (string= (subseq ,d (1- (length ,d))) "/")
+ (setf ,d (concat ,d "/")))
+ collect `(ensure-directories-exist ,d :verbose nil))))
+
+(defun validate-server (server)
+ (with-struct
+ (server public-dir rewrite-rule thread session-save-dir
+ log-save-dir upload-tmp-dir) server
+ (when (aand thread (bordeaux-threads:thread-alive-p it))
+ (error "server is already running"))
+ (unless (string= public-dir "")
+ (ensure-directories public-dir)
+ (unless (is-readable public-dir)
+ (error "invalid public-dir")))
+ (when (and rewrite-rule (not (fboundp rewrite-rule)))
+ (error "invalid rewrite-rule"))
+ (ensure-directories session-save-dir log-save-dir upload-tmp-dir)))
+
+(defun start-server (&optional (server (make-server)))
+ (validate-server server)
+ (setf (server-thread server)
+ (bordeaux-threads:make-thread
+ (lambda () (start-server-thread server))
+ :name (concat "server-" (server-port server))))
+ server)
+
+(defun start-server-thread (server)
+ (with-struct (server host port reuse-address backlog) server
+ (let ((socket (socket-listen host port :backlog backlog
+ :reuse-address reuse-address
+ :element-type '(unsigned-byte 8))))
+ (unwind-protect
+ (loop (handle-request server (socket-accept socket)))
+ (socket-close socket)))))
+
+(defun server-is-running-p (server)
+ (when (aand (server-thread server)
+ (bordeaux-threads:thread-alive-p it))
+ t))
+
+(defun stop-server (server)
+ (if (server-is-running-p server)
+ (bordeaux-threads:destroy-thread (server-thread server))
+ (error "server is not running"))
+ t)
+
+; --- Logging ---------------------------------------------------
+
+(defun write-log (file content)
+ (with-open-file (stream file
+ :direction :output
+ :if-exists :append
+ :if-does-not-exist :create)
+ (format stream (concat content "~%"))))
+
+(defun access-log ()
+ (write-log
+ (concat (server-log-save-dir *server*)
+ "access." (car (split " " (iso-time))) ".log")
+ (join " "
+ (request-remote-addr *request*)
+ (concat "[" (iso-time) "]")
+ (qw (request-request-line *request*))
+ (response-status-code *response*)
+ (qw (header-field "User-Agent")))))
+
+(defun error-log (&rest content)
+ (write-log
+ (concat (if *server* (server-log-save-dir *server*) "/tmp/")
+ "error." (car (split " " (iso-time))) ".log")
+ (join " "
+ (concat "[" (iso-time) "]")
+ (apply #'concat content))))
+
+(defun debug-log (&rest content)
+ (write-log
+ (concat (if *server* (server-log-save-dir *server*) "/tmp/")
+ "debug." (car (split " " (iso-time))) ".log")
+ (join " "
+ (concat "[" (iso-time) "]")
+ (apply #'concat content))))
+
+; --- Session ---------------------------------------------------
+
+(defun %sid ()
+ (aif (get-cookie-sid)
+ (progn
+ (renew-cookie-lifetime it)
+ it)
+ (let ((sid (generate-sid)))
+ (set-cookie (session-name) sid)
+ sid)))
+
+(defun get-cookies (&optional request)
+ (awhen (or request *request*)
+ (request-cookies it)))
+
+(defun get-cookie (name &optional request)
+ (cdr (assoc name (get-cookies request) :test #'equalp)))
+
+(defun set-cookie (name &optional (value "")
+ (expires "Sun, 17-Jan-2038 19:14:07 GMT"))
+ (add-header
+ (format nil "Set-Cookie: ~A=~A; expires=~A; path=~A" name
+ value expires (server-session-cookie-path *server*))))
+
+(defun get-cookie-sid ()
+ (awhen (get-cookie (session-name))
+ (when (valid-sid-p it)
+ it)))
+
+(defun renew-cookie-lifetime (sid)
+ (trivial-shell:shell-command
+ (concat "touch -m " (session-file sid))))
+
+(defun get-session (&optional name)
+ (awhen (aand *sid* (session-file it))
+ (let ((file it))
+ (when (probe-file file)
+ (let ((s (with-open-file (in file)
+ (with-standard-io-syntax
+ (read in nil nil)))))
+ (if name
+ (cdr (assoc name s :test #'equalp))
+ s))))))
+
+(defun rem-session (name)
+ (let ((session (get-session)))
+ (when (cdr (assoc name session :test #'equalp))
+ (set-session
+ (remove-if #'(lambda (x) (string= name (car x)))
+ session)))))
+
+(defun destroy-session ()
+ (set-session '()))
+
+(defun set-session (key-or-vals &optional val)
+ (if (listp key-or-vals)
+ (save-session-data key-or-vals)
+ (let ((session (get-session)))
+ (aif (assoc key-or-vals session :test #'equalp)
+ (setf (cdr it) val)
+ (setf session (append session
+ (list (cons key-or-vals val)))))
+ (save-session-data session))))
+
+(defun save-session-data (data)
+ (with-open-file (out (session-file *sid*)
+ :direction :output
+ :if-exists :supersede)
+ (with-standard-io-syntax
+ (print data out))))
+
+(defun session-file (sid)
+ (awhen (aand sid *server*)
+ (merge-pathnames sid (server-session-save-dir it))))
+
+(defun session-name ()
+ (server-session-name *server*))
+
+(defun generate-sid ()
+ (let ((sid (random-string)))
+ (if (valid-sid-p sid)
+ (generate-sid)
+ (progn
+ (ensure-file-exist (session-file sid))
+ sid))))
+
+(defun valid-sid-p (sid)
+ (let ((file (session-file sid)))
+ (when (and sid (probe-file file))
+ (if (> (- (get-universal-time) (file-write-date file))
+ (server-session-gc-lifetime *server*))
+ (progn
+ (delete-file file)
+ nil)
+ t))))
+
+(defun session-gc (server)
+ (with-struct (server session-save-dir session-gc-lifetime) server
+ (let* ((f "find ~A -maxdepth 1 -type f -cmin +~A -exec rm {} \\;")
+ (min (floor (/ session-gc-lifetime 60)))
+ (gc-command (format nil f session-save-dir min)))
+ (trivial-shell:shell-command gc-command))))
+
+; --- Page ------------------------------------------------------
+
+(defun get-page (name)
+ (gethash (->keyword name) *pages*))
+
+(defun set-page (name fn)
+ (setf (gethash (->keyword name) *pages*) fn))
+
+(defmacro page-lambda ((&rest args) &rest body)
+ (flet ((parse-args (args)
+ (loop for a in args until (keywordp a) collect a)))
+ (let ((args* (parse-args args)))
+ `(lambda ,(awhen args* `(&optional ,@it))
+ (let (,@(loop for p in args*
+ as n = 2 then (1+ n)
+ collect `(,p (or ,p (uri-path ,n))))
+ ,@(awhen (position :post args)
+ (loop for p in (parse-args (subseq args (1+ it)))
+ collect `(,p (post-param ,(->string p)))))
+ ,@(awhen (position :get args)
+ (loop for p in (parse-args (subseq args (1+ it)))
+ collect `(,p (get-param ,(->string p))))))
+ (progn
+ ,@body))))))
+
+(defmacro defpage (name (&rest args) &rest body)
+ `(set-page ',name (page-lambda (,@args) ,@body)))
+
+(defun index-page ()
+ (html :title "Default index page"
+ :body "Default index page"))
+
+(defun %status-page (status-code)
+ (let ((reason (reason-phrase status-code)))
+ (html :title (concat status-code " " reason)
+ :body (concat status-code " " reason))))
+
+(defun status-page (status-code)
+ (setf (response-status-code *response*) status-code)
+ (%status-page status-code))
+
+(defun default-page (&rest args)
+ (aif (get-page 'default)
+ (apply it args)
+ (index-page)))
+
+(defun page (page &rest args)
+ (aif (get-page page)
+ (apply it args)
+ (default-page)))
+
+; --- Response --------------------------------------------------
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun reason-phrase (status-code)
+ (case status-code
+ (200 "OK")
+ (201 "Created")
+ (202 "Accepted")
+ (204 "No Content")
+ (301 "Moved Permanently")
+ (302 "Moved Temporarily")
+ (304 "Not Modified")
+ (400 "Bad Request")
+ (401 "Unauthorized")
+ (403 "Forbidden")
+ (404 "Not Found")
+ (500 "Internal Server Error")
+ (501 "Not Implemented")
+ (502 "Bad Gateway")
+ (503 "Service Unavailable")
+ (otherwise
+ (error
+ (format nil "unknown status code: ~A" status-code))))))
+
+(defun basic-header ()
+ (list (rfc-1123-date)
+ "Server: cl-http-server"
+ "Connection: close"))
+
+(defun add-header (&rest headers)
+ (setf (response-header *response*)
+ (append (response-header *response*) headers)))
+
+(defun response-status-line (status-code)
+ (format nil "HTTP/1.0 ~d ~a"
+ status-code (reason-phrase status-code)))
+
+(defun charset ()
+ (aif (response-charset *response*)
+ (concat "; charset=" (string-downcase (->string it)))
+ ""))
+
+(defun content-length (content)
+ (aif (response-charset *response*)
+ (octet-length content :external-format it)
+ (char-length content)))
+
+(defun send-header ()
+ (flet ((send-http-line (line)
+ (princ (concat line *crlf*) *http-stream*)))
+ (with-flexi-stream (*http-stream* :iso-8859-1)
+ (send-http-line (response-status-line (response-status-code *response*)))
+ (awhen (response-content-type *response*)
+ (add-header (format nil "Content-Type: ~A~A" it (charset))))
+ (mapcar #'send-http-line (response-header *response*))
+ (unless (eq 'HEAD (request-method *request*))
+ (send-http-line "")))))
+
+(defmacro with-header (&rest body)
+ (let ((content (gensym)))
+ `(let* ((*http-binary-stream* (make-in-memory-output-stream))
+ (*http-char-stream*
+ (make-flexi-stream *http-binary-stream* :external-format
+ (response-charset *response*))))
+ (run-hooks 'before-handle-request)
+ (unwind-protect
+ (progn ,@body)
+ (unless (response-sent *response*)
+ (let ((,content (get-output-stream-sequence *http-binary-stream*)))
+ (add-header (format nil "Content-Length: ~D" (content-length ,content)))
+ (send-header)
+ (unless (eq 'HEAD (request-method *request*))
+ (aif (response-charset *response*)
+ (with-flexi-stream (*http-stream* it)
+ (princ (octets-to-string ,content :external-format it)
+ *http-stream*))
+ (write-sequence ,content *http-stream*)))))
+ (run-hooks 'after-handle-request)))))
+
+(add-hook 'after-handle-request #'access-log)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun rfc-1123-date (&optional (time (get-universal-time)))
+ (let ((days #("Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun"))
+ (months #("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul"
+ "Aug" "Sep" "Oct" "Nov" "Dec")))
+ (multiple-value-bind (sec min hr date mon year day)
+ (decode-universal-time time 0)
+ (format nil "Date: ~a, ~2,'0d ~a ~4d ~2,'0d:~2,'0d:~2,'0d GMT"
+ (svref days day) date (svref months (1- mon))
+ year hr min sec)))))
+
+; --- Handle requests -------------------------------------------
+
+(defstruct request
+ (method nil :type symbol)
+ (uri "" :type string)
+ (query-string "" :type string)
+ (script-name "" :type string)
+ (http-version "" :type string)
+ (remote-addr)
+ (request-line)
+ (header-fields)
+ (get-params)
+ (post-params)
+ (cookies))
+
+(defun handle-request (server stream-usocket)
+ (let ((timeout-sec (server-timeout-sec server)))
+ (bordeaux-threads:make-thread
+ (lambda ()
+ (handler-case
+ (bordeaux-threads:with-timeout (timeout-sec)
+ (when (= (random (server-session-gc-probability server)) 0)
+ (session-gc server))
+ (let* ((*http-stream* (socket-stream stream-usocket))
+ (*server* server)
+ (*request* (parse-request)))
+ (set-remote-addr stream-usocket)
+ (unwind-protect
+ (handle-request-thread)
+ (close *http-stream*))))
+ (bordeaux-threads:timeout () (timeout-handelr)))))))
+
+(defun set-remote-addr (stream-usocket)
+ (aif (get-peer-address stream-usocket)
+ (setf (request-remote-addr *request*)
+ (format nil "~{~A~^.~}" (coerce it 'list)))))
+
+(defun timeout-handelr ()
+ (error-log
+ (join " "
+ "[error]"
+ (qw "Request timed out")
+ (awhen *request*
+ (join " " (request-remote-addr it)
+ (qw (request-request-line it)))))))
+
+(defun read-request ()
+ (awhen (read-line *http-stream* nil)
+ (string-trim *crlf* it)))
+
+(defun parse-request ()
+ (let ((req (make-request)))
+ (with-struct
+ (request method uri http-version header-fields request-line) req
+ (with-flexi-stream (*http-stream* :iso-8859-1)
+ ; Request-Line like "GET / HTTP/1.1"
+ (let ((r (split #\Space (setf request-line (read-request)))))
+ (awhen (pop r) (setf method (->keyword it)))
+ (awhen (pop r)
+ (setf uri it)
+ (multiple-value-bind (script query get) (parse-uri uri)
+ (setf (request-script-name req) (or script "")
+ (request-query-string req) (or query "")
+ (request-get-params req) get)))
+ (awhen (pop r) (setf http-version it)))
+ ; Request header fields like "[key]: [value]"
+ (loop for line = (read-request)
+ do (let ((h (split ": " line)))
+ (push (cons (car h) (nth 1 h)) header-fields)
+ (when (string= (car h) "Cookie")
+ (setf (request-cookies req) (parse-params (nth 1 h) "; "))))
+ until (string= line ""))
+ ; Entity body
+ (when (eq method :POST)
+ (let* ((length* (header-field "Content-Length" req))
+ (length (ignore-errors (parse-integer length*)))
+ (type (header-field "Content-Type" req)))
+ (when (and type length (> length 0))
+ (setf (request-post-params req)
+ (parse-request-body length type)))))))
+ req))
+
+(defun parse-request-body (content-length content-type)
+ (multiple-value-bind (type attr)
+ (rfc2388-binary:parse-header-value content-type)
+ (cond ((string= type "application/x-www-form-urlencoded")
+ (with-flexi-stream (*http-stream* :utf-8)
+ (let ((post-query (make-string content-length)))
+ (read-sequence post-query *http-stream*)
+ (parse-params (uri-decode post-query)))))
+ ((string= type "multipart/form-data")
+ (let ((bound (cdr (assoc "boundary" attr :test #'string=))))
+ (rfc2388-binary:read-mime *http-stream* bound
+ #'rfc2388-callback))))))
+
+(defun rfc2388-callback (mime-part)
+ (let* ((header (rfc2388-binary:get-header mime-part "Content-Disposition"))
+ (disposition (rfc2388-binary:header-value header))
+ (name (rfc2388-binary:get-header-attribute header "name"))
+ (filename (rfc2388-binary:get-header-attribute header "filename")))
+ (cond ((or (string= disposition "file") (not (null filename)))
+ (rfc2388-callback-file mime-part name filename))
+ ((string= disposition "form-data")
+ (rfc2388-callback-form-data mime-part name)))))
+
+(defun rfc2388-callback-file (mime-part name filename)
+ (let ((type (rfc2388-binary:content-type mime-part))
+ (tmp-name (uniq-file-name (server-upload-tmp-dir *server*)))
+ (size 0))
+ (setf (rfc2388-binary:content mime-part)
+ (open tmp-name :direction :output :element-type '(unsigned-byte 8)))
+ (values (lambda (byte)
+ (incf size)
+ (write-byte byte (rfc2388-binary:content mime-part)))
+ (lambda ()
+ (close (rfc2388-binary:content mime-part))
+ (cons name (list (cons "name" (when (plusp size) filename))
+ (cons "type" (when (plusp size) type))
+ (cons "tmp-name" (when (plusp size) tmp-name))
+ (cons "size" size)))))))
+
+(defun rfc2388-callback-form-data (mime-part name)
+ (setf (rfc2388-binary:content mime-part)
+ (make-array 10 :element-type '(unsigned-byte 8)
+ :adjustable t :fill-pointer 0))
+ (values (lambda (byte)
+ (vector-push-extend
+ byte (rfc2388-binary:content mime-part)))
+ (lambda ()
+ (cons name (octets-to-string
+ (rfc2388-binary:content mime-part)
+ :external-format :utf-8)))))
+
+(defun parse-uri (uri)
+ (let ((script uri)
+ query
+ get)
+ (awhen (position #\? uri)
+ (setf script (subseq uri 0 it))
+ (setf query (subseq uri (1+ it)))
+ (unless (string= query "")
+ (setf get (parse-params (uri-decode query)))))
+ (values script query get)))
+
+(defun parse-params (query &optional (delimiter "&"))
+ (awhen (split delimiter query)
+ (mapcar #'(lambda (x)
+ (if (position #\= x)
+ (let ((s (split "=" x)))
+ (when (eq (length s) 2)
+ (cons (car s)
+ (regex-replace-all
+ *crlf* (nth 1 s) *nl*))))))
+ it)))
+
+(defun delete-tmp-file ()
+ (loop for p in (post-params)
+ when (listp (cdr p))
+ do (awhen (cdr (assoc "tmp-name" (cdr p) :test #'equal))
+ (when (and it (probe-file it))
+ (delete-file it)))))
+
+(add-hook 'after-handle-request #'delete-tmp-file)
+
+; --- Response --------------------------------------------------
+
+(defstruct response
+ (header (basic-header) :type list)
+ (status-code 200 :type integer)
+ (charset :utf-8 :type symbol)
+ (sent nil :type boolean)
+ (content-type "text/html")
+ (exit))
+
+(defun handle-request-thread ()
+ (let* ((exit (lambda () (return-from handle-request-thread)))
+ (*response* (make-response :exit exit))
+ (*sid* (%sid))
+ (uri (rewrote-uri))
+ (path1 (uri-path 1)))
+ (with-header
+ (case (request-method *request*)
+ ((:get :head :post)
+ (cond ((get-page path1) (funcall (get-page path1)))
+ ((matched-route uri) (funcall (matched-route uri)))
+ ((string= uri "/") (default-page))
+ ((string= (public-dir) "")
+ (status-page 404))
+ (t (serve-file (merge-pathnames
+ (subseq uri 1)
+ (namestring (public-dir)))))))
+ ((:put :delete :link :unlink) (status-page 501))
+ (otherwise (status-page 400))))))
+
+(defun content-type (file)
+ (let* ((file (namestring file))
+ (type (trivial-shell:shell-command (concat "file " file)))
+ (s (split #\Space (string-trim '(#\Newline) type))))
+ (cond ((equalp "image" (ignore-errors (subseq (nth 2 s) 0 5)))
+ (cond ((equalp "PNG" (nth 1 s)) "image/png")
+ ((equalp "JPEG" (nth 1 s)) "image/jpeg")
+ ((equalp "GIF" (nth 1 s)) "image/gif")))
+ ((or (equalp "icon" (car (last s)))
+ (equalp "icon" (nth 3 s))) "image/x-icon")
+ ((equalp "HTML" (nth 1 s)) "text/html")
+ ((equalp "text" (car (last s)))
+ (let ((ext (string-downcase (car (last (split #\. file))))))
+ (cond ((equal "js" ext) "application/x-javascript")
+ ((equal "css" ext) "text/css")
+ (t nil))))
+ ((equalp "Zip" (nth 1 s)) "application/zip"))))
+
+(defun serve-file (file &key (public-file-only t))
+ (cond ((and public-file-only
+ (not (public-file-p file)))
+ (status-page 400))
+ ((or (not (probe-file file))
+ (directory-exists-p file))
+ (status-page 404))
+ ((not (is-readable file))
+ (status-page 403))
+ (t (setf (response-content-type *response*) (content-type file))
+ (setf (response-charset *response*) nil)
+ (with-open-file (in file :element-type '(unsigned-byte 8))
+ (dotimes (i (file-length in))
+ (write-byte (read-byte in) *http-binary-stream*))))))
+
+(defun public-file-p (file)
+ (let* ((file-pdir (pathname-directory file))
+ (public-dir (namestring (public-dir)))
+ (public-pdir (pathname-directory public-dir))
+ (length (length public-pdir)))
+ (unless (or (member :up file-pdir)
+ (> length (length file-pdir))
+ (not (equal public-pdir
+ (remove-if (constantly t) file-pdir
+ :start length))))
+ t)))
+
+; --- Util ------------------------------------------------------
+
+(defun host-uri ()
+ (concat "http://" (header-field "Host") "/"))
+
+(defun page-uri (&rest args)
+ (concat (host-uri) (apply #'join (append '("/") args)) "/"))
+
+(defun uri-path (n)
+ (let* ((u1 (subseq (request-uri *request*) 1))
+ (u2 (let ((u (split #\? u1)))
+ (car u)))
+ (u3 (split #\/ u2)))
+ (aif (nth (1- n) u3)
+ (unless (string= it "")
+ it))))
+
+(defun get-params (&optional request)
+ (awhen (or request *request*)
+ (request-get-params it)))
+
+(defun get-param (name &optional request)
+ (cdr (assoc name (get-params request) :test #'equalp)))
+
+(defun post-params (&optional request)
+ (awhen (or request *request*)
+ (request-post-params it)))
+
+(defun post-param (name &optional request)
+ (cdr (assoc name (post-params request) :test #'equalp)))
+
+(defun header-fields (&optional request)
+ (awhen (or request *request*)
+ (request-header-fields it)))
+
+(defun header-field (name &optional request)
+ (cdr (assoc name (header-fields request) :test #'equalp)))
+
+(defun redirect (uri)
+ (setf (response-status-code *response*) 302)
+ (add-header (format nil "Location: ~A" uri))
+ (exit))
+
+(defun exit ()
+ (awhen (response-exit *response*)
+ (funcall it)))
+
+(defun public-dir ()
+ (awhen *server*
+ (server-public-dir it)))
+
+(defun req-uri ()
+ (request-uri *request*))
+
+(defun get-file-data (name key &optional (param-fn #'post-param))
+ (awhen (funcall param-fn name)
+ (when (listp it)
+ (cdr (assoc key it :test #'equalp)))))
+
+(defun file-name (name) (get-file-data name "name"))
+(defun file-type (name) (get-file-data name "type"))
+(defun file-tmp-name (name) (get-file-data name "tmp-name"))
+(defun file-size (name) (get-file-data name "size"))
+(defun file-save-name (name) (get-file-data name "save-name"))
--- /dev/null
+(in-package :cl-http-server)
+
+(defvar *nl* (format nil "~%")
+ "Newline")
+
+(defvar *crlf*
+ (format nil "~C~C" #\Return #\Linefeed)
+ "CRLF")
+
+(defvar *server* nil
+ "Instance of the server structure")
+
+(defvar *request* nil
+ "Instance of the request structure")
+
+(defvar *response* nil
+ "Instance of the response structure")
+
+(defvar *http-stream* *standard-output*
+ "HTTP stream")
+
+(defvar *http-char-stream* *standard-output*
+ "HTTP character stream")
+
+(defvar *http-binary-stream* *standard-output*
+ "HTTP binary stream")
+
+(defvar *pages* (make-hash-table)
+ "Page hash table")
+
+(defvar *sid* nil
+ "Session ID")
+
+(defvar *hooks* (make-hash-table)
+ "Hooks hash table")
+
+(defparameter *the-random-state*
+ (make-random-state t)
+ "A fresh random state.")
--- /dev/null
+(in-package :cl-http-server)
+
+(defmacro with-struct ((name . fields) struct &body body)
+ (let ((gs (gensym)))
+ `(let ((,gs ,struct))
+ (symbol-macrolet
+ ,(mapcar #'(lambda (f)
+ `(,f (,(intern (concat name "-" f)) ,gs)))
+ fields)
+ ,@body))))
+
+(defmacro with-flexi-stream ((stream external-format) &rest body)
+ `(let ((,stream (make-flexi-stream
+ ,stream :external-format ,external-format)))
+ ,@body))
+
+(defun ensure-file-exist (file)
+ (handler-case
+ (with-open-file
+ (stream file :direction :output :if-exists :append
+ :if-does-not-exist :create)
+ t)
+ (error () nil)))
+
+(defun iso-time (&optional (time (get-universal-time)))
+ (multiple-value-bind (second minute hour date month year)
+ (decode-universal-time time)
+ (format nil "~4,'0d-~2,'0d-~2,'0d ~2,'0d:~2,'0d:~2,'0d"
+ year month date hour minute second)))
+
+(defun is-readable (file)
+ (let ((file (namestring file)))
+ (unless (not (probe-file file))
+ (handler-case
+ (with-open-file (stream file)
+ t)
+ (error () nil)))))
+
+(defun qw (str)
+ (format nil "\"~A\"" (or str "")))
+
+(defun random-string (&optional (n 10) (base 16))
+ (with-output-to-string (s)
+ (dotimes (i n)
+ (format s "~VR" base
+ (random base *the-random-state*)))))
+
+(defun uri-encode (str)
+ (with-output-to-string (s)
+ (loop for c across str
+ for i from 0
+ do (if (or (char<= #\0 c #\9)
+ (char<= #\a c #\z)
+ (char<= #\A c #\Z)
+ (find c "'.-*()_" :test #'char=))
+ (write-char c s)
+ (loop for o across
+ (string-to-octets str :start i :end (1+ i)
+ :external-format :utf-8)
+ do (format s "%~2,'0x" o))))))
+
+(defun uri-decode (str)
+ (let* ((len (length str))
+ (vec (make-array
+ len :element-type '(unsigned-byte 8) :fill-pointer 0))
+ (idx 0))
+ (flet ((vec-push (x) (vector-push x vec)))
+ (do ()
+ ((not (< idx len)))
+ (let ((c (char str idx)))
+ (cond ((char= c #\%)
+ (vec-push
+ (parse-integer
+ str :start (1+ idx) :end (+ 3 idx) :radix 16))
+ (incf idx 2))
+ ((char= c #\+) (vec-push 32))
+ (t (vec-push
+ (elt (string-to-octets
+ (string c) :external-format :utf-8) 0)))))
+ (incf idx)))
+ (octets-to-string vec :external-format :utf-8)))
+
+(defun uniq-file-name (dir &optional (length 10))
+ (dotimes (x 5)
+ (let ((file (concat dir (random-string length))))
+ (unless (probe-file file)
+ (return-from uniq-file-name file)))))
+
+(defun html (&key (title "Default title") (body "Default body"))
+ (format *http-char-stream*
+"<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN
+http://www.w3.org/TR/html4/loose.dtd\">
+<HTML LANG=\"en\">
+<HEAD>
+<META HTTP-EQUIV=\"content-type\" CONTENT=\"text/html; charset=utf-8\">
+<TITLE>~A</TITLE>
+</HEAD>
+<BODY>
+~A
+</BODY>
+</HTML>" title body))
--- /dev/null
+(in-package :cl-user)
+
+(defpackage :cl-http-server-tests
+ (:use :cl :cl-http-server :my-util :5am :drakma)
+ (:import-from :cl-http-server :html :random-string))
+
+(in-package :cl-http-server-tests)
+
+(def-suite cl-http-server)
--- /dev/null
+Hello
+World
--- /dev/null
+h1 { color: white; background: orange !important; }
+h2 { color: white; background: green !important; }
--- /dev/null
+<html>
+<body>
+Hello, World!
+</body>
+</html>
--- /dev/null
+function test () {
+ alert("Hello, World!");
+}
--- /dev/null
+Hello
+World
--- /dev/null
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (asdf:oos 'asdf:load-op :cl-http-server-tests))
+
+(in-package :cl-http-server-tests)
+
+(let ((*srv* (start-server
+ (make-server :public-dir *test-public-dir* :port 8080))))
+ (unwind-protect (5am:run! 'cl-http-server)
+ (stop-server *srv*)))
--- /dev/null
+(in-package :cl-http-server-tests)
+(in-suite cl-http-server)
+
+(defun p (obj)
+ (when obj
+ (princ obj *http-char-stream*))
+ nil)
+
+(defun p/ (&rest args)
+ (dolist (a args)
+ (p a)))
+
+(defun string=* (str1 str2)
+ (string= (regex-replace-all *nl* str1 "")
+ (regex-replace-all *nl* str2 "")))
+
+(defmacro sml= (sml ml)
+ `(let ((*http-char-stream* (make-string-output-stream)))
+ ,sml
+ (string=* (get-output-stream-string *http-char-stream*)
+ ,ml)))
+
+(defun file-content= (file &optional content)
+ (unless content
+ (setf content (http-request (concat "http://localhost:8080/" file))))
+ (let ((e (if (stringp content) 'base-char '(unsigned-byte 8))))
+ (with-open-file (in (merge-pathnames file *test-public-dir*) :element-type e)
+ (let* ((length (file-length in))
+ (array (make-array length :element-type e)))
+ (read-sequence array in)
+ (equalp array content)))))
+
+(defun upload-file= (file)
+ (file-content= file
+ (http-request "http://localhost:8080/upload-test"
+ :method :post
+ :content-length t
+ :parameters
+ (list (list "foo" (merge-pathnames
+ file *test-public-dir*))))))
+
+(defun status-code= (uri status-code)
+ (multiple-value-bind (body status-code* headers uri stream close reason-phrase)
+ (http-request (concat "http://localhost:8080/" uri))
+ (declare (ignore body headers uri stream close reason-phrase))
+ (= status-code* status-code)))
+
+(defun content-type= (uri content-type)
+ (multiple-value-bind (body status-code headers uri stream close reason-phrase)
+ (http-request (concat "http://localhost:8080/" uri))
+ (declare (ignore body status-code uri stream close reason-phrase))
+ (equalp content-type
+ (awhen (cdr (assoc :content-type headers))
+ (car (split "; " it))))))
+
+(defun test-rewrite-rule (uri)
+ (let ((match (scan-to-strings "(\.ico|\.gif|\.jpeg|\.jpg|\.png|)$" uri)))
+ (when (not (string= match ""))
+ "/test.html")))
+
+(defun matched-page ()
+ (html :body "matched"))
+
+(defun defpage-test1 ()
+ (html :body "defpage-test1"))
+
+; Drakma has a bug which drakma don't send cookies when the request uri is
+; a root directory even when cookie path is set to "/". This function is
+; to avoid that bug. The bug has been alread fixed in dev repo on 2009/02/25.
+; http://bknr.net/trac/changeset/4322
+(defun http-request* (uri &rest args)
+ (apply #'http-request
+ (append (list (regex-replace-all "http://localhost:8080/"
+ uri "http://localhost:8080//"))
+ args)))
+
+(test static-file
+ (is (file-content= "test"))
+ (is (file-content= "test.css"))
+ (is (file-content= "test.gif"))
+ (is (file-content= "test.html"))
+ (is (file-content= "test.ico"))
+ (is (file-content= "test.jpeg"))
+ (is (file-content= "test.js"))
+ (is (file-content= "test.png"))
+ (is (file-content= "test.txt"))
+ (is (file-content= "test.zip")))
+
+(defvar *test-tmp-files* nil)
+(test file-upload
+ (setf *test-tmp-files* nil)
+ (defpage upload-test ()
+ (awhen (post-param "foo")
+ (awhen (cdr (assoc "tmp-name" it :test #'equal))
+ (push it *test-tmp-files*)
+ (serve-file it :public-file-only nil))))
+ (is (upload-file= "test"))
+ (is (upload-file= "test.css"))
+ (is (upload-file= "test.gif"))
+ (is (upload-file= "test.html"))
+ (is (upload-file= "test.ico"))
+ (is (upload-file= "test.jpeg"))
+ (is (upload-file= "test.js"))
+ (is (upload-file= "test.png"))
+ (is (upload-file= "test.txt"))
+ (is (upload-file= "test.zip"))
+ (loop for f in *test-tmp-files*
+ do (is-false (probe-file f))))
+
+(test get-params
+ (defpage get-params-test () (p/ (get-params)))
+ (is-true (sml= (p/ '(("k1" . "v1")("k2" . "v2")("k3" . "v3")))
+ (http-request
+ "http://localhost:8080/get-params-test?k1=v1&k2=v2&k3=v3"))))
+
+(test get-param
+ (defpage get-param-test () (p/ (get-param "k1")))
+ (is-true (sml= (p/ "v1")
+ (http-request
+ "http://localhost:8080/get-param-test?k1=v1"))))
+
+(test post-params
+ (defpage post-params-test () (p/ (post-params)))
+ (is-true (sml= (p/ '(("k1" . "v1")("k2" . "v2")))
+ (http-request
+ "http://localhost:8080/post-params-test"
+ :method :post :form-data t
+ :parameters '(("k1" . "v1") ("k2" . "v2")))))
+ ; (multipart/form-data)
+ (is-true (sml= (p/ '(("k1" . "v1")("k2" . "v2")))
+ (http-request
+ "http://localhost:8080/post-params-test"
+ :method :post
+ :parameters '(("k1" . "v1") ("k2" . "v2"))))))
+
+(test post-param
+ (defpage post-param-test () (p/ (post-param "k1")))
+ (is-true (sml= (p/ "v1")
+ (http-request
+ "http://localhost:8080/post-param-test"
+ :method :post :form-data t :parameters '(("k1" . "v1"))))))
+
+(test defpage
+ (defpage defpage-test1 () (defpage-test1))
+ (is-true (sml= (defpage-test1)
+ (http-request "http://localhost:8080/defpage-test1")))
+ (defpage defpage-test2 (p1 p2) (p/ p1 p2))
+ (is-true (sml= (p/ "pv1" "pv2")
+ (http-request "http://localhost:8080/defpage-test2/pv1/pv2/")))
+ (defpage defpage-test3 (:get p1 p2) (p/ p1 p2))
+ (is-true (sml= (p/ "pv1" "pv2")
+ (http-request
+ "http://localhost:8080/defpage-test3?p1=pv1&p2=pv2")))
+ (defpage defpage-test4 (:post p1 p2) (p/ p1 p2))
+ (is-true (sml= (p/ "pv1" "pv2")
+ (http-request
+ "http://localhost:8080/defpage-test4"
+ :method :post :form-data t
+ :parameters '(("p1" . "pv1") ("p2" . "pv2"))))))
+
+;(test page-lambda
+; (defpage page-lambda-test1 ()
+; (form/cont/ (page-lambda (:post foo) (p/ foo))
+; (input-text/ "foo")))
+; (let ((c (make-instance 'cookie-jar)))
+; (multiple-value-bind (match regs)
+; (scan-to-strings "NAME=\"cid\" VALUE=\"(.+)\""
+; (http-request
+; "http://localhost:8080/page-lambda-test1"
+; :cookie-jar c))
+; (is-true (sml= (p/ "ok")
+; (http-request "http://localhost:8080//"
+; :method :post :form-data t
+; :parameters
+; (list (cons "cid" (elt regs 0))
+; (cons "foo" "ok"))
+; :cookie-jar c))))))
+
+(test page
+ (is-true (sml= (cl-http-server::%status-page 400)
+ (http-request "http://localhost:8080/../../../../../../etc/passwd")))
+ (is-true (sml= (cl-http-server::%status-page 404)
+ (http-request "http://localhost:8080/nopage")))
+ (defpage page-test1 () (matched-page))
+ (defpage page-test2 () (page 'page-test1))
+ (is-true (sml= (matched-page)
+ (http-request "http://localhost:8080/page-test2")))
+ (is-true (sml= (default-page)
+ (http-request "http://localhost:8080/"))))
+
+(test status-code
+ (is (status-code= "test" 200))
+ (is (status-code= "test.css" 200))
+ (is (status-code= "test.gif" 200))
+ (is (status-code= "test.html" 200))
+ (is (status-code= "test.ico" 200))
+ (is (status-code= "test.jpeg" 200))
+ (is (status-code= "test.js" 200))
+ (is (status-code= "test.png" 200))
+ (is (status-code= "test.txt" 200))
+ (is (status-code= "test.zip" 200))
+ (is (status-code= "../../../../../../etc/passwd" 400))
+ (is (status-code= "nopage" 404))
+ (is (status-code= "defpage-test1" 200))
+ (is (status-code= "" 200)))
+
+(test content-type
+ (is (content-type= "test" nil))
+ (is (content-type= "test.css" "text/css" ))
+ (is (content-type= "test.gif" "image/gif"))
+ (is (content-type= "test.html" "text/html"))
+ (is (content-type= "test.ico" "image/x-icon"))
+ (is (content-type= "test.jpeg" "image/jpeg"))
+ (is (content-type= "test.js" "application/x-javascript"))
+ (is (content-type= "test.png" "image/png"))
+ (is (content-type= "test.txt" nil))
+ (is (content-type= "test.zip" "application/zip"))
+ (is (content-type= "defpage-test1" "text/html"))
+ (is (content-type= "" "text/html")))
+
+(test rewrite-rule
+ (setf (cl-http-server::server-rewrite-rule *srv*) 'test-rewrite-rule)
+ (is (file-content= "test.html"
+ (http-request "http://localhost:8080/test.gif")))
+ (is (file-content= "test.html"
+ (http-request "http://localhost:8080/test.png")))
+ (is (file-content= "test.html"))
+ (is (file-content= "test.js"))
+ (is (file-content= "test.css"))
+ (setf (cl-http-server::server-rewrite-rule *srv*) nil))
+
+(test static-route
+ (add-route *srv* :static "/nopage" 'matched-page)
+ (is-true (sml= (matched-page)
+ (http-request "http://localhost:8080/nopage")))
+ (rem-route *srv* :static "/nopage")
+ (is-true (sml= (cl-http-server::%status-page 404)
+ (http-request "http://localhost:8080/nopage"))))
+
+(test regex-route
+ (is-true (sml= (cl-http-server::%status-page 404)
+ (http-request "http://localhost:8080/matched1")))
+ (add-route *srv* :regex "^/matched" 'matched-page)
+ (is-true (sml= (matched-page)
+ (http-request "http://localhost:8080/matched1")))
+ (is-true (sml= (cl-http-server::%status-page 404)
+ (http-request "http://localhost:8080/no/matched1")))
+ (is-true (sml= (matched-page)
+ (http-request "http://localhost:8080/matched2")))
+ (rem-route *srv* :regex "^/matched")
+ (is-true (sml= (cl-http-server::%status-page 404)
+ (http-request "http://localhost:8080/matched1"))))
+
+(test cookie
+ (let ((r (random-string)))
+ (defpage cookie-set-test () (set-cookie "cookie-set-test1" r))
+ (defpage cookie-get-test () (p/ (get-cookie "cookie-set-test1")))
+ (let ((cookie (make-instance 'cookie-jar)))
+ (http-request "http://localhost:8080/cookie-set-test" :cookie-jar cookie)
+ (is-true (sml= (p/ r)
+ (http-request "http://localhost:8080/cookie-get-test"
+ :cookie-jar cookie))))))
+
+(test session
+ (let ((r (random-string)))
+ (defpage session-set-test () (set-session "session-set-test1" r))
+ (defpage session-get-test () (p/ (get-session "session-set-test1")))
+ (let ((cookie (make-instance 'cookie-jar)))
+ (http-request "http://localhost:8080/session-set-test" :cookie-jar cookie)
+ (is-true (sml= (p/ r)
+ (http-request "http://localhost:8080/session-get-test"
+ :cookie-jar cookie))))))
+
+(test host-uri
+ (defpage host-uri-test () (p (host-uri)))
+ (is (equal "http://localhost:8080/"
+ (http-request "http://localhost:8080/host-uri-test"))))
+
+(test header-field
+ (defpage header-field-test () (p (header-field "Host")))
+ (is (equal "localhost:8080"
+ (http-request "http://localhost:8080/header-field-test"))))
+
+(test redirect
+ (defpage redirect-test1 ()
+ (redirect (page-uri 'redirect-test2)))
+ (defpage redirect-test2 () (p "ok"))
+ (is (equal "ok" (http-request "http://localhost:8080/redirect-test2"))))
+
+(test file-data
+ (defpage file-data-test1 ()
+ (p (concat (file-name "foo") "-"
+ (file-type "foo") "-"
+ (file-size "foo"))))
+ (is (equal "test.gif-image/gif-1841"
+ (http-request "http://localhost:8080/file-data-test1"
+ :method :post :content-length t
+ :parameters
+ (list (list "foo"
+ (merge-pathnames "test.gif"
+ *test-public-dir*)
+ :content-type "image/gif"
+ :filename "test.gif")))))
+ (is (equal "test.png-image/gif-2497"
+ (http-request "http://localhost:8080/file-data-test1"
+ :method :post :content-length t
+ :parameters
+ (list (list "foo"
+ (merge-pathnames "test.png"
+ *test-public-dir*)
+ :content-type "image/gif"
+ :filename "test.png"))))))
--- /dev/null
+(in-package :cl-http-server-tests)
+
+(defvar *test-dir*
+ (cl-http-server::awhen (load-time-value #.*compile-file-pathname*)
+ (directory-namestring cl-http-server::it)))
+
+(defvar *test-public-dir*
+ (namestring (merge-pathnames "public/" *test-dir*)))
+
+(defvar *nl* (format nil "~%"))
+
+(defvar *srv* nil)
--- /dev/null
+(in-package :cl-http-server-tests)
+
+(test with-struct
+ (defstruct str
+ (s1)
+ (s2))
+ (let ((str (make-str :s1 "s1" :s2 "s2")))
+ (is (string= (str-s1 str) "s1"))
+ (is (string= (str-s2 str) "s2")))
+ (let ((str (make-str)))
+ (with-struct (str s1 s2) str
+ (setf s1 :s1)
+ (setf s2 :s2)
+ (is (eq (str-s1 str) :s1))
+ (is (eq (str-s2 str) :s2)))))
+
+(test with-flexi-stream
+ (with-open-file (in "/tmp/flexi-test" :if-does-not-exist :create)
+ (with-flexi-stream (in :utf-8)
+ (is (typep (flexi-streams:flexi-stream-external-format in)
+ 'FLEXI-STREAMS::FLEXI-UTF-8-FORMAT)))
+ (with-flexi-stream (in :iso-8859-1)
+ (is (typep (flexi-streams:flexi-stream-external-format in)
+ 'FLEXI-STREAMS::FLEXI-LATIN-1-FORMAT)))))
+
+(test ensure-file-exist
+ (loop for i from 1 to 3
+ as f = (mkstr "/tmp/web4r.util.test" i)
+ do (progn
+ (when (is-readable f)
+ (trivial-shell:shell-command (mkstr "rm -f " f)))
+ (when (is-readable f)
+ (error (format nil "file ~A already exists" f)))
+ (ensure-file-exist f)
+ (is (eq t (is-readable f)))
+ (trivial-shell:shell-command (mkstr "rm -f " f)))))
+
+(test iso-time
+ (is (equal (iso-time 3161620249) "2000-03-10 04:50:49"))
+ (is (equal (iso-time 3361620000) "2006-07-12 00:20:00"))
+ (is (equal (iso-time 3443620249) "2009-02-15 02:10:49")))
+
+(test is-readable
+ (is (eq t (is-readable "/etc/"))))
+
+(test qw
+ (is (string= (qw "str") "\"str\""))
+ (is (string= (qw nil) "\"\""))
+ (is (string= (qw "\"") "\"\"\"")))
+
+(test random-string
+ (let ((lst (loop for i from 1 to 10
+ collect (random-string 32))))
+ (loop for r in lst
+ as i from 0
+ do (progn
+ (is (null (member r (remseq lst i (1+ i)))))))))
+
+(test uri-encode
+ (is (string= (uri-encode "ニュース速報")
+ "%E3%83%8B%E3%83%A5%E3%83%BC%E3%82%B9%E9%80%9F%E5%A0%B1"))
+ (is (string= (uri-encode "'.-*()_") "'.-*()_"))
+ (is (string= (uri-encode "UTF-8") "UTF-8"))
+ (is (string= (uri-encode " ") "%20")))
+
+(test uri-decode
+ (is (string= (uri-decode
+ "%E3%83%8B%E3%83%A5%E3%83%BC%E3%82%B9%E9%80%9F%E5%A0%B1")
+ "ニュース速報"))
+ (is (string= (uri-decode "'.-*()_") "'.-*()_"))
+ (is (string= (uri-decode "UTF-8") "UTF-8"))
+ (is (string= (uri-decode "%20") " ")))
+
+(test uniq-file-name
+ (let ((dir "/tmp/web4r-test/")
+ (times 10))
+ (when (probe-file dir)
+ (cl-fad:delete-directory-and-files dir))
+ (ensure-directories-exist dir :verbose nil)
+ (let (files)
+ (dotimes (x times)
+ (let ((file (uniq-file-name dir)))
+ (push file files)
+ (ensure-file-exist file)))
+ (is (eq (length (cl-fad:list-directory dir)) times))
+ (loop for f in files
+ do (is (probe-file f)))
+ (cl-fad:delete-directory-and-files dir))))
--- /dev/null
+Version 1.0.15
+2015-07-01
+Support strings as external-format name specifiers (LispAlien)
+
+Version 1.0.14
+2014-11-28
+update support information (Hans Huebner)
+
+Version 1.0.13
+2014-05-18
+fix version number (Hans Huebner)
+
+Version 1.0.12
+2013-12-30
+Update :description
+
+Version 1.0.11
+2013-12-30
+Don't reset column to NIL on internal write operations (Anton Vodonosov)
+
+Version 1.0.10
+2013-12-09
+Fix file-position errors (markv)
+
+Version 1.0.9
+2013-11-21
+Dummy release without any functional changes
+
+Version 1.0.8
+Make write-sequence call transform-octet (Jason Miller)
+Fix for CMUCL (Raymond Toy, Xu Jingtao)
+
+Version 1.0.7
+2008-08-26
+Don't read a second time if the first READ-SEQUENCE already reached EOF (Drakma bug report by Stas Boukarev)
+
+Version 1.0.6
+2008-08-25
+Don't use a reserve if we can't rewind the stream (Drakma bug report by Stas Boukarev)
+
+Version 1.0.5
+2008-08-01
+Export RUN-ALL-TESTS instead of RUN-TESTS (caught by Nick Allen)
+
+Version 1.0.4
+2008-07-25
+Cosmetic surgery on test suite
+
+Version 1.0.3
+2008-05-30
+Better checks for invalid UTF-8 data
+New restart ACCEPT-OVERLONG-SEQUENCE
+More tests
+Unused variable in CHECK-END
+
+Version 1.0.2
+2008-05-26
+Removed unnecessary test
+
+Version 1.0.1
+2008-05-26
+Removed two faulty declarations
+
+Version 1.0.0
+2008-05-26
+More redesign for the sake of performance
+More checks for invalid data
+More tests
+Exported functions for length computation
+
+Version 0.15.3
+2008-05-23
+Avoid CHANGE-CLASS on LispWorks if possible
+
+Version 0.15.2
+2008-05-22
+Remove debugging remnants (d'ooh!)
+
+Version 0.15.1
+2008-05-21
+Direct access to underlying stream in case of binary sequence operations
+More tests
+
+Version 0.15.0
+2008-05-21
+Complete redesign, various additions, bugfixes, performance improvements (with the help of Hans Hübner)
+
+Version 0.14.0
+2007-12-30
+Some fixes for LispWorks (when the underlying stream is a character stream)
+Optimized methods for UNREAD-CHAR% in case of 8-bit encodings
+More tests
+
+Version 0.13.1
+2007-10-11
+Small fix for AllegroCL's "modern" mode
+
+Version 0.13.0
+2007-09-13
+Better optimizations for STREAM-WRITE-SEQUENCE (thanks to Anton Vodonosov)
+Bugfix for STREAM-WRITE-BYTE
+
+Version 0.12.0
+2007-09-07
+Added "bound" for flexi input streams
+
+Version 0.11.2
+2007-04-06
+Fixed bug in STREAM-WRITE-STRING implementation (reported by quasi)
+
+Version 0.11.1
+2007-03-22
+More ugliness for a bit of output performance in special cases
+
+Version 0.11.0
+2007-03-09
+Re-factoring of how encoding errors are handled (patch by Anton Vodonosov)
+
+Version 0.10.3
+2007-02-19
+Fixed bug in UTF-16 output (patch by Stelian Ionescu)
+Fixed *SUBSTITUTION-CHAR* example in docs
+
+Version 0.10.2
+2007-01-12
+Another fix - sigh...
+
+Version 0.10.1
+2007-01-11
+Fixed the last change (thanks to Red Daly)
+
+Version 0.10.0
+2007-01-10
+Added transformers to in-memory streams (thanks to Chris Dean)
+Documentation fixes
+
+Version 0.9.1
+2006-12-27
+More performance improvements (thanks to Robert J. Macomber for SBCL hints)
+
+Version 0.9.0
+2006-12-27
+Complete re-factoring to improve performance and reduce consing (at least for LispWorks)
+Added some tests
+Added *PROVIDE-USE-VALUE-RESTART*
+Added FLEXI-STREAM-POSITION-SPEC-ERROR condition
+
+Version 0.8.0
+2006-11-14
+Added USE-VALUE restart for STREAM-READ-CHAR (thanks to Anton Vodonosov)
+Added *SUBSTITUTION-CHAR*
+
+Version 0.7.2
+2006-11-06
+Removed unnecessary CHECK-EOF-NO-HANG also for in-memory streams (see 0.5.8)
+
+Version 0.7.1
+2006-10-31
+Argh, missed the most important part...
+
+Version 0.7.0
+2006-10-31
+Added KOI8-R (thanks to Igor Plekhov)
+
+Version 0.6.6
+2006-10-06
+Made sure not to apply Gray stream generic function to underlying stream
+
+Version 0.6.5
+2006-10-06
+Optimized STREAM-WRITE-SEQUENCE and STREAM-READ-SEQUENCE for arrays of octets
+
+Version 0.6.4
+2006-10-05
+Made READ-BYTE/WRITE-BYTE the default behaviour, i.e. we only use the sequence functions for LW if necessary
+
+Version 0.6.3
+2006-10-02
+Fixed problems with CMUCL Gray streams implementation (reported by Ivan Toshkov)
+
+Version 0.6.2
+2006-09-23
+Added method for MAKE-LOAD-FORM which is needed for OpenMCL (reported by Robert Synnott, see Drakma mailing list)
+
+Version 0.6.1
+2006-09-15
+Switched FILE-POSITION implementation to TRIVIAL-GRAY-STREAMS (thanks to David Lichteblau)
+
+Version 0.6.0
+2006-09-13
+Implemented file positions for LispWorks
+
+Version 0.5.10
+2006-09-04
+Flexi streams can have binary element types now
+
+Version 0.5.9
+2006-09-01
+Added string functions
+
+Version 0.5.8
+2006-09-01
+CHECK-EOF-NO-HANG is not necessary
+Updated LW links in documentation
+Changed package handling in system definition (thanks to Christophe Rhodes)
+
+Version 0.5.7
+2006-06-29
+Removed incompatibility with AllegroCL, see mailing list archive for details
+
+Version 0.5.6
+2006-06-13
+Fixed Emacs mode lines (reported by Robert Goldman)
+
+Version 0.5.5
+2006-05-24
+Some small fixes for LW
+
+Version 0.5.4
+2006-05-18
+Workaround for CMUCL (thanks to Satyaki Das)
+
+Version 0.5.3
+2006-03-06
+Fixed more typos in stream.lisp
+Added missing exports in packages.lisp
+
+Version 0.5.2
+2006-01-26
+Fixed typos in stream.lisp (thanks to James Bielman)
+
+Version 0.5.1
+2005-12-14
+Some bugfixes in output.lisp (thanks to Jan Idzikowski)
+
+Version 0.5.0
+2005-12-11
+Added in-memory streams
+Exported types
+Added specific conditions
+
+Version 0.4.1
+2005-12-05
+Updated docs
+
+Version 0.4.0
+2005-12-05
+Added US-ASCII encoding
+Added *USE-REPLACEMENT-CHAR*
+
+Version 0.3.0
+2005-11-26
+Added UNREAD-BYTE and PEEK-BYTE
+
+Version 0.2.4
+2005-11-26
+WIN32:CODE-PAGE only for LispWorks
+
+Version 0.2.3
+2005-11-26
+Added STREAM-TERPRI to appease AllegroCL
+Fixed typo in docs
+
+Version 0.2.2
+2005-11-26
+Patch to make class precendence list work in AllegroCL (David Lichteblau)
+
+Version 0.2.1
+2005-11-25
+Adapted to new TRIVIAL-GRAY-STREAMS API (David Lichteblau)
+More changes for portability, specifically for SBCL (David Lichteblau)
+
+Version 0.2.0
+2005-11-25
+Portable version thanks to TRIVIAL-GRAY-STREAMS (David Lichteblau)
+
+Version 0.1.1
+2005-11-25
+Documentation enhancements
+
+Version 0.1.0
+2005-11-25
+Initial public release
--- /dev/null
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: FLEXI-STREAMS; Base: 10 -*-\r
+;;; $Header: /usr/local/cvsrep/flexi-streams/ascii.lisp,v 1.9 2008/05/18 21:32:15 edi Exp $\r
+\r
+;;; Copyright (c) 2005-2008, Dr. Edmund Weitz. All rights reserved.\r
+\r
+;;; Redistribution and use in source and binary forms, with or without\r
+;;; modification, are permitted provided that the following conditions\r
+;;; are met:\r
+\r
+;;; * Redistributions of source code must retain the above copyright\r
+;;; notice, this list of conditions and the following disclaimer.\r
+\r
+;;; * Redistributions in binary form must reproduce the above\r
+;;; copyright notice, this list of conditions and the following\r
+;;; disclaimer in the documentation and/or other materials\r
+;;; provided with the distribution.\r
+\r
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED\r
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED\r
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE\r
+;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY\r
+;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL\r
+;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE\r
+;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS\r
+;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,\r
+;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING\r
+;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS\r
+;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.\r
+\r
+(in-package :flexi-streams)\r
+\r
+(defconstant +ascii-table+\r
+ ;; currently not used, but we leave it in here just in case...\r
+ (make-decoding-table '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533))\r
+ "An array enumerating the character codes for the US-ASCII\r
+encoding.")\r
--- /dev/null
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: FLEXI-STREAMS; Base: 10 -*-\r
+;;; $Header: /usr/local/cvsrep/flexi-streams/code-pages.lisp,v 1.7 2008/05/18 21:32:15 edi Exp $\r
+\r
+;;; Copyright (c) 2005-2008, Dr. Edmund Weitz. All rights reserved.\r
+\r
+;;; Redistribution and use in source and binary forms, with or without\r
+;;; modification, are permitted provided that the following conditions\r
+;;; are met:\r
+\r
+;;; * Redistributions of source code must retain the above copyright\r
+;;; notice, this list of conditions and the following disclaimer.\r
+\r
+;;; * Redistributions in binary form must reproduce the above\r
+;;; copyright notice, this list of conditions and the following\r
+;;; disclaimer in the documentation and/or other materials\r
+;;; provided with the distribution.\r
+\r
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED\r
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED\r
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE\r
+;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY\r
+;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL\r
+;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE\r
+;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS\r
+;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,\r
+;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING\r
+;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS\r
+;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.\r
+\r
+(in-package :flexi-streams)\r
+\r
+;;; the following code was auto-generated with LWW\r
+\r
+(defconstant +code-page-tables+\r
+ `((437 . ,(make-decoding-table '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 199 252 233 226 228 224 229 231 234 235 232 239 238 236 196 197 201 230 198 244 246 242 251 249 255 214 220 162 163 165 8359 402 225 237 243 250 241 209 170 186 191 8976 172 189 188 161 171 187 9617 9618 9619 9474 9508 9569 9570 9558 9557 9571 9553 9559 9565 9564 9563 9488 9492 9524 9516 9500 9472 9532 9566 9567 9562 9556 9577 9574 9568 9552 9580 9575 9576 9572 9573 9561 9560 9554 9555 9579 9578 9496 9484 9608 9604 9612 9616 9600 945 223 915 960 931 963 181 964 934 920 937 948 8734 966 949 8745 8801 177 8805 8804 8992 8993 247 8776 176 8729 183 8730 8319 178 9632 160))) \r
+ (720 . ,(make-decoding-table '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 233 226 132 224 134 231 234 235 232 239 238 141 142 143 144 1617 1618 244 164 1600 251 249 1569 1570 1571 1572 163 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 171 187 9617 9618 9619 9474 9508 9569 9570 9558 9557 9571 9553 9559 9565 9564 9563 9488 9492 9524 9516 9500 9472 9532 9566 9567 9562 9556 9577 9574 9568 9552 9580 9575 9576 9572 9573 9561 9560 9554 9555 9579 9578 9496 9484 9608 9604 9612 9616 9600 1590 1591 1592 1593 1594 1601 181 1602 1603 1604 1605 1606 1607 1608 1609 1610 8801 1611 1612 1613 1614 1615 1616 8776 176 8729 183 8730 8319 178 9632 160))) \r
+ (737 . ,(make-decoding-table '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 931 932 933 934 935 936 937 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 963 962 964 965 966 967 968 9617 9618 9619 9474 9508 9569 9570 9558 9557 9571 9553 9559 9565 9564 9563 9488 9492 9524 9516 9500 9472 9532 9566 9567 9562 9556 9577 9574 9568 9552 9580 9575 9576 9572 9573 9561 9560 9554 9555 9579 9578 9496 9484 9608 9604 9612 9616 9600 969 940 941 942 970 943 972 973 971 974 902 904 905 906 908 910 911 177 8805 8804 938 939 247 8776 176 8729 183 8730 8319 178 9632 160))) \r
+ (775 . ,(make-decoding-table '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 262 252 233 257 228 291 229 263 322 275 342 343 299 377 196 197 201 230 198 333 246 290 162 346 347 214 220 248 163 216 215 164 256 298 243 379 380 378 8221 166 169 174 172 189 188 321 171 187 9617 9618 9619 9474 9508 260 268 280 278 9571 9553 9559 9565 302 352 9488 9492 9524 9516 9500 9472 9532 370 362 9562 9556 9577 9574 9568 9552 9580 381 261 269 281 279 303 353 371 363 382 9496 9484 9608 9604 9612 9616 9600 211 223 332 323 245 213 181 324 310 311 315 316 326 274 325 8217 173 177 8220 190 182 167 247 8222 176 8729 183 185 179 178 9632 160))) \r
+ (850 . ,(make-decoding-table '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 199 252 233 226 228 224 229 231 234 235 232 239 238 236 196 197 201 230 198 244 246 242 251 249 255 214 220 248 163 216 215 402 225 237 243 250 241 209 170 186 191 174 172 189 188 161 171 187 9617 9618 9619 9474 9508 193 194 192 169 9571 9553 9559 9565 162 165 9488 9492 9524 9516 9500 9472 9532 227 195 9562 9556 9577 9574 9568 9552 9580 164 240 208 202 203 200 305 205 206 207 9496 9484 9608 9604 166 204 9600 211 223 212 210 245 213 181 254 222 218 219 217 253 221 175 180 173 177 8215 190 182 167 247 184 176 168 183 185 179 178 9632 160))) \r
+ (852 . ,(make-decoding-table '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 199 252 233 226 228 367 263 231 322 235 336 337 238 377 196 262 201 313 314 244 246 317 318 346 347 214 220 356 357 321 215 269 225 237 243 250 260 261 381 382 280 281 172 378 268 351 171 187 9617 9618 9619 9474 9508 193 194 282 350 9571 9553 9559 9565 379 380 9488 9492 9524 9516 9500 9472 9532 258 259 9562 9556 9577 9574 9568 9552 9580 164 273 272 270 203 271 327 205 206 283 9496 9484 9608 9604 354 366 9600 211 223 212 323 324 328 352 353 340 218 341 368 253 221 355 180 173 733 731 711 728 167 247 184 176 168 729 369 344 345 9632 160))) \r
+ (855 . ,(make-decoding-table '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 1106 1026 1107 1027 1105 1025 1108 1028 1109 1029 1110 1030 1111 1031 1112 1032 1113 1033 1114 1034 1115 1035 1116 1036 1118 1038 1119 1039 1102 1070 1098 1066 1072 1040 1073 1041 1094 1062 1076 1044 1077 1045 1092 1060 1075 1043 171 187 9617 9618 9619 9474 9508 1093 1061 1080 1048 9571 9553 9559 9565 1081 1049 9488 9492 9524 9516 9500 9472 9532 1082 1050 9562 9556 9577 9574 9568 9552 9580 164 1083 1051 1084 1052 1085 1053 1086 1054 1087 9496 9484 9608 9604 1055 1103 9600 1071 1088 1056 1089 1057 1090 1058 1091 1059 1078 1046 1074 1042 1100 1068 8470 173 1099 1067 1079 1047 1096 1064 1101 1069 1097 1065 1095 1063 167 9632 160))) \r
+ (857 . ,(make-decoding-table '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 199 252 233 226 228 224 229 231 234 235 232 239 238 305 196 197 201 230 198 244 246 242 251 249 304 214 220 248 163 216 350 351 225 237 243 250 241 209 286 287 191 174 172 189 188 161 171 187 9617 9618 9619 9474 9508 193 194 192 169 9571 9553 9559 9565 162 165 9488 9492 9524 9516 9500 9472 9532 227 195 9562 9556 9577 9574 9568 9552 9580 164 186 170 202 203 200 65533 205 206 207 9496 9484 9608 9604 166 204 9600 211 223 212 210 245 213 181 65533 215 218 219 217 236 255 175 180 173 177 65533 190 182 167 247 184 176 168 183 185 179 178 9632 160))) \r
+ (860 . ,(make-decoding-table '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 199 252 233 226 227 224 193 231 234 202 232 205 212 236 195 194 201 192 200 244 245 242 218 249 204 213 220 162 163 217 8359 211 225 237 243 250 241 209 170 186 191 210 172 189 188 161 171 187 9617 9618 9619 9474 9508 9569 9570 9558 9557 9571 9553 9559 9565 9564 9563 9488 9492 9524 9516 9500 9472 9532 9566 9567 9562 9556 9577 9574 9568 9552 9580 9575 9576 9572 9573 9561 9560 9554 9555 9579 9578 9496 9484 9608 9604 9612 9616 9600 945 223 915 960 931 963 181 964 934 920 937 948 8734 966 949 8745 8801 177 8805 8804 8992 8993 247 8776 176 8729 183 8730 8319 178 9632 160))) \r
+ (861 . ,(make-decoding-table '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 199 252 233 226 228 224 229 231 234 235 232 208 240 222 196 197 201 230 198 244 246 254 251 221 253 214 220 248 163 216 8359 402 225 237 243 250 193 205 211 218 191 8976 172 189 188 161 171 187 9617 9618 9619 9474 9508 9569 9570 9558 9557 9571 9553 9559 9565 9564 9563 9488 9492 9524 9516 9500 9472 9532 9566 9567 9562 9556 9577 9574 9568 9552 9580 9575 9576 9572 9573 9561 9560 9554 9555 9579 9578 9496 9484 9608 9604 9612 9616 9600 945 223 915 960 931 963 181 964 934 920 937 948 8734 966 949 8745 8801 177 8805 8804 8992 8993 247 8776 176 8729 183 8730 8319 178 9632 160))) \r
+ (862 . ,(make-decoding-table '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 162 163 165 8359 402 225 237 243 250 241 209 170 186 191 8976 172 189 188 161 171 187 9617 9618 9619 9474 9508 9569 9570 9558 9557 9571 9553 9559 9565 9564 9563 9488 9492 9524 9516 9500 9472 9532 9566 9567 9562 9556 9577 9574 9568 9552 9580 9575 9576 9572 9573 9561 9560 9554 9555 9579 9578 9496 9484 9608 9604 9612 9616 9600 945 223 915 960 931 963 181 964 934 920 937 948 8734 966 949 8745 8801 177 8805 8804 8992 8993 247 8776 176 8729 183 8730 8319 178 9632 160))) \r
+ (863 . ,(make-decoding-table '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 199 252 233 226 194 224 182 231 234 235 232 239 238 8215 192 167 201 200 202 244 203 207 251 249 164 212 220 162 163 217 219 402 166 180 243 250 168 184 179 175 206 8976 172 189 188 190 171 187 9617 9618 9619 9474 9508 9569 9570 9558 9557 9571 9553 9559 9565 9564 9563 9488 9492 9524 9516 9500 9472 9532 9566 9567 9562 9556 9577 9574 9568 9552 9580 9575 9576 9572 9573 9561 9560 9554 9555 9579 9578 9496 9484 9608 9604 9612 9616 9600 945 223 915 960 931 963 181 964 934 920 937 948 8734 966 949 8745 8801 177 8805 8804 8992 8993 247 8776 176 8729 183 8730 8319 178 9632 160))) \r
+ (864 . ,(make-decoding-table '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 176 183 8729 8730 9618 9472 9474 9532 9508 9516 9500 9524 9488 9484 9492 9496 946 8734 966 177 189 188 8776 171 187 65271 65272 155 156 65275 65276 159 160 173 65154 163 164 65156 65533 65533 65166 65167 65173 65177 1548 65181 65185 65189 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 65233 1563 65201 65205 65209 1567 162 65152 65153 65155 65157 65226 65163 65165 65169 65171 65175 65179 65183 65187 65191 65193 65195 65197 65199 65203 65207 65211 65215 65217 65221 65227 65231 166 172 247 215 65225 1600 65235 65239 65243 65247 65251 65255 65259 65261 65263 65267 65213 65228 65230 65229 65249 65149 1617 65253 65257 65260 65264 65266 65232 65237 65269 65270 65245 65241 65265 9632 65533))) \r
+ (865 . ,(make-decoding-table '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 199 252 233 226 228 224 229 231 234 235 232 239 238 236 196 197 201 230 198 244 246 242 251 249 255 214 220 248 163 216 8359 402 225 237 243 250 241 209 170 186 191 8976 172 189 188 161 171 164 9617 9618 9619 9474 9508 9569 9570 9558 9557 9571 9553 9559 9565 9564 9563 9488 9492 9524 9516 9500 9472 9532 9566 9567 9562 9556 9577 9574 9568 9552 9580 9575 9576 9572 9573 9561 9560 9554 9555 9579 9578 9496 9484 9608 9604 9612 9616 9600 945 223 915 960 931 963 181 964 934 920 937 948 8734 966 949 8745 8801 177 8805 8804 8992 8993 247 8776 176 8729 183 8730 8319 178 9632 160))) \r
+ (866 . ,(make-decoding-table '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 9617 9618 9619 9474 9508 9569 9570 9558 9557 9571 9553 9559 9565 9564 9563 9488 9492 9524 9516 9500 9472 9532 9566 9567 9562 9556 9577 9574 9568 9552 9580 9575 9576 9572 9573 9561 9560 9554 9555 9579 9578 9496 9484 9608 9604 9612 9616 9600 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1025 1105 1028 1108 1031 1111 1038 1118 176 8729 183 8730 8470 164 9632 160))) \r
+ (869 . ,(make-decoding-table '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 902 135 183 172 166 8216 8217 904 8213 905 906 938 908 147 148 910 939 169 911 178 179 940 163 941 942 943 970 912 972 973 913 914 915 916 917 918 919 189 920 921 171 187 9617 9618 9619 9474 9508 922 923 924 925 9571 9553 9559 9565 926 927 9488 9492 9524 9516 9500 9472 9532 928 929 9562 9556 9577 9574 9568 9552 9580 931 932 933 934 935 936 937 945 946 947 9496 9484 9608 9604 948 949 9600 950 951 952 953 954 955 956 957 958 959 960 961 963 962 964 900 173 177 965 966 967 167 968 901 176 168 969 971 944 974 9632 160))) \r
+ (1250 . ,(make-decoding-table '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 8364 129 8218 131 8222 8230 8224 8225 136 8240 352 8249 346 356 381 377 144 8216 8217 8220 8221 8226 8211 8212 152 8482 353 8250 347 357 382 378 160 711 728 321 164 260 166 167 168 169 350 171 172 173 174 379 176 177 731 322 180 181 182 183 184 261 351 187 317 733 318 380 340 193 194 258 196 313 262 199 268 201 280 203 282 205 206 270 272 323 327 211 212 336 214 215 344 366 218 368 220 221 354 223 341 225 226 259 228 314 263 231 269 233 281 235 283 237 238 271 273 324 328 243 244 337 246 247 345 367 250 369 252 253 355 729))) \r
+ (1251 . ,(make-decoding-table '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 1026 1027 8218 1107 8222 8230 8224 8225 8364 8240 1033 8249 1034 1036 1035 1039 1106 8216 8217 8220 8221 8226 8211 8212 152 8482 1113 8250 1114 1116 1115 1119 160 1038 1118 1032 164 1168 166 167 1025 169 1028 171 172 173 174 1031 176 177 1030 1110 1169 181 182 183 1105 8470 1108 187 1112 1029 1109 1111 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103))) \r
+ (1252 . ,(make-decoding-table '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 8364 129 8218 402 8222 8230 8224 8225 710 8240 352 8249 338 141 381 143 144 8216 8217 8220 8221 8226 8211 8212 732 8482 353 8250 339 157 382 376 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255))) \r
+ (1253 . ,(make-decoding-table '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 8364 129 8218 402 8222 8230 8224 8225 136 8240 138 8249 140 141 142 143 144 8216 8217 8220 8221 8226 8211 8212 152 8482 154 8250 156 157 158 159 160 901 902 163 164 165 166 167 168 169 65533 171 172 173 174 8213 176 177 178 179 900 181 182 183 904 905 906 187 908 189 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 65533 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 65533))) \r
+ (1254 . ,(make-decoding-table '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 8364 129 8218 402 8222 8230 8224 8225 710 8240 352 8249 338 141 142 143 144 8216 8217 8220 8221 8226 8211 8212 732 8482 353 8250 339 157 158 376 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 286 209 210 211 212 213 214 215 216 217 218 219 220 304 350 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 287 241 242 243 244 245 246 247 248 249 250 251 252 305 351 255))) \r
+ (1255 . ,(make-decoding-table '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 8364 129 8218 402 8222 8230 8224 8225 710 8240 138 8249 140 141 142 143 144 8216 8217 8220 8221 8226 8211 8212 732 8482 154 8250 156 157 158 159 160 161 162 163 8362 165 166 167 168 169 215 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 247 187 188 189 190 191 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1520 1521 1522 1523 1524 65533 65533 65533 65533 65533 65533 65533 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 65533 65533 8206 8207 65533))) \r
+ (1256 . ,(make-decoding-table '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 8364 1662 8218 402 8222 8230 8224 8225 710 8240 1657 8249 338 1670 1688 1672 1711 8216 8217 8220 8221 8226 8211 8212 1705 8482 1681 8250 339 8204 8205 1722 160 1548 162 163 164 165 166 167 168 169 1726 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 1563 187 188 189 190 1567 1729 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 215 1591 1592 1593 1594 1600 1601 1602 1603 224 1604 226 1605 1606 1607 1608 231 232 233 234 235 1609 1610 238 239 1611 1612 1613 1614 244 1615 1616 247 1617 249 1618 251 252 8206 8207 1746))) \r
+ (1257 . ,(make-decoding-table '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 8364 129 8218 131 8222 8230 8224 8225 136 8240 138 8249 140 168 711 184 144 8216 8217 8220 8221 8226 8211 8212 152 8482 154 8250 156 175 731 159 160 65533 162 163 164 65533 166 167 216 169 342 171 172 173 174 198 176 177 178 179 180 181 182 183 248 185 343 187 188 189 190 230 260 302 256 262 196 197 280 274 268 201 377 278 290 310 298 315 352 323 325 211 332 213 214 215 370 321 346 362 220 379 381 223 261 303 257 263 228 229 281 275 269 233 378 279 291 311 299 316 353 324 326 243 333 245 246 247 371 322 347 363 252 380 382 729))) \r
+ (1258 . ,(make-decoding-table '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 8364 129 8218 402 8222 8230 8224 8225 710 8240 138 8249 338 141 142 143 144 8216 8217 8220 8221 8226 8211 8212 732 8482 154 8250 339 157 158 376 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 258 196 197 198 199 200 201 202 203 768 205 206 207 272 209 777 211 212 416 214 215 216 217 218 219 220 431 771 223 224 225 226 259 228 229 230 231 232 233 234 235 769 237 238 239 273 241 803 243 244 417 246 247 248 249 250 251 252 432 8363 255))))\r
+ "A list of 8-bit Windows code pages where each element is a\r
+cons with the car being the ID of the code page and the cdr being\r
+a vector enumerating the corresponding character codes.")\r
--- /dev/null
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: FLEXI-STREAMS; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/flexi-streams/conditions.lisp,v 1.9 2008/05/25 22:23:58 edi Exp $
+
+;;; Copyright (c) 2005-2008, Dr. Edmund Weitz. All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;; * Redistributions of source code must retain the above copyright
+;;; notice, this list of conditions and the following disclaimer.
+
+;;; * 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 BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; 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 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.
+
+(in-package :flexi-streams)
+
+(define-condition flexi-stream-error (stream-error)
+ ()
+ (:documentation "Superclass for all errors related to flexi
+streams."))
+
+(define-condition flexi-stream-simple-error (flexi-stream-error simple-condition)
+ ()
+ (:documentation "Like FLEXI-STREAM-ERROR but with formatting
+capabilities."))
+
+(define-condition flexi-stream-element-type-error (flexi-stream-error)
+ ((element-type :initarg :element-type
+ :reader flexi-stream-element-type-error-element-type))
+ (:report (lambda (condition stream)
+ (format stream "Element type ~S not allowed."
+ (flexi-stream-element-type-error-element-type condition))))
+ (:documentation "Errors of this type are signalled if the flexi
+stream has a wrong element type."))
+
+(define-condition flexi-stream-out-of-sync-error (flexi-stream-error)
+ ()
+ (:report (lambda (condition stream)
+ (declare (ignore condition))
+ (format stream "Stream out of sync from previous
+lookahead, couldn't rewind.")))
+ (:documentation "This can happen if you're trying to write to an IO
+stream which had prior to that `looked ahead' while reading and now
+can't `rewind' to the octet where you /should/ be."))
+
+(define-condition in-memory-stream-error (stream-error)
+ ()
+ (:documentation "Superclass for all errors related to
+IN-MEMORY streams."))
+
+(define-condition in-memory-stream-simple-error (in-memory-stream-error simple-condition)
+ ()
+ (:documentation "Like IN-MEMORY-STREAM-ERROR but with formatting
+capabilities."))
+
+(define-condition in-memory-stream-closed-error (in-memory-stream-error)
+ ()
+ (:report (lambda (condition stream)
+ (format stream "~S is closed."
+ (stream-error-stream condition))))
+ (:documentation "An error that is signalled when someone is trying
+to read from or write to a closed IN-MEMORY stream."))
+
+(define-condition in-memory-stream-position-spec-error (in-memory-stream-simple-error)
+ ((position-spec :initarg :position-spec
+ :reader in-memory-stream-position-spec-error-position-spec))
+ (:documentation "Errors of this type are signalled if an erroneous
+position spec is used in conjunction with FILE-POSITION."))
+
+(define-condition external-format-condition (simple-condition)
+ ((external-format :initarg :external-format
+ :initform nil
+ :reader external-format-condition-external-format))
+ (:documentation "Superclass for all conditions related to external
+formats."))
+
+(define-condition external-format-error (external-format-condition error)
+ ()
+ (:documentation "Superclass for all errors related to external
+formats."))
+
+(define-condition external-format-encoding-error (external-format-error)
+ ()
+ (:documentation "Errors of this type are signalled if there is an
+encoding problem."))
+
+(defun signal-encoding-error (external-format format-control &rest format-args)
+ "Convenience function similar to ERROR to signal conditions of type
+EXTERNAL-FORMAT-ENCODING-ERROR."
+ (error 'external-format-encoding-error
+ :format-control format-control
+ :format-arguments format-args
+ :external-format external-format))
--- /dev/null
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: FLEXI-STREAMS; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/flexi-streams/decode.lisp,v 1.35 2008/08/26 10:59:22 edi Exp $
+
+;;; Copyright (c) 2005-2008, Dr. Edmund Weitz. All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;; * Redistributions of source code must retain the above copyright
+;;; notice, this list of conditions and the following disclaimer.
+
+;;; * 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 BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; 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 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.
+
+(in-package :flexi-streams)
+
+(defun recover-from-encoding-error (external-format format-control &rest format-args)
+ "Helper function used by OCTETS-TO-CHAR-CODE below to deal with
+encoding errors. Checks if *SUBSTITUTION-CHAR* is not NIL and returns
+its character code in this case. Otherwise signals an
+EXTERNAL-FORMAT-ENCODING-ERROR as determined by the arguments to this
+function and provides a corresponding USE-VALUE restart."
+ (when *substitution-char*
+ (return-from recover-from-encoding-error (char-code *substitution-char*)))
+ (restart-case
+ (apply #'signal-encoding-error external-format format-control format-args)
+ (use-value (char)
+ :report "Specify a character to be used instead."
+ :interactive (lambda ()
+ (loop
+ (format *query-io* "Type a character: ")
+ (let ((line (read-line *query-io*)))
+ (when (= 1 (length line))
+ (return (list (char line 0)))))))
+ (char-code char))))
+
+(defgeneric octets-to-char-code (format reader)
+ (declare #.*standard-optimize-settings*)
+ (:documentation "Converts a sequence of octets to a character code
+\(which is returned, or NIL in case of EOF) using the external format
+FORMAT. The sequence is obtained by calling the function \(which must
+be a functional object) READER with no arguments which should return
+one octet per call. In the case of EOF, READER should return NIL.
+
+The special variable *CURRENT-UNREADER* must be bound correctly
+whenever this function is called."))
+
+(defgeneric octets-to-string* (format sequence start end)
+ (declare #.*standard-optimize-settings*)
+ (:documentation "A generic function which dispatches on the external
+format and does the real work for OCTETS-TO-STRING."))
+
+(defmethod octets-to-string* :around (format (list list) start end)
+ (declare #.*standard-optimize-settings*)
+ (octets-to-string* format (coerce list 'vector) start end))
+
+(defmacro define-sequence-readers ((format-class) &body body)
+ "Non-hygienic utility macro which defines methods for READ-SEQUENCE*
+and OCTETS-TO-STRING* for the class FORMAT-CLASS. BODY is described
+in the docstring of DEFINE-CHAR-ENCODERS but can additionally contain
+a form \(UNGET <form>) which has to be replaced by the correct code to
+`unread' the octets for the character designated by <form>."
+ (let* ((body `((block char-decoder
+ (locally
+ (declare #.*fixnum-optimize-settings*)
+ ,@body)))))
+ `(progn
+ (defmethod read-sequence* ((format ,format-class) flexi-input-stream sequence start end)
+ (with-accessors ((position flexi-stream-position)
+ (bound flexi-stream-bound)
+ (octet-stack flexi-stream-octet-stack)
+ (last-octet flexi-stream-last-octet)
+ (last-char-code flexi-stream-last-char-code)
+ (stream flexi-stream-stream))
+ flexi-input-stream
+ (let* (buffer
+ (buffer-pos 0)
+ (buffer-end 0)
+ (index start)
+ donep
+ ;; whether we will later be able to rewind the stream if
+ ;; needed (to get rid of unused octets in the buffer)
+ (can-rewind-p (maybe-rewind stream 0))
+ (factor (encoding-factor format))
+ (integer-factor (floor factor))
+ ;; it's an interesting question whether it makes sense
+ ;; performance-wise to make RESERVE significantly bigger
+ ;; (and thus put potentially a lot more octets into
+ ;; OCTET-STACK), especially for UTF-8
+ (reserve (cond ((or (not (floatp factor))
+ (not can-rewind-p)) 0)
+ (t (ceiling (* (- factor integer-factor) (- end start)))))))
+ (declare (fixnum buffer-pos buffer-end index integer-factor reserve)
+ (boolean can-rewind-p))
+ (flet ((compute-fill-amount ()
+ "Computes the amount of octets we can savely read into
+the buffer without violating the stream's bound \(if there is one) and
+without potentially reading much more than we need \(unless we can
+rewind afterwards)."
+ (let ((minimum (min (the fixnum (+ (the fixnum (* integer-factor
+ (the fixnum (- end index))))
+ reserve))
+ +buffer-size+)))
+ (cond (bound (min minimum (- bound position)))
+ (t minimum))))
+ (fill-buffer (end)
+ "Tries to fill the buffer from BUFFER-POS to END and
+returns NIL if the buffer doesn't contain any new data."
+ (when donep
+ (return-from fill-buffer nil))
+ ;; put data from octet stack into buffer if there is any
+ (loop
+ (when (>= buffer-pos end)
+ (return))
+ (let ((next-octet (pop octet-stack)))
+ (cond (next-octet
+ (setf (aref (the (array octet *) buffer) buffer-pos) (the octet next-octet))
+ (incf buffer-pos))
+ (t (return)))))
+ (setq buffer-end (read-sequence buffer stream
+ :start buffer-pos
+ :end end))
+ ;; we reached EOF, so we remember this
+ (when (< buffer-end end)
+ (setq donep t))
+ ;; BUFFER-POS is only greater than zero if the buffer
+ ;; already contains unread data from the octet stack
+ ;; (see below), so we test for ZEROP here and do /not/
+ ;; compare with BUFFER-POS
+ (unless (zerop buffer-end)
+ (incf position buffer-end))))
+ (let ((minimum (compute-fill-amount)))
+ (declare (fixnum minimum))
+ (setq buffer (make-octet-buffer minimum))
+ ;; fill buffer for the first time or return immediately if
+ ;; we don't succeed
+ (unless (fill-buffer minimum)
+ (return-from read-sequence* start)))
+ (setq buffer-pos 0)
+ (macrolet ((iterate (set-place)
+ "A very unhygienic macro to implement the
+actual iteration through the sequence including housekeeping for the
+flexi stream. SET-PLACE is the place \(using the index INDEX) used to
+access the sequence."
+ `(flet ((leave ()
+ "This is the function used to
+abort the LOOP iteration below."
+ (when (> index start)
+ (setq last-octet nil
+ last-char-code ,(sublis '((index . (1- index))) set-place)))
+ (return-from read-sequence* index)))
+ (loop
+ (when (>= index end)
+ ;; check if there are octets in the
+ ;; buffer we didn't use - see
+ ;; COMPUTE-FILL-AMOUNT above
+ (let ((rest (- buffer-end buffer-pos)))
+ (when (plusp rest)
+ (or (and can-rewind-p
+ (maybe-rewind stream rest))
+ (loop
+ (when (>= buffer-pos buffer-end)
+ (return))
+ (decf buffer-end)
+ (push (aref (the (array octet *) buffer) buffer-end)
+ octet-stack)))))
+ (leave))
+ (let ((next-char-code
+ (progn (symbol-macrolet
+ ((octet-getter
+ ;; this is the code to retrieve the next octet (or
+ ;; NIL) and to fill the buffer if needed
+ (block next-octet
+ (when (>= buffer-pos buffer-end)
+ (setq buffer-pos 0)
+ (unless (fill-buffer (compute-fill-amount))
+ (return-from next-octet)))
+ (prog1
+ (aref (the (array octet *) buffer) buffer-pos)
+ (incf buffer-pos)))))
+ (macrolet ((unget (form)
+ `(unread-char% ,form flexi-input-stream)))
+ ,',@body)))))
+ (unless next-char-code
+ (leave))
+ (setf ,set-place (code-char next-char-code))
+ (incf index))))))
+ (etypecase sequence
+ (string (iterate (char sequence index)))
+ (array (iterate (aref sequence index)))
+ (list (iterate (nth index sequence)))))))))
+ (defmethod octets-to-string* ((format ,format-class) sequence start end)
+ (declare #.*standard-optimize-settings*)
+ (declare (fixnum start end))
+ (let* ((i start)
+ (string-length (compute-number-of-chars format sequence start end))
+ (string (make-array string-length :element-type 'char*)))
+ (declare (fixnum i string-length))
+ (loop for j of-type fixnum from 0 below string-length
+ do (setf (schar string j)
+ (code-char (macrolet ((unget (form)
+ `(decf i (character-length format ,form))))
+ ;; we don't need to test for
+ ;; the end of SEQUENCE as the
+ ;; computation has been done
+ ;; for us already
+ (symbol-macrolet ((octet-getter (prog1
+ (aref sequence i)
+ (incf i))))
+ ,@body))))
+ finally (return string)))))))
+
+(defmacro define-char-decoders ((lf-format-class cr-format-class crlf-format-class) &body body)
+ "Non-hygienic utility macro which defines several decoding-related
+methods for the classes LF-FORMAT-CLASS, CR-FORMAT-CLASS, and
+CRLF-FORMAT-CLASS where it is assumed that CR-FORMAT-CLASS is the same
+encoding as LF-FORMAT-CLASS but with CR instead of LF line endings and
+similar for CRLF-FORMAT-CLASS, i.e. LF-FORMAT-CLASS is the base class.
+BODY is a code template for the code to read octets and return one
+character code. BODY must contain a symbol OCTET-GETTER representing
+the form which is used to obtain the next octet."
+ (let* ((body (with-unique-names (char-code)
+ `((let ((,char-code (progn ,@body)))
+ (when (and ,char-code
+ (or (<= #xd8 (logand* #x00ff (ash* ,char-code -8)) #xdf)
+ (> ,char-code #x10ffff)))
+ (recover-from-encoding-error format "Illegal code point ~A \(#x~:*~X)." ,char-code))
+ ,char-code)))))
+ `(progn
+ (defmethod octets-to-char-code ((format ,lf-format-class) reader)
+ (declare #.*fixnum-optimize-settings*)
+ (declare (function reader))
+ (symbol-macrolet ((octet-getter (funcall reader)))
+ ,@(sublis '((char-decoder . octets-to-char-code))
+ body)))
+ (define-sequence-readers (,lf-format-class) ,@body)
+ (define-sequence-readers (,cr-format-class)
+ ,(with-unique-names (char-code)
+ `(let ((,char-code (progn ,@body)))
+ (case ,char-code
+ (#.+cr+ #.(char-code #\Newline))
+ (otherwise ,char-code)))))
+ (define-sequence-readers (,crlf-format-class)
+ ,(with-unique-names (char-code next-char-code get-char-code)
+ `(flet ((,get-char-code () ,@body))
+ (let ((,char-code (,get-char-code)))
+ (case ,char-code
+ (#.+cr+
+ (let ((,next-char-code (,get-char-code)))
+ (case ,next-char-code
+ (#.+lf+ #.(char-code #\Newline))
+ ;; we saw a CR but no LF afterwards, but then the data
+ ;; ended, so we just return #\Return
+ ((nil) +cr+)
+ ;; if the character we peeked at wasn't a
+ ;; linefeed character we unread its constituents
+ (otherwise (unget (code-char ,next-char-code))
+ ,char-code))))
+ (otherwise ,char-code)))))))))
+
+(define-char-decoders (flexi-latin-1-format flexi-cr-latin-1-format flexi-crlf-latin-1-format)
+ octet-getter)
+
+(define-char-decoders (flexi-ascii-format flexi-cr-ascii-format flexi-crlf-ascii-format)
+ (when-let (octet octet-getter)
+ (if (> (the octet octet) 127)
+ (recover-from-encoding-error format
+ "No character which corresponds to octet #x~X." octet)
+ octet)))
+
+(define-char-decoders (flexi-8-bit-format flexi-cr-8-bit-format flexi-crlf-8-bit-format)
+ (with-accessors ((decoding-table external-format-decoding-table))
+ format
+ (when-let (octet octet-getter)
+ (let ((char-code (aref (the (simple-array char-code-integer *) decoding-table)
+ (the octet octet))))
+ (if (or (null char-code)
+ (= (the char-code-integer char-code) 65533))
+ (recover-from-encoding-error format
+ "No character which corresponds to octet #x~X." octet)
+ char-code)))))
+
+(define-char-decoders (flexi-utf-8-format flexi-cr-utf-8-format flexi-crlf-utf-8-format)
+ (let (first-octet-seen)
+ (declare (boolean first-octet-seen))
+ (macrolet ((read-next-byte ()
+ '(prog1
+ (or octet-getter
+ (cond (first-octet-seen
+ (return-from char-decoder
+ (recover-from-encoding-error format
+ "End of data while in UTF-8 sequence.")))
+ (t (return-from char-decoder nil))))
+ (setq first-octet-seen t))))
+ (flet ((recover-from-overlong-sequence (value)
+ (restart-case
+ (recover-from-encoding-error format "`Overlong' UTF-8 sequence for code point #x~X."
+ value)
+ (accept-overlong-sequence ()
+ :report "Accept the code point and continue."
+ value))))
+ (let ((octet (read-next-byte)))
+ (declare (type octet octet))
+ (block utf-8-sequence
+ (multiple-value-bind (start count)
+ (cond ((not (logbitp 7 octet))
+ ;; avoid the overlong checks below
+ (return-from utf-8-sequence octet))
+ ((= #b11000000 (logand* octet #b11100000))
+ (values (logand* octet #b00011111) 1))
+ ((= #b11100000 (logand* octet #b11110000))
+ (values (logand* octet #b00001111) 2))
+ ((= #b11110000 (logand* octet #b11111000))
+ (values (logand* octet #b00000111) 3))
+ (t (return-from char-decoder
+ (recover-from-encoding-error format
+ "Unexpected value #x~X at start of UTF-8 sequence."
+ octet))))
+ (declare (fixnum count))
+ (loop for result of-type code-point
+ = start then (+ (ash* result 6)
+ (logand* octet #b111111))
+ repeat count
+ for octet of-type octet = (read-next-byte)
+ unless (= #b10000000 (logand* octet #b11000000))
+ do (return-from char-decoder
+ (recover-from-encoding-error format
+ "Unexpected value #x~X in UTF-8 sequence." octet))
+ finally (return (cond ((< result (ecase count
+ (1 #x00080)
+ (2 #x00800)
+ (3 #x10000)))
+ (recover-from-overlong-sequence result))
+ (t result)))))))))))
+
+(define-char-decoders (flexi-utf-16-le-format flexi-cr-utf-16-le-format flexi-crlf-utf-16-le-format)
+ (let (first-octet-seen)
+ (declare (boolean first-octet-seen))
+ (macrolet ((read-next-byte ()
+ '(prog1
+ (or octet-getter
+ (cond (first-octet-seen
+ (return-from char-decoder
+ (recover-from-encoding-error format
+ "End of data while in UTF-16 sequence.")))
+ (t (return-from char-decoder nil))))
+ (setq first-octet-seen t))))
+ (flet ((read-next-word ()
+ (+ (the octet (read-next-byte))
+ (ash* (the octet (read-next-byte)) 8))))
+ (declare (inline read-next-word))
+ (let ((word (read-next-word)))
+ (declare (type (unsigned-byte 16) word))
+ (cond ((<= #xd800 word #xdfff)
+ (let ((next-word (read-next-word)))
+ (declare (type (unsigned-byte 16) next-word))
+ (unless (<= #xdc00 next-word #xdfff)
+ (return-from char-decoder
+ (recover-from-encoding-error format
+ "Unexpected UTF-16 word #x~X following #x~X."
+ next-word word)))
+ (+ (ash* (logand* #b1111111111 word) 10)
+ (logand* #b1111111111 next-word)
+ #x10000)))
+ (t word)))))))
+
+(define-char-decoders (flexi-utf-16-be-format flexi-cr-utf-16-be-format flexi-crlf-utf-16-be-format)
+ (let (first-octet-seen)
+ (declare (boolean first-octet-seen))
+ (macrolet ((read-next-byte ()
+ '(prog1
+ (or octet-getter
+ (cond (first-octet-seen
+ (return-from char-decoder
+ (recover-from-encoding-error format
+ "End of data while in UTF-16 sequence.")))
+ (t (return-from char-decoder nil))))
+ (setq first-octet-seen t))))
+ (flet ((read-next-word ()
+ (+ (ash* (the octet (read-next-byte)) 8)
+ (the octet (read-next-byte)))))
+ (declare (inline read-next-word))
+ (let ((word (read-next-word)))
+ (declare (type (unsigned-byte 16) word))
+ (cond ((<= #xd800 word #xdfff)
+ (let ((next-word (read-next-word)))
+ (declare (type (unsigned-byte 16) next-word))
+ (unless (<= #xdc00 next-word #xdfff)
+ (return-from char-decoder
+ (recover-from-encoding-error format
+ "Unexpected UTF-16 word #x~X following #x~X."
+ next-word word)))
+ (+ (ash* (logand* #b1111111111 word) 10)
+ (logand* #b1111111111 next-word)
+ #x10000)))
+ (t word)))))))
+
+(define-char-decoders (flexi-utf-32-le-format flexi-cr-utf-32-le-format flexi-crlf-utf-32-le-format)
+ (let (first-octet-seen)
+ (declare (boolean first-octet-seen))
+ (macrolet ((read-next-byte ()
+ '(prog1
+ (or octet-getter
+ (cond (first-octet-seen
+ (return-from char-decoder
+ (recover-from-encoding-error format
+ "End of data while in UTF-32 sequence.")))
+ (t (return-from char-decoder nil))))
+ (setq first-octet-seen t))))
+ (loop for count of-type fixnum from 0 to 24 by 8
+ for octet of-type octet = (read-next-byte)
+ sum (ash* octet count)))))
+
+(define-char-decoders (flexi-utf-32-be-format flexi-cr-utf-32-be-format flexi-crlf-utf-32-be-format)
+ (let (first-octet-seen)
+ (declare (boolean first-octet-seen))
+ (macrolet ((read-next-byte ()
+ '(prog1
+ (or octet-getter
+ (cond (first-octet-seen
+ (return-from char-decoder
+ (recover-from-encoding-error format
+ "End of data while in UTF-32 sequence.")))
+ (t (return-from char-decoder nil))))
+ (setq first-octet-seen t))))
+ (loop for count of-type fixnum from 24 downto 0 by 8
+ for octet of-type octet = (read-next-byte)
+ sum (ash* octet count)))))
+
+(defmethod octets-to-char-code ((format flexi-cr-mixin) reader)
+ (declare #.*fixnum-optimize-settings*)
+ (declare (ignore reader))
+ (let ((char-code (call-next-method)))
+ (case char-code
+ (#.+cr+ #.(char-code #\Newline))
+ (otherwise char-code))))
+
+(defmethod octets-to-char-code ((format flexi-crlf-mixin) reader)
+ (declare #.*fixnum-optimize-settings*)
+ (declare (function *current-unreader*))
+ (declare (ignore reader))
+ (let ((char-code (call-next-method)))
+ (case char-code
+ (#.+cr+
+ (let ((next-char-code (call-next-method)))
+ (case next-char-code
+ (#.+lf+ #.(char-code #\Newline))
+ ;; we saw a CR but no LF afterwards, but then the data
+ ;; ended, so we just return #\Return
+ ((nil) +cr+)
+ ;; if the character we peeked at wasn't a
+ ;; linefeed character we unread its constituents
+ (otherwise (funcall *current-unreader* (code-char next-char-code))
+ char-code))))
+ (otherwise char-code))))
+
--- /dev/null
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN">
+<html>
+
+<head>
+ <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
+ <title>FLEXI-STREAMS - Flexible bivalent streams for Common Lisp</title>
+ <style type="text/css">
+ pre { padding:5px; background-color:#e0e0e0 }
+ h3, h4 { text-decoration: underline; }
+ a { text-decoration: none; padding: 1px 2px 1px 2px; }
+ a:visited { text-decoration: none; padding: 1px 2px 1px 2px; }
+ a:hover { text-decoration: none; padding: 1px 1px 1px 1px; border: 1px solid #000000; }
+ a:focus { text-decoration: none; padding: 1px 2px 1px 2px; border: none; }
+ a.none { text-decoration: none; padding: 0; }
+ a.none:visited { text-decoration: none; padding: 0; }
+ a.none:hover { text-decoration: none; border: none; padding: 0; }
+ a.none:focus { text-decoration: none; border: none; padding: 0; }
+ a.noborder { text-decoration: none; padding: 0; }
+ a.noborder:visited { text-decoration: none; padding: 0; }
+ a.noborder:hover { text-decoration: none; border: none; padding: 0; }
+ a.noborder:focus { text-decoration: none; border: none; padding: 0; }
+ </style>
+</head>
+
+<body bgcolor=white>
+
+<h2>FLEXI-STREAMS - Flexible bivalent streams for Common Lisp</h2>
+
+<blockquote>
+<br> <br><h3><a name=abstract class=none>Abstract</a></h3>
+
+FLEXI-STREAMS implements "virtual" bivalent streams that can be
+layered atop real binary or bivalent streams and that can be used to
+read and write character data in various single- or multi-octet
+encodings which can be changed on the fly. It also supplies
+<em>in-memory</em> binary streams which are similar to string streams.
+<p>
+The library needs a Common Lisp implementation that
+supports <a
+href="http://www.nhplace.com/kent/CL/Issues/stream-definition-by-user.html"><em>Gray
+streams</em></a> and relies on David
+Lichteblau's <a
+href="http://www.cliki.net/trivial-gray-streams">trivial-gray-streams</a>
+to offer portability between different Lisps.
+<p>
+The code comes with
+a <a
+href="http://www.opensource.org/licenses/bsd-license.php">BSD-style
+license</a> so you can basically do with it whatever you want.
+
+<p>
+<font color=red>Download shortcut:</font> <a href="http://weitz.de/files/flexi-streams.tar.gz">http://weitz.de/files/flexi-streams.tar.gz</a>.
+</blockquote>
+
+<br> <br><h3><a class=none name="contents">Contents</a></h3>
+<ol>
+ <li><a href="#example">Example usage</a>
+ <li><a href="#install">Download and installation</a>
+ <li><a href="#support">Support</a>
+ <li><a href="#dictionary">The FLEXI-STREAMS dictionary</a>
+ <ol>
+ <li><a href="#external-formats">External formats</a>
+ <ol>
+ <li><a href="#make-external-format"><code>make-external-format</code></a>
+ <li><a href="#external-format-name"><code>external-format-name</code></a>
+ <li><a href="#external-format-eol-style"><code>external-format-eol-style</code></a>
+ <li><a href="#external-format-little-endian"><code>external-format-little-endian</code></a>
+ <li><a href="#external-format-id"><code>external-format-id</code></a>
+ <li><a href="#external-format-equal"><code>external-format-equal</code></a>
+ <li><a href="#*default-eol-style*"><code>*default-eol-style*</code></a>
+ <li><a href="#*default-little-endian*"><code>*default-little-endian*</code></a>
+ <li><a href="#external-format-condition"><code>external-format-condition</code></a>
+ <li><a href="#external-format-condition-external-format"><code>external-format-condition-external-format</code></a>
+ <li><a href="#external-format-error"><code>external-format-error</code></a>
+ <li><a href="#external-format-encoding-error"><code>external-format-encoding-error</code></a>
+ <li><a href="#*substitution-char*"><code>*substitution-char*</code></a>
+ <li><a href="#accept-overlong-sequence"><code>accept-overlong-sequence</code></a>
+ </ol>
+ <li><a href="#flexi-streams">Flexi streams</a>
+ <ol>
+ <li><a href="#flexi-stream"><code>flexi-stream</code></a>
+ <li><a href="#flexi-input-stream"><code>flexi-input-stream</code></a>
+ <li><a href="#flexi-output-stream"><code>flexi-output-stream</code></a>
+ <li><a href="#flexi-io-stream"><code>flexi-io-stream</code></a>
+ <li><a href="#make-flexi-stream"><code>make-flexi-stream</code></a>
+ <li><a href="#flexi-stream-external-format"><code>flexi-stream-external-format</code></a>
+ <li><a href="#flexi-stream-element-type"><code>flexi-stream-element-type</code></a>
+ <li><a href="#flexi-stream-column"><code>flexi-stream-column</code></a>
+ <li><a href="#flexi-stream-position"><code>flexi-stream-position</code></a>
+ <li><a href="#flexi-stream-bound"><code>flexi-stream-bound</code></a>
+ <li><a href="#flexi-stream-stream"><code>flexi-stream-stream</code></a>
+ <li><a href="#unread-byte"><code>unread-byte</code></a>
+ <li><a href="#peek-byte"><code>peek-byte</code></a>
+ <li><a href="#octet"><code>octet</code></a>
+ <li><a href="#flexi-stream-error"><code>flexi-stream-error</code></a>
+ <li><a href="#flexi-stream-out-of-sync-error"><code>flexi-stream-out-of-sync-error</code></a>
+ <li><a href="#flexi-stream-element-type-error"><code>flexi-stream-element-type-error</code></a>
+ <li><a href="#flexi-stream-element-type-error-element-type"><code>flexi-stream-element-type-error-element-type</code></a>
+ </ol>
+ <li><a href="#in-memory">In-memory streams</a>
+ <ol>
+ <li><a href="#in-memory-stream"><code>in-memory-stream</code></a>
+ <li><a href="#in-memory-input-stream"><code>in-memory-input-stream</code></a>
+ <li><a href="#in-memory-output-stream"><code>in-memory-output-stream</code></a>
+ <li><a href="#list-stream"><code>list-stream</code></a>
+ <li><a href="#vector-stream"><code>vector-stream</code></a>
+ <li><a href="#make-in-memory-input-stream"><code>make-in-memory-input-stream</code></a>
+ <li><a href="#make-in-memory-output-stream"><code>make-in-memory-output-stream</code></a>
+ <li><a href="#get-output-stream-sequence"><code>get-output-stream-sequence</code></a>
+ <li><a href="#output-stream-sequence-length"><code>output-stream-sequence-length</code></a>
+ <li><a href="#with-input-from-sequence"><code>with-input-from-sequence</code></a>
+ <li><a href="#with-output-to-sequence"><code>with-output-to-sequence</code></a>
+ <li><a href="#in-memory-stream-error"><code>in-memory-stream-error</code></a>
+ <li><a href="#in-memory-stream-closed-error"><code>in-memory-stream-closed-error</code></a>
+ <li><a href="#in-memory-stream-position-spec-error"><code>in-memory-stream-position-spec-error</code></a>
+ <li><a href="#in-memory-stream-position-spec-error-position-spec"><code>in-memory-stream-position-spec-error-position-spec</code></a>
+ </ol>
+ <li><a href="#strings">Strings</a>
+ <ol>
+ <li><a href="#string-to-octets"><code>string-to-octets</code></a>
+ <li><a href="#octets-to-string"><code>octets-to-string</code></a>
+ <li><a href="#octet-length"><code>octet-length</code></a>
+ <li><a href="#char-length"><code>char-length</code></a>
+ </ol>
+ </ol>
+ <li><a href="#position">File positions</a>
+ <li><a href="#ack">Acknowledgements</a>
+</ol>
+
+<br> <br><h3><a name="example" class=none>Example usage</a></h3>
+
+The examples were created with <a href="http://www.lispworks.com/">LispWorks</a> 4.4.6 pro on Windows. The following two functions create <a href="foo.txt">the same file</a>:
+
+<pre>
+(defun foo (pathspec)
+ "With standard LispWorks streams."
+ (with-open-file (out pathspec
+ :direction :output
+ :if-exists :supersede
+ :external-format '(:utf-8 :eol-style :crlf))
+ (write-line "ÄÖÜ1" out))
+ (with-open-file (out pathspec
+ :direction :output
+ :if-exists :append
+ :external-format '(:latin-1 :eol-style :lf))
+ (write-line "ÄÖÜ2" out))
+ (with-open-file (out pathspec
+ :direction :output
+ :if-exists :append
+ :element-type 'octet)
+ (write-byte #xeb out)
+ (write-sequence #(#xa3 #xa4 #xa5) out))
+ (with-open-file (out pathspec
+ :direction :output
+ :if-exists :append
+ :external-format '(:unicode :little-endian nil :eol-style :crlf))
+ (write-line "ÄÖÜ3" out)))
+
+(defun bar (pathspec)
+ "With a <a href="#flexi-streams" class=noborder>flexi stream</a>."
+ (with-open-file (out pathspec
+ :direction :output
+ :if-exists :supersede
+ :external-format '(:latin-1 :eol-style :lf))
+ (setq out (<a href="#make-flexi-stream" class=noborder>make-flexi-stream</a> out <a href="#external-formats" class=noborder>:external-format</a> :utf-8))
+ (write-line "ÄÖÜ1" out)
+ (setf (<a href="#flexi-stream-external-format" class=noborder>flexi-stream-external-format</a> out) '(:latin-1 :eol-style :lf))
+ (write-line "ÄÖÜ2" out)
+ (write-byte #xeb out)
+ (write-sequence #(#xa3 #xa4 #xa5) out)
+ (setf (flexi-stream-external-format out) :ucs-2be)
+ (write-line "ÄÖÜ3" out)))
+</pre>
+
+<p>
+And applying this function
+<pre>
+(defun baz (pathspec)
+ (let (result)
+ (with-open-file (in pathspec :element-type '<a href="#octet" class=noborder>octet</a>)
+ (setq in (<a href="#make-flexi-stream" class=noborder>make-flexi-stream</a> in <a href="#external-formats" class=noborder>:external-format</a> :utf-8))
+ (push (read-line in) result)
+ (push (read-byte in) result)
+ (setf (<a href="#flexi-stream-external-format" class=noborder>flexi-stream-external-format</a> in) '(:latin-1 :eol-style :lf))
+ (push (read-line in) result)
+ (setf (flexi-stream-external-format in) :greek)
+ (push (read-char in) result)
+ (setf (flexi-stream-external-format in) :latin0)
+ (let ((string (make-string 3 :element-type 'character)))
+ (read-sequence string in)
+ (push string result))
+ (let ((octets (make-array 2 :element-type 'octet)))
+ (read-sequence octets in)
+ (push octets result))
+ (setf (flexi-stream-external-format in) :ucs-2be)
+ (push (read-line in) result))
+ (nreverse result)))
+</pre>
+to the file created above will yield the list
+<pre>
+("ÄÖÜ1" 196 "ÖÜ2" #\λ "£€¥" #(0 196) "ÖÜ3")
+</pre>
+
+<p>
+For more examples see the source code
+of
+<a href="http://mr-co.de/projects/cl-rfc2047/">CL-RFC2047</a>,
+<a
+href="http://weitz.de/drakma/">Drakma</a>, <a
+href="http://weitz.de/chunga/">Chunga</a>,
+or <a href="http://weitz.de/cl-wbxml/">CL-WBXML</a>.
+
+<br> <br><h3><a name="install" class=none>Download and installation</a></h3>
+
+Before you try to install FLEXI-STREAMS, first check that in your Lisp
+each <a
+href="http://www.lispworks.com/documentation/HyperSpec/Body/13_.htm">character</a>'s
+<a
+href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_c.htm#character_code">character
+code</a> is equal to
+its <a
+href="http://en.wikipedia.org/wiki/Unicode">Unicode</a> <a
+href="http://unicode.org/glossary/">code point</a> and
+that <code>(CHAR-CODE #\Newline)</code>
+and <code>(CHAR-CODE #\Linefeed)</code> have the same
+value (10). (This is the case for all relevant CL
+implementations which were in use when this library was written. It
+is <em>not</em> mandated by the ANSI standard, though.)
+<p>
+FLEXI-STREAMS together with this documentation can be downloaded from <a
+href="http://weitz.de/files/flexi-streams.tar.gz">http://weitz.de/files/flexi-streams.tar.gz</a>. The
+current version is 1.0.12.
+<p>
+Before you install FLEXI-STREAMS you first need to
+install the <a
+href="http://www.cliki.net/trivial-gray-streams">trivial-gray-streams</a> library
+unless you already have it.
+<p>
+FLEXI-STREAMS comes with a system definition for <a
+href="http://www.cliki.net/asdf">ASDF</a> so you can install the library with
+<pre>
+(asdf:oos 'asdf:load-op :flexi-streams)
+</pre>
+if you've unpacked it in a place where ASDF can find it. Installation
+via <a href="http://www.cliki.net/asdf-install">asdf-install</a>
+should also be possible, and there's a port
+to <a href="http://www.cliki.net/Gentoo">Gentoo Lisp</a> thanks to
+Matthew Kennedy.
+<p>
+You can run a test suite which tests <em>some</em> (but
+not <em>all</em>) aspects of the library with
+<pre>
+(asdf:oos 'asdf:test-op :flexi-streams)
+</pre>
+This might take a while...
+<p>
+The current development version of FLEXI-STREAMS can be found
+at <a href="http://bknr.net/trac/browser/trunk/thirdparty">http://bknr.net/trac/browser/trunk/thirdparty</a>.
+This is the one to send <a href="#mail">patches</a> against. Use at
+your own risk.
+<p>
+Luís Oliveira maintains a <a href="http://darcs.net/">darcs</a>
+repository of FLEXI-STREAMS
+at <a href="http://common-lisp.net/%7Eloliveira/ediware/">http://common-lisp.net/~loliveira/ediware/</a>.
+<p>
+A <a href="http://www.selenic.com/mercurial/wiki/">Mercurial</a>
+repository of older versions is available
+at <a
+href="http://arcanes.fr.eu.org/~pierre/2007/02/weitz/">http://arcanes.fr.eu.org/~pierre/2007/02/weitz/</a>
+thanks to Pierre Thierry.
+
+<br> <br><h3><a name="support" class=none>Support</a></h3>
+
+The development version of flexi-streams can be
+found <a href="https://github.com/edicl/flexi-streams" target="_new">on
+github</a>. Please use the github issue tracking system to submit bug
+reports. Patches are welcome, please
+use <a href="https://github.com/edicl/flexi-streams/pulls">GitHub pull
+requests</a>. If you want to make a change,
+please <a href="http://weitz.de/patches.html" target="_new">read this
+first</a>.
+
+<br> <br><h3><a class=none name="dictionary">The FLEXI-STREAMS dictionary</a></h3>
+
+<h4><a name="external-formats" class=none>External formats</a></h4>
+
+<code>EXTERNAL-FORMAT</code> objects are used to denote the external
+formats of <a href="#flexi-streams">flexi streams</a>. These objects are created using
+the <a
+href="#make-external-format"><code>MAKE-EXTERNAL-FORMAT</code></a>
+function, and there are <a href="#external-format-name">various
+readers</a> to query their attributes. Once such an object is
+created it can't be changed.
+<p>
+An external format consists of a basic encoding
+(like <a
+href="http://en.wikipedia.org/wiki/Iso-8859-1">ISO 8859-1</a>
+or <a href="http://en.wikipedia.org/wiki/UTF-8">UTF-8</a>), a
+definition how line endings are denoted - by a carriage return
+character (ASCII 13), by a line feed character (ASCII 10),
+or by both of these characters in a row -, and optionally (for
+encodings that use units larger than 8 bits) information
+about the <a href="http://en.wikipedia.org/wiki/Endian">endianess</a>
+of the encoding.
+<p>
+The following encodings are currently supported by FLEXI-STREAMS:
+<ul>
+<li><a href="http://en.wikipedia.org/wiki/UTF-8">UTF-8</a> (denoted by the keyword <code>:UTF-8</code>),
+<li><a href="http://en.wikipedia.org/wiki/UTF-16">UTF-16</a> (denoted by the keyword <code>:UTF-16</code>),
+<li><a href="http://en.wikipedia.org/wiki/UTF-32">UTF-32</a> (denoted by the keyword <code>:UTF-32</code>),
+<li>all <a href="http://czyborra.com/charsets/iso8859.html">ISO 8859</a> character sets (denoted by keywords like <code>:ISO-8859-15</code>),
+<li><a href="http://en.wikipedia.org/wiki/KOI8-R">KOI8-R</a> (denoted by the keyword <code>:KOI8-R</code>),
+<li>a couple
+of <a href="http://czyborra.com/charsets/codepages.html">Windows code
+pages</a> (denoted by the keyword <code>:CODE-PAGE</code> and an
+obligatory <code>:ID</code> argument), and
+<li><a href="http://en.wikipedia.org/wiki/ASCII">US-ASCII</a>.
+</ul>
+<p>
+A couple of alternative names are allowed that are listed below:
+<p>
+<table border=1>
+<tr><td><code>:UTF-8</code></td><td><code>:UTF8</code></td></tr>
+<tr><td rowspan=4 valign=top><code>:UTF-16</code></td><td><code>:UTF16</code></td></tr>
+<tr><td><code>:UCS-2</code></td></tr>
+<tr><td><code>:UCS2</code></td></tr>
+<tr><td><code>:UNICODE</code></td></tr>
+<tr><td rowspan=3 valign=top><code>:UTF-32</code></td><td><code>:UTF32</code></td></tr>
+<tr><td><code>:UCS-4</code></td></tr>
+<tr><td><code>:UCS4</code></td></tr>
+<tr><td rowspan=2 valign=top><code>:ISO-8859-1</code></td><td><code>:LATIN-1</code></td></tr>
+<tr><td><code>:LATIN1</code></td></tr>
+<tr><td rowspan=2 valign=top><code>:ISO-8859-2</code></td><td><code>:LATIN-2</code></td></tr>
+<tr><td><code>:LATIN2</code></td></tr>
+<tr><td rowspan=2 valign=top><code>:ISO-8859-3</code></td><td><code>:LATIN-3</code></td></tr>
+<tr><td><code>:LATIN3</code></td></tr>
+<tr><td rowspan=2 valign=top><code>:ISO-8859-4</code></td><td><code>:LATIN-4</code></td></tr>
+<tr><td><code>:LATIN4</code></td></tr>
+<tr><td><code>:ISO-8859-5</code></td><td><code>:CYRILLIC</code></td></tr>
+<tr><td><code>:ISO-8859-6</code></td><td><code>:ARABIC</code></td></tr>
+<tr><td><code>:ISO-8859-7</code></td><td><code>:GREEK</code></td></tr>
+<tr><td><code>:ISO-8859-8</code></td><td><code>:HEBREW</code></td></tr>
+<tr><td rowspan=2 valign=top><code>:ISO-8859-9</code></td><td><code>:LATIN-5</code></td></tr>
+<tr><td><code>:LATIN5</code></td></tr>
+<tr><td rowspan=2 valign=top><code>:ISO-8859-10</code></td><td><code>:LATIN-6</code></td></tr>
+<tr><td><code>:LATIN6</code></td></tr>
+<tr><td><code>:ISO-8859-11</code></td><td><code>:THAI</code></td></tr>
+<tr><td rowspan=2 valign=top><code>:ISO-8859-13</code></td><td><code>:LATIN-7</code></td></tr>
+<tr><td><code>:LATIN7</code></td></tr>
+<tr><td rowspan=2 valign=top><code>:ISO-8859-14</code></td><td><code>:LATIN-8</code></td></tr>
+<tr><td><code>:LATIN8</code></td></tr>
+<tr><td rowspan=4 valign=top><code>:ISO-8859-15</code></td><td><code>:LATIN-9</code></td></tr>
+<tr><td><code>:LATIN9</code></td></tr>
+<tr><td><code>:LATIN-0</code></td></tr>
+<tr><td><code>:LATIN0</code></td></tr>
+<tr><td rowspan=2 valign=top><code>:ISO-8859-16</code></td><td><code>:LATIN-10</code></td></tr>
+<tr><td><code>:LATIN10</code></td></tr>
+<tr><td rowspan=2 valign=top><code>:CODE-PAGE</code></td><td><code>:CODEPAGE</code></td></tr>
+<tr><td><code>WIN32:CODE-PAGE<br>(only on <a href="http://www.lispworks.com/products/lww.html">LWW</a>)</code></td></tr>
+<tr><td><code>:KOI8-R</code></td><td><code>:KOI8R</code></td></tr>
+<tr><td><code>:US-ASCII</code></td><td><code>:ASCII</code></td></tr>
+</table>
+<p>
+(Note that we treat UCS-2 exactly like UTF-16 although there
+are <a href="http://en.wikipedia.org/wiki/UTF-16">subtle
+differences</a>. Also note that even though we support encodings like
+UTF-32 some Lisps only supports characters contained within
+the <a
+href="http://en.wikipedia.org/wiki/Basic_Multilingual_Plane">Basic
+Multilingual Plane</a> (like LispWorks) or even less (like CMUCL), so
+if other characters are read from a
+<a href="#flexi-streams">flexi
+stream</a>, <a
+href="http://www.lispworks.com/documentation/HyperSpec/Body/f_rd_cha.htm"><code>READ-CHAR</code></a>
+will try to be helpful and return the corresponding Unicode code point -
+an integer - instead. This might lead to an error if you're using
+functions
+like <a
+href="http://www.lispworks.com/documentation/HyperSpec/Body/f_rd_lin.htm"><code>READ-LINE</code></a>, though.)
+
+<p>
+Whenever a FLEXI-STREAMS function accepts an external format as one of
+its arguments, you can provide either an <code>EXTERNAL-FORMAT</code>
+object or a shortcut which can be a list or a symbol. The list
+shortcuts have a syntax similar
+to <a
+href="http://www.lispworks.com/documentation/lw50/LWUG/html/lwuser-360.htm">the
+one used by LispWorks</a> - the cars are the names of and encoding
+and the cdrs of these lists correspond to the keyword arguments
+to <a
+href="#make-external-format"><code>MAKE-EXTERNAL-FORMAT</code></a>, so
+for example
+<pre>(:latin-1 :eol-style :crlf)</pre>
+is equivalent to
+<pre>(<a class=noborder href="#make-external-format">make-external-format</a> :latin-1 :eol-style :crlf)</pre> The
+symbol shortcuts are equivalent to
+calling <a
+href="#make-external-format"><code>MAKE-EXTERNAL-FORMAT</code></a>
+without keyword arguments, i.e.
+<pre>:thai</pre>
+behaves like
+<pre>(<a class=noborder href="#make-external-format">make-external-format</a> :thai)</pre>
+Finally, the following expansions are
+available:
+<p>
+<table border=1>
+<tr><td><code>:UCS-2LE</code></td><td><code>(:UCS-2 :LITTLE-ENDIAN T)</code></td></tr>
+<tr><td><code>:UCS-2BE</code></td><td><code>(:UCS-2 :LITTLE-ENDIAN NIL)</code></td></tr>
+<tr><td><code>:UCS-4LE</code></td><td><code>(:UCS-4 :LITTLE-ENDIAN T)</code></td></tr>
+<tr><td><code>:UCS-4BE</code></td><td><code>(:UCS-4 :LITTLE-ENDIAN NIL)</code></td></tr>
+<tr><td><code>:UTF-16LE</code></td><td><code>(:UTF-16 :LITTLE-ENDIAN T)</code></td></tr>
+<tr><td><code>:UTF-16BE</code></td><td><code>(:UTF-16 :LITTLE-ENDIAN NIL)</code></td></tr>
+<tr><td><code>:UTF-32LE</code></td><td><code>(:UTF-32 :LITTLE-ENDIAN T)</code></td></tr>
+<tr><td><code>:UTF-32BE</code></td><td><code>(:UTF-32 :LITTLE-ENDIAN NIL)</code></td></tr>
+<tr><td><code>:IBM437</code></td><td><code>(:CODE-PAGE :ID 437)</code></td></tr>
+<tr><td><code>:IBM850</code></td><td><code>(:CODE-PAGE :ID 850)</code></td></tr>
+<tr><td><code>:IBM852</code></td><td><code>(:CODE-PAGE :ID 852)</code></td></tr>
+<tr><td><code>:IBM855</code></td><td><code>(:CODE-PAGE :ID 855)</code></td></tr>
+<tr><td><code>:IBM857</code></td><td><code>(:CODE-PAGE :ID 857)</code></td></tr>
+<tr><td><code>:IBM860</code></td><td><code>(:CODE-PAGE :ID 860)</code></td></tr>
+<tr><td><code>:IBM861</code></td><td><code>(:CODE-PAGE :ID 861)</code></td></tr>
+<tr><td><code>:IBM862</code></td><td><code>(:CODE-PAGE :ID 862)</code></td></tr>
+<tr><td><code>:IBM863</code></td><td><code>(:CODE-PAGE :ID 863)</code></td></tr>
+<tr><td><code>:IBM864</code></td><td><code>(:CODE-PAGE :ID 864)</code></td></tr>
+<tr><td><code>:IBM865</code></td><td><code>(:CODE-PAGE :ID 865)</code></td></tr>
+<tr><td><code>:IBM866</code></td><td><code>(:CODE-PAGE :ID 866)</code></td></tr>
+<tr><td><code>:IBM869</code></td><td><code>(:CODE-PAGE :ID 869)</code></td></tr>
+<tr><td><code>:WINDOWS-1250</code></td><td><code>(:CODE-PAGE :ID 1250)</code></td></tr>
+<tr><td><code>:WINDOWS-1251</code></td><td><code>(:CODE-PAGE :ID 1251)</code></td></tr>
+<tr><td><code>:WINDOWS-1252</code></td><td><code>(:CODE-PAGE :ID 1252)</code></td></tr>
+<tr><td><code>:WINDOWS-1253</code></td><td><code>(:CODE-PAGE :ID 1253)</code></td></tr>
+<tr><td><code>:WINDOWS-1254</code></td><td><code>(:CODE-PAGE :ID 1254)</code></td></tr>
+<tr><td><code>:WINDOWS-1255</code></td><td><code>(:CODE-PAGE :ID 1255)</code></td></tr>
+<tr><td><code>:WINDOWS-1256</code></td><td><code>(:CODE-PAGE :ID 1256)</code></td></tr>
+<tr><td><code>:WINDOWS-1257</code></td><td><code>(:CODE-PAGE :ID 1257)</code></td></tr>
+<tr><td><code>:WINDOWS-1258</code></td><td><code>(:CODE-PAGE :ID 1258)</code></td></tr>
+</table>
+<p>
+Note that if you provide a shortcut, it
+will be converted to an <code>EXTERNAL-FORMAT</code> object first.
+So, if you're concerned about efficiency, create these objects once and
+re-use them.
+
+<p><br>[Function]
+<br><a class=none name="make-external-format"><b>make-external-format</b> <i>name <tt>&key</tt> eol-style little-endian id</i> => <i>external-format</i></a>
+
+<blockquote><br> Creates and returns
+an <a href="#external-formats"><code>EXTERNAL-FORMAT</code>
+object</a>. <code><i>name</i></code> is a
+symbol, <code><i>eol-style</i></code> is one of the
+keywords <code>:CR</code>, <code>:LF</code>, or <code>:CRLF</code>,
+and <code><i>little-endian</i></code> is
+a <a
+href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_g.htm#generalized_boolean">generalized
+boolean</a>. The default value for <code><i>eol-style</i></code> is the value of <a href="#*default-eol-style*"><code>*DEFAULT-EOL-STYLE*</code></a> except for Windows code pages where it is <code>:CRLF</code>. The default value
+for <code><i>little-endian</i></code> is the value of <a href="#*default-little-endian*"><code>*DEFAULT-LITTLE-ENDIAN*</code></a> - this value is ignored unless <code><i>name</i></code> denotes one of UTF-16 or UTF-32.
+<code><i>id</i></code> must be an integer denoting a Windows code page
+known by FLEXI-STREAMS if <code><i>name</i></code>
+is <code>:CODE-PAGE</code> or <code>WIN32:CODE-PAGE</code>, otherwise
+the value is ignored. See <a href="#external-formats">the section
+about external formats</a> for more info.
+<p>
+Examples (run on Windows):
+
+<pre>
+CL-USER 1 > (make-external-format :latin-1)
+#<FLEXI-STREAMS::EXTERNAL-FORMAT (:ISO-8859-1 :EOL-STYLE :CRLF) 2067DA84>
+
+CL-USER 2 > (make-external-format :latin-1 :eol-style :lf)
+#<FLEXI-STREAMS::EXTERNAL-FORMAT (:ISO-8859-1 :EOL-STYLE :LF) 2068B4D4>
+
+CL-USER 3 > (make-external-format :ibm437)
+#<FLEXI-STREAMS::EXTERNAL-FORMAT (:CODE-PAGE :ID 437 :EOL-STYLE :CRLF) 2069B33C>
+
+CL-USER 4 > (make-external-format :ucs-2)
+#<FLEXI-STREAMS::EXTERNAL-FORMAT (:UTF-16 :EOL-STYLE :CRLF :LITTLE-ENDIAN T) 206B4F4C>
+
+CL-USER 5 > (make-external-format :ucs-2be)
+#<FLEXI-STREAMS::EXTERNAL-FORMAT (:UTF-16 :EOL-STYLE :CRLF :LITTLE-ENDIAN NIL) 2067DBE4>
+
+CL-USER 6 > (make-external-format :ucs-2be :eol-style :cr)
+#<FLEXI-STREAMS::EXTERNAL-FORMAT (:UTF-16 :EOL-STYLE :CR :LITTLE-ENDIAN NIL) 206B54AC>
+</pre>
+</blockquote>
+
+<p><br>[Readers]
+<br><a class=none name="external-format-name"><b>external-format-name</b> <i>external-format</i> => <i>name</i></a>
+<br><a class=none name="external-format-eol-style"><b>external-format-eol-style</b> <i>external-format</i> => <i>eol-style</i></a>
+<br><a class=none name="external-format-little-endian"><b>external-format-little-endian</b> <i>external-format</i> => <i>little-endian</i></a>
+<br><a class=none name="external-format-id"><b>external-format-id</b> <i>external-format</i> => <i>id</i></a>
+
+<blockquote><br>
+These methods can be used to query an <a href="#external-formats"><code>EXTERNAL-FORMAT</code> object</a> for its attributes.
+</blockquote>
+
+<p><br>[Functions]
+<br><a class=none name="external-format-equal"><b>external-format-equal</b> <i>external-format-1 external-format-2</i> => <i>generalized-boolean</i></a>
+
+<blockquote><br>
+Checks whether the two <a href="#external-formats">external formats</a> <code><i>external-format-1</i></code> and <code><i>external-format-2</i></code> are equivalent with respect to their effects on <a href="#flexi-streams">flexi streams</a>.
+<p>
+Examples (run on Windows):
+
+<pre>
+CL-USER 1 > (<a href="#make-external-format" class=noborder>make-external-format</a> :ucs-4le)
+#<FLEXI-STREAMS::EXTERNAL-FORMAT (:UTF-32 :EOL-STYLE :CRLF :LITTLE-ENDIAN T) 2067FB74>
+
+CL-USER 2 > (external-format-equal <a href="http://www.lispworks.com/documentation/HyperSpec/Body/v__stst_.htm" class=noborder>*</a> (make-external-format :utf32 :little-endian t))
+T
+
+CL-USER 3 > (make-external-format :code-page :id 437)
+#<FLEXI-STREAMS::EXTERNAL-FORMAT (:CODE-PAGE :ID 437 :EOL-STYLE :CRLF) 2069428C>
+
+CL-USER 4 > (external-format-equal * (make-external-format :ibm437))
+T
+</pre>
+
+</blockquote>
+
+<p><br>[Special variable]
+<br><a class=none name="*default-eol-style*"><b>*default-eol-style*</b></a>
+
+<blockquote><br>
+The default value for the <code><i>eol-style</i></code> keyword argument of <a href="#make-external-format"><code>MAKE-EXTERNAL-FORMAT</code></a>. Its initial value is <code>:CRLF</code> on Windows and <code>:LF</code> on other operating systems.
+</blockquote>
+
+<p><br>[Special variable]
+<br><a class=none name="*default-little-endian*"><b>*default-little-endian*</b></a>
+
+<blockquote><br>
+The default value for the <code><i>little-endian</i></code> keyword argument of <a href="#make-external-format"><code>MAKE-EXTERNAL-FORMAT</code></a>. Its initial value corresponds to the endianess of the platform FLEXI-STREAMS is used on as revealed by the <code>:LITTLE-ENDIAN</code> <a href="http://www.lispworks.com/documentation/HyperSpec/Body/24_ab.htm">feature</a>.
+</blockquote>
+
+<p><br>[Condition]
+<br><a class=none name="external-format-condition"><b>external-format-condition</b></a>
+
+<blockquote><br>
+All conditions related to <a href="#external-formats">external formats</a> are of this type.
+There's a slot for the external format which can be accessed with <a href="#external-format-condition-external-format"><code>EXTERNAL-FORMAT-CONDITION-EXTERNAL-FORMAT</code></a>.
+</blockquote>
+
+<p><br>[Reader]
+<br><a class=none name="external-format-condition-external-format"><b>external-format-condition-external-format</b> <i>condition</i> => <i>external-format</i></a>
+
+<blockquote><br> If <code><i>condition</i></code> is of
+type <a href="#external-format-condition"><code>EXTERNAL-FORMAT-CONDITION</code></a>,
+this function will return the associated external format. Note that
+there are situation which happen during the creation of external
+formats where this method returns <code>NIL</code>.
+</blockquote>
+
+<p><br>[Condition]
+<br><a class=none name="external-format-error"><b>external-format-error</b></a>
+
+<blockquote><br>
+All errors related to <a href="#external-formats">external formats</a> are of this type.
+This is a subtype of <a href="#external-format-condition"><code>EXTERNAL-FORMAT-CONDITION</code></a>.
+</blockquote>
+
+<p><br>[Condition]
+<br><a class=none name="external-format-encoding-error"><b>external-format-encoding-error</b></a>
+
+<blockquote><br>
+All errors related to encoding problems with <a href="#external-formats">external formats</a> are of this type. (This includes situation where an end of file is encountered in the middle of a multi-octet character.) When this condition is signalled during reading, <a href="http://www.lispworks.com/documentation/HyperSpec/Body/r_use_va.htm"><code>USE-VALUE</code>
+restart</a> is provided. See also <a href="#*substitution-char*"><code>*SUBSTITUTION-CHAR*</code></a> and the example for it. <a href="#external-format-encoding-error"><code>EXTERNAL-FORMAT-ENCODING-ERROR</code></a> is a subtype of <a href="#external-format-error"><code>EXTERNAL-FORMAT-ERROR</code></a>.
+</blockquote>
+
+<p><br>[Special variable]
+<br><a class=none name="*substitution-char*"><b>*substitution-char*</b></a>
+
+<blockquote><br>
+If this value is not NIL, it should be a character which is used
+(as if by a <a href="http://www.lispworks.com/documentation/HyperSpec/Body/r_use_va.htm"><code>USE-VALUE</code> restart</a>) whenever during reading an error of
+type <a href="#external-format-encoding-error"><code>EXTERNAL-FORMAT-ENCODING-ERROR</code></a> would have been signalled otherwise.
+
+<pre>
+CL-USER 1 > (defun foo ()
+ <font color=orange>;; not a valid UTF-8 sequence</font>
+ (<a href="#with-input-from-sequence" class=noborder>with-input-from-sequence</a> (in '(#xe4 #xf6 #xfc))
+ (setq in (<a href="#make-flexi-stream" class=noborder>make-flexi-stream</a> in :external-format :utf8))
+ (read-line in)))
+FOO
+
+CL-USER 2 > (foo)
+
+Error: Unexpected value #xF6 in UTF-8 sequence.
+ 1 (continue) Specify a character to be used instead.
+ 2 (abort) Return to level 0.
+ 3 Return to top loop level 0.
+
+Type :b for backtrace, :c <option number> to proceed, or :? for other options
+
+CL-USER 3 : 1 > :c
+Type a character: x
+
+Error: End of file while in UTF-8 sequence.
+ 1 (continue) Specify a character to be used instead.
+ 2 (abort) Return to level 0.
+ 3 Return to top loop level 0.
+
+Type :b for backtrace, :c <option number> to proceed, or :? for other options
+
+CL-USER 4 : 1 > :c
+Type a character: y
+"xy"
+T
+
+CL-USER 5 > (<a href="http://www.lispworks.com/documentation/HyperSpec/Body/m_handle.htm" class=noborder>handler-bind</a> ((<a href="#external-format-encoding-error" class=noborder>external-format-encoding-error</a> (lambda (condition)
+ (<a href="http://www.lispworks.com/documentation/HyperSpec/Body/r_use_va.htm" class=noborder>use-value</a> #\-))))
+ (foo))
+"--"
+T
+
+CL-USER 6 > (let ((<a href="#*SUBSTITUTION-CHAR*" class=noborder>*substitution-char*</a> #\?))
+ (foo))
+"??"
+T
+</pre>
+</blockquote>
+
+<p><br>[Restart]
+<br><a class=none name="accept-overlong-sequence"><b>accept-overlong-sequence</b></a>
+
+<blockquote><br> This is
+a <a href="http://www.lispworks.com/documentation/HyperSpec/Body/09_adb.htm">restart</a>
+which is established whenever a UTF-8 "overlong" sequence is
+encountered. If
+you <a href="http://www.lispworks.com/documentation/HyperSpec/Body/f_invo_1.htm">invoke</a>
+this restart, the corresponding code point will be accepted although
+it was encoded in an illegal way.
+</blockquote>
+
+<h4><a name="flexi-streams" class=none>Flexi streams</a></h4>
+
+<em>Flexi streams</em> are the core of the FLEXI-STREAMS library. You
+create them using the
+function <a
+href="#make-flexi-stream"><code>MAKE-FLEXI-STREAM</code></a> which
+takes an open binary stream (called the <em>underlying</em> stream) as its only required argument.
+A <em>binary</em> stream in this context means that if it's an <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_i.htm#input">input
+stream</a>, you can read from it with
+<a href="http://www.lispworks.com/documentation/HyperSpec/Body/f_rd_by.htm"><code>READ-BYTE</code></a>
+(or, as a workaround for LispWorks, you can at least apply
+<a
+href="http://www.lispworks.com/documentation/HyperSpec/Body/f_rd_seq.htm"><code>READ-SEQUENCE</code></a>
+to it where the sequence is an array of element
+type <a href="#octet"><code>OCTET</code></a>), and similarly for
+<a
+href="http://www.lispworks.com/documentation/HyperSpec/Body/f_wr_by.htm#write-byte"><code>WRITE-BYTE</code></a>
+(<a
+href="http://www.lispworks.com/documentation/HyperSpec/Body/f_wr_seq.htm"><code>WRITE-SEQUENCE</code></a>
+for LispWorks)
+and <a
+href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_o.htm#output">output
+streams</a>. (Note that this specifically holds
+for <a
+href="http://www.lispworks.com/documentation/lw50/LWRM/html/lwref-91.htm"><em>bivalent</em>
+streams</a> like socket streams.)
+<p>
+A flexi stream behaves like an ordinary Lisp stream. It is an input
+stream if the underlying binary stream is an input stream, and it is
+an output stream when the underlying binary stream is an output
+stream. You can write characters as well
+as <a href="#octet">octets</a> to an output flexi stream and similarly
+you can read characters and octets from an input flexi stream.
+<p>
+A flexi stream always has an <a href="#external-formats">external
+format</a> associated with it which is deployed whenever you read
+characters from the stream or write characters to it. You
+can <a href="#flexi-stream-external-format">change</a> the external
+format while you use the stream.
+<p>
+Once you're using a flexi stream you should <em>not</em> read from or
+write to the underlying stream directly anymore.
+<p>
+If
+you <a
+href="http://www.lispworks.com/documentation/HyperSpec/Body/f_close.htm">close</a>
+a flexi stream, the underlying stream will also be closed. However, it
+also suffices to close the underlying stream directly should you not
+want to use the flexi stream anymore. So, the following usage
+(where <code>IN</code> is implicitly closed at the end) is OK:
+<pre>
+(with-open-file (in "/foo/bar/baz.txt")
+ (let ((flexi (<a href="#make-flexi-stream" class=noborder>make-flexi-stream</a> in <a href="#external-formats" class=noborder>:external-format</a> :hebrew)))
+ (read-line flexi)))
+</pre>
+<p>
+Output flexi streams will try to keep track of
+the <a
+href="http://www.lispworks.com/documentation/lw50/LWRM/html/lwref-591.htm">column</a>
+they're in but you can also <a href="#flexi-stream-column">set</a> the
+column directly. This value will be incremented by one for each
+character written to the stream and it will be set to <code>0</code>
+if you send a <code>#\Newline</code> character. The column will be
+set to <code>NIL</code> if an <a href="#octet"><code>OCTET</code></a>
+is sent to the stream. Once the column is <code>NIL</code> it'll stay
+like that unless it is explicitly set to another value.
+<p>
+Input flexi streams keep track of
+their <a href="#flexi-stream-position">position</a> within the stream.
+This value is incremented by one for
+each <a href="#octet"><code>OCTET</code></a> read from the stream, and
+it is incremented by the number of octets actually read for each
+character read from the stream. So, if the encoding is UTF-8, reading
+the character <code>#\ä</code> (a-umlaut) will advance the position by two.
+If the encoding is UTF-32 and the end-of-line style
+is <code>:CRLF</code>, reading a <code>#\Newline</code> will advance
+the position by eight.
+<p>
+You can also set the <a href="#flexi-stream-bound">bound</a> of an
+input flexi stream. Initially it is <code>NIL</code>, but when it's
+an integer and the
+stream's <a href="#flexi-stream-position">position</a> has gone beyond
+this bound, the stream will behave as if no more input is available.
+<p>
+Caveat: You can
+only <a
+href="http://www.lispworks.com/documentation/HyperSpec/Body/f_unrd_c.htm">unread</a>
+a character from a flexi stream if you haven't changed the external format after you read it.
+<p>
+Caveat: The <em>underlying</em> stream should either be a <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_b.htm#binary">binary stream</a> (i.e. have an element type that is a subtype of integer) or it should explicitly use an <a href="http://www.lispworks.com/documentation/lw50/LWUG/html/lwuser-360.htm">external format</a> with <code>:LF</code> as its end-of-line style. Otherwise it might perform unwanted conversion of line endings on its own. (LispWorks <a href="http://article.gmane.org/gmane.lisp.lispworks.general/4859">does this</a> even if you write binary data to the stream using <a href="http://www.lispworks.com/documentation/HyperSpec/Body/f_wr_seq.htm"><code>WRITE-SEQUENCE</code></a>.)
+
+<p><br>[Standard class]
+<br><a class=none name="flexi-stream"><b>flexi-stream</b></a>
+
+<blockquote><br>
+Every <a href="#flexi-streams"><em>flexi stream</em></a> returned by <a href="#make-flexi-stream"><code>MAKE-FLEXI-STREAM</code></a> is of this type which is a subtype of <a href="http://www.lispworks.com/documentation/HyperSpec/Body/t_stream.htm"><code>STREAM</code></a>.
+</blockquote>
+
+<p><br>[Standard class]
+<br><a class=none name="flexi-input-stream"><b>flexi-input-stream</b></a>
+
+<blockquote><br>
+A <a href="#flexi-streams"><em>flexi stream</em></a> is of this type if its underlying stream is an <a href="http://www.lispworks.com/documentation/HyperSpec/Body/f_in_stm.htm">input stream</a>. This is a subtype of <a href="#flexi-stream"><code>FLEXI-STREAM</code></a>.
+</blockquote>
+
+<p><br>[Standard class]
+<br><a class=none name="flexi-output-stream"><b>flexi-output-stream</b></a>
+
+<blockquote><br>
+A <a href="#flexi-streams"><em>flexi stream</em></a> is of this type if its underlying stream is an <a href="http://www.lispworks.com/documentation/HyperSpec/Body/f_in_stm.htm">output stream</a>. This is a subtype of <a href="#flexi-stream"><code>FLEXI-STREAM</code></a>.
+</blockquote>
+
+<p><br>[Standard class]
+<br><a class=none name="flexi-io-stream"><b>flexi-io-stream</b></a>
+
+<blockquote><br>
+A <a href="#flexi-streams"><em>flexi stream</em></a> is of this type if it is both a <a href="#flexi-input-stream"><code>FLEXI-INPUT-STREAM</code></a> as well as a <a href="#flexi-output-stream"><code>FLEXI-OUTPUT-STREAM</code></a>.
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="make-flexi-stream"><b>make-flexi-stream</b> <i>stream <tt>&key</tt> external-format element-type column position bound</i> => <i>flexi-stream</i></a>
+
+<blockquote><br>
+Creates and returns a <a href="#flexi-streams"><em>flexi stream</em></a>, i.e. an object of type <a href="#flexi-stream"><code>FLEXI-STREAM</code></a>. <code><i>stream</i></code> is the underlying Lisp stream. <code><i>external-format</i></code> is the initial <a href="#external-formats">external format</a> to be used by the stream, the default is the value of evaluating <code>(<a href="#make-external-format">MAKE-EXTERNAL-FORMAT</a> :LATIN1)</code>. <code><i>element-type</i></code> is the initial <a href="http://www.lispworks.com/documentation/HyperSpec/Body/f_stm_el.htm">element type</a> of the flexi stream the default of which is <a href="http://www.lispworks.com/documentation/lw50/LWRM/html/lwref-346.htm"><code>LW:SIMPLE-CHAR</code></a> for LispWorks and <a href="http://www.lispworks.com/documentation/HyperSpec/Body/t_ch.htm"><code>CHARACTER</code></a> otherwise. <code><i>column</i></code> is the initial column of the stream and should only be provided for output streams, the default is <code>0</code>. <code><i>position</i></code> is the initial octet position of the stream and must only be provided for input streams, the default is <code>0</code>. <code><i>bound</i></code> should be <code>NIL</code> (the default) or an integer and must only be provided for input streams. If the octet position of the stream has gone beyond this bound, the stream will behave as if no more input is available. See <a href="#flexi-streams">the section about flexi streams</a> for more information.
+</blockquote>
+
+<p><br>[Accessors]
+<br><a class=none name="flexi-stream-external-format"><b>flexi-stream-external-format</b> <i>flexi-stream</i> => <i>external-format</i></a>
+<br><tt>(setf (</tt><b>flexi-stream-external-format</b> <i>flexi-stream</i>) <i>external-format</i><tt>)</tt>
+<br><a class=none name="flexi-stream-element-type"><b>flexi-stream-element-type</b> <i>flexi-stream</i> => <i>element-type</i></a>
+<br><tt>(setf (</tt><b>flexi-stream-element-type</b> <i>flexi-stream</i>) <i>element-type</i><tt>)</tt>
+<br><a class=none name="flexi-stream-column"><b>flexi-stream-column</b> <i>flexi-output-stream</i> => <i>column</i></a>
+<br><tt>(setf (</tt><b>flexi-stream-column</b> <i>flexi-output-stream</i>) <i>column</i><tt>)</tt>
+<br><a class=none name="flexi-stream-position"><b>flexi-stream-position</b> <i>flexi-input-stream</i> => <i>position</i></a>
+<br><tt>(setf (</tt><b>flexi-stream-position</b> <i>flexi-input-stream</i>) <i>position</i><tt>)</tt>
+<br><a class=none name="flexi-stream-bound"><b>flexi-stream-bound</b> <i>flexi-input-stream</i> => <i>bound</i></a>
+<br><tt>(setf (</tt><b>flexi-stream-bound</b> <i>flexi-input-stream</i>) <i>bound</i><tt>)</tt>
+
+<blockquote><br>
+These methods can be used to get and set the corresponding attributes of a <a href="#flexi-streams">flexi stream</a>.
+<p>
+<a href="#flexi-stream-external-format"><code>(SETF
+FLEXI-STREAM-EXTERNAL-FORMAT)</code></a> accepts keyword symbols
+(<a href="#external-formats">names of external formats</a>), lists
+(which should be valid lists of parameters
+to <a
+href="#make-external-format"><code>MAKE-EXTERNAL-FORMAT</code></a>), or <code>EXTERNAL-FORMAT</code> objects:
+<pre>
+CL-USER 1 > (setf (flexi-stream-external-format *my-stream*) :ucs-4le)
+#<FLEXI-STREAMS::EXTERNAL-FORMAT (:UTF-32 :EOL-STYLE :CRLF :LITTLE-ENDIAN T) 206920DC>
+
+CL-USER 2 > (setf (flexi-stream-external-format *my-stream*) '(:ucs-2be :eol-style :br))
+#<FLEXI-STREAMS::EXTERNAL-FORMAT (:UTF-16 :EOL-STYLE :BR :LITTLE-ENDIAN NIL) 20696934>
+
+CL-USER 3 > (setf (flexi-stream-external-format *my-stream*) (make-external-format :ibm437))
+#<FLEXI-STREAMS::EXTERNAL-FORMAT (:CODE-PAGE :ID 437 :EOL-STYLE :CRLF) 2068716C>
+</pre>
+</blockquote>
+
+<p><br>[Reader]
+<br><a class=none name="flexi-stream-stream"><b>flexi-stream-stream</b> <i>flexi-stream</i> => <i>stream</i></a>
+
+<blockquote><br>
+This method returns the underlying stream of a <a href="#flexi-streams">flexi stream</a>.
+</blockquote>
+
+<p><br>[Generic function]
+<br><a class=none name="unread-byte"><b>unread-byte</b> <i>byte stream</i> => <i>nil</i></a>
+
+<blockquote><br>
+Similar to <a href="http://www.lispworks.com/documentation/HyperSpec/Body/f_unrd_c.htm"><code>UNREAD-CHAR</code></a> in that it "unreads" the last <a href="#octet">octet</a> from
+<code><i>stream</i></code> which must be a <a href="#flexi-streams">flexi stream</a>. Note that you can only call <code>UNREAD-BYTE</code> after a corresponding
+<a href="http://www.lispworks.com/documentation/HyperSpec/Body/f_rd_by.htm"><code>READ-BYTE</code></a>, <em>not</em> after <a href="http://www.lispworks.com/documentation/HyperSpec/Body/f_rd_cha.htm"><code>READ-CHAR</code></a>.
+</blockquote>
+
+<p><br>[Generic function]
+<br><a class=none name="peek-byte"><b>peek-byte</b> <i>stream <tt>&optional</tt> peek-type eof-error-p eof-value</i> => <i>byte</i></a>
+
+<blockquote><br>
+<code>PEEK-BYTE</code> is like <a href="http://www.lispworks.com/documentation/HyperSpec/Body/f_peek_c.htm"><code>PEEK-CHAR</code></a>, i.e. it returns an <a href="#octet">octet</a> from <code><i>stream</i></code> (which must be a <a href="#flexi-streams">flexi stream</a>)
+without actually removing it. If <code><i>peek-type</i></code> is <code>NIL</code>, the next octet is
+returned, if <code><i>peek-type</i></code> is <code>T</code>, the next octet which is not <code>0</code> is
+returned, if <code><i>peek-type</i></code> is an octet, the next octet which equals
+<code><i>peek-type</i></code> is returned. <code><i>eof-error-p</i></code> and <code><i>eof-value</i></code> are interpreted as usual.
+<p>
+Note that the parameters aren't in the same order as with <a href="http://www.lispworks.com/documentation/HyperSpec/Body/f_peek_c.htm"><code>PEEK-CHAR</code></a> because it doesn't make much sense to make <code><i>stream</i></code> an optional argument.
+</blockquote>
+
+<p><br>[Type]
+<br><a class=none name="octet"><b>octet</b></a>
+
+<blockquote><br>
+Just a shortcut for <code>(UNSIGNED-BYTE 8)</code>.
+</blockquote>
+
+<p><br>[Condition]
+<br><a class=none name="flexi-stream-error"><b>flexi-stream-error</b></a>
+
+<blockquote><br>
+All errors related to <a href="#flexi-streams">flexi streams</a> are of this type. This is a subtype of <a href="http://www.lispworks.com/documentation/HyperSpec/Body/e_stm_er.htm"><code>STREAM-ERROR</code></a>.
+</blockquote>
+
+<p><br>[Condition]
+<br><a class=none name="flexi-stream-out-of-sync-error"><b>flexi-stream-out-of-sync-error</b></a>
+
+<blockquote><br> This can happen if you're trying to write to
+an <a href="#flexi-io-stream">IO stream</a> which had prior to that
+"looked ahead" while reading and now can't "rewind" to the octet where
+you <em>should</em> be.
+</blockquote>
+
+<p><br>[Condition]
+<br><a class=none name="flexi-stream-element-type-error"><b>flexi-stream-element-type-error</b></a>
+
+<blockquote><br>
+All errors related to problems with the element type of <a href="#flexi-streams">flexi streams</a> are of this type. This is a subtype of <a href="#flexi-stream-error"><code>FLEXI-STREAM-ERROR</code></a> and has an additional slot for the element type which can be accessed with <a href="#flexi-stream-element-type-error-element-type"><code>FLEXI-STREAM-ELEMENT-TYPE-ERROR-ELEMENT-TYPE</code></a>.
+</blockquote>
+
+<p><br>[Reader]
+<br><a class=none name="flexi-stream-element-type-error-element-type"><b>flexi-stream-element-type-error-element-type</b> <i>condition</i> => <i>element-type</i></a>
+
+<blockquote><br>
+If <code><i>condition</i></code> is of type <a href="#flexi-stream-element-type-error"><code>FLEXI-STREAM-ELEMENT-TYPE-ERROR</code></a>, this function will return the offending element type.
+</blockquote>
+
+<h4><a name="in-memory" class=none>In-memory streams</a></h4>
+
+The library also provides <em>in-memory</em> binary streams which are modeled after <a href="http://www.lispworks.com/documentation/HyperSpec/Body/t_stg_st.htm">string streams</a> and behave very similar only that they deal with <a href="#octet">octets</a> instead of characters and the underlying data structure is not a string but either a list or a vector. These streams can obviously be used as the underlying streams for <a href="#flexi-streams">flexi streams</a>.
+
+<p><br>[Standard class]
+<br><a class=none name="in-memory-stream"><b>in-memory-stream</b></a>
+
+<blockquote><br>
+Every <a href="#in-memory"><em>in-memory stream</em></a> returned by <a href="#make-in-memory-input-stream"><code>MAKE-IN-MEMORY-INPUT-STREAM</code></a> or <a href="#make-in-memory-output-stream"><code>MAKE-IN-MEMORY-OUTPUT-STREAM</code></a> is of this type which is a subtype of <a href="http://www.lispworks.com/documentation/HyperSpec/Body/t_stream.htm"><code>STREAM</code></a>.
+</blockquote>
+
+<p><br>[Standard class]
+<br><a class=none name="in-memory-input-stream"><b>in-memory-input-stream</b></a>
+
+<blockquote><br>
+Every <a href="#in-memory"><em>in-memory stream</em></a> returned by <a href="#make-in-memory-input-stream"><code>MAKE-IN-MEMORY-INPUT-STREAM</code></a> is of this type which is a subtype of <a href="#in-memory-stream"><code>IN-MEMORY-STREAM</code></a>.
+</blockquote>
+
+<p><br>[Standard class]
+<br><a class=none name="in-memory-output-stream"><b>in-memory-output-stream</b></a>
+
+<blockquote><br>
+Every <a href="#in-memory"><em>in-memory stream</em></a> returned by <a href="#make-in-memory-output-stream"><code>MAKE-IN-MEMORY-OUTPUT-STREAM</code></a> is of this type which is a subtype of <a href="#in-memory-stream"><code>IN-MEMORY-STREAM</code></a>.
+</blockquote>
+
+<p><br>[Standard class]
+<br><a class=none name="list-stream"><b>list-stream</b></a>
+
+<blockquote><br>
+Every <a href="#in-memory"><em>in-memory input stream</em></a> is of this type if it reads from a list.
+</blockquote>
+
+<p><br>[Standard class]
+<br><a class=none name="vector-stream"><b>vector-stream</b></a>
+
+<blockquote><br>
+Every <a href="#in-memory"><em>in-memory stream</em></a> is of this type if it reads from or writes to a vector.
+</blockquote>
+
+<p><br>[Generic function]
+<br><a class=none name="make-in-memory-input-stream"><b>make-in-memory-input-stream</b> <i>sequence <tt>&key</tt> start end transformer</i> => <i>in-memory-input-stream</i></a>
+
+<blockquote><br>
+Returns a <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_b.htm#binary">binary</a> <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_i.htm#input">input</a> stream (of type <a href="#in-memory-input-stream"><code>IN-MEMORY-INPUT-STREAM</code></a>) which will supply, in order, the
+octets in the subsequence of <code><i>sequence</i></code> bounded by <code><i>start</i></code> (the default is <code>0</code>) and <code><i>end</i></code> (the default is the length of <code><i>sequence</i></code>). <code><i>sequence</i></code> must either be a list or a vector of <a href="#octet">octets</a>.
+Each octet returned will be transformed in turn by the optional
+<code><i>transformer</i></code> function.
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="make-in-memory-output-stream"><b>make-in-memory-output-stream</b> <i><tt>&key</tt> element-type transformer</i> => <i>in-memory-output-stream</i></a>
+
+<blockquote><br>
+Returns a <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_b.htm#binary">binary</a> <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_o.htm#output">output</a> stream (of type <a href="#in-memory-output-stream"><code>IN-MEMORY-OUTPUT-STREAM</code></a>) which accepts objects of type <code><i>element-type</i></code> (a subtype of <a href="#octet"><code>OCTET</code></a>) and makes
+available a sequence (see <a href="#get-output-stream-sequence"><code>GET-OUTPUT-STREAM-SEQUENCE</code></a>) that contains the octets that were actually
+output. The octets stored will each be transformed by the optional <code><i>transformer</i></code> function.
+</blockquote>
+
+<p><br>[Generic function]
+<br><a class=none name="get-output-stream-sequence"><b>get-output-stream-sequence</b> <i>stream <tt>&key</tt> as-list</i> => <i>sequence</i></a>
+
+<blockquote><br>
+Returns a vector containing, in order, all the octets that have
+been output to the <a href="#in-memory">in-memory output stream</a> <code><i>stream</i></code>. This operation clears any
+octets on <code><i>stream</i></code>, so the vector contains only those octets which have
+been output since the last call to <a href="#get-output-stream-sequence"><code>GET-OUTPUT-STREAM-SEQUENCE</code></a> or since
+the creation of the stream, whichever occurred most recently. If
+<code><i>as-list</i></code> is true the return value is coerced to a list.
+</blockquote>
+
+<p><br>[Generic function]
+<br><a class=none name="output-stream-sequence-length"><b>output-stream-sequence-length</b> <i>stream</i> => <i>length</i></a>
+
+<blockquote><br> Returns the current length of the underlying vector
+of the <a href="#in-memory">in-memory output
+stream</a> <code><i>stream</i></code>, i.e. this is the length of the
+sequence that <a href="#get-output-stream-sequence"><code>GET-OUTPUT-STREAM-SEQUENCE</code></a> would return if called at
+this very moment.
+</blockquote>
+
+<p><br>[Macro]
+<br><a class=none name="with-input-from-sequence"><b>with-input-from-sequence</b> <i>(var sequence <tt>&key</tt> start end transformer) statement*</i> => <i>result*</i></a>
+
+<blockquote><br> Creates an <a href="#in-memory">in-memory input
+stream</a> from the sequence <code><i>sequence</i></code> using the
+parameters <code><i>start</i></code> and <code><i>end</i></code>
+(see <a
+href="#make-in-memory-input-stream"><code>MAKE-IN-MEMORY-INPUT-STREAM</code></a>),
+binds <code><i>var</i></code> to this stream and then executes
+the <code><i>statement*</i></code> forms. A
+function <code><i>transformer</i></code> may optionally be specified
+to transform the returned octets. The stream is automatically closed
+on exit from
+<a href="#with-output-to-sequence"><code>WITH-OUTPUT-TO-SEQUENCE</code></a>, no matter whether the exit is normal or
+abnormal. The return value of this macro is the return value of
+the last statement of <code><i>statement*</i></code>.
+</blockquote>
+
+<p><br>[Macro]
+<br><a class=none name="with-output-to-sequence"><b>with-output-to-sequence</b> <i>(var <tt>&key</tt> as-list element-type transformer) statement*</i> => <i>sequence</i></a>
+
+<blockquote><br>
+Creates an <a href="#in-memory">in-memory output stream</a>, binds <code><i>var</i></code> to this stream and
+then executes the <code><i>statement*</i></code> forms. The stream stores
+data of type <code><i>element-type</i></code> (a subtype of <a href="#octet"><code>OCTET</code></a>) which is (optionally) transformed by the
+function <code><i>transformer</i></code> prior to storage. The stream is automatically closed on
+exit from <a href="#with-output-to-sequence"><code>WITH-OUTPUT-TO-SEQUENCE</code></a>, no matter whether the exit is
+normal or abnormal. The return value of this macro is a vector (or a
+list if <code><i>as-list</i></code> is true) containing the octets that were sent to the
+stream within the body of the macro.
+</blockquote>
+
+<p><br>[Condition]
+<br><a class=none name="in-memory-stream-error"><b>in-memory-stream-error</b></a>
+
+<blockquote><br>
+All errors related to <a href="#in-memory">in-memory streams</a> are of this type. This is a subtype of <a href="http://www.lispworks.com/documentation/HyperSpec/Body/e_stm_er.htm"><code>STREAM-ERROR</code></a>.
+</blockquote>
+
+<p><br>[Condition]
+<br><a class=none name="in-memory-stream-closed-error"><b>in-memory-stream-closed-error</b></a>
+
+<blockquote><br>
+An error of this type is signalled if one tries to read from or write to an <a href="#in-memory">in-memory stream</a> which had already been closed. This is a subtype of <a href="#in-memory-stream-error"><code>IN-MEMORY-STREAM-ERROR</code></a>.
+</blockquote>
+
+<p><br>[Condition]
+<br><a class=none name="in-memory-stream-position-spec-error"><b>in-memory-stream-position-spec-error</b></a>
+
+<blockquote><br> Errors of this type are signalled if an erroneous
+position spec is used in conjunction
+with <a href="#position"><code>FILE-POSITION</code></a>. This is a
+subtype
+of <a href="#in-memory-stream-error"><code>IN-MEMORY-STREAM-ERROR</code></a>
+and has an additional slot for the position spec which can be accessed
+with <a href="#in-memory-stream-position-spec-error-position-spec"><code>IN-MEMORY-STREAM-POSITION-SPEC-ERROR-POSITION-SPEC</code></a>.
+</blockquote>
+
+<p><br>[Reader]
+<br><a class=none name="in-memory-stream-position-spec-error-position-spec"><b>in-memory-stream-position-spec-error-position-spec</b> <i>condition</i> => <i>position-spec</i></a>
+
+<blockquote><br>
+If <code><i>condition</i></code> is of type <a href="#in-memory-stream-position-spec-error"><code>IN-MEMORY-STREAM-POSITION-SPEC-ERROR</code></a>, this function will return the offending position spec.
+</blockquote>
+
+<h4><a name="strings" class=none>Strings</a></h4>
+
+This section collects a few convenience functions for strings conversions.
+
+<p><br>[Function]
+<br><a class=none name="string-to-octets"><b>string-to-octets</b> <i>string <tt>&key</tt> external-format start end</i> => <i>vector</i></a>
+
+<blockquote><br>
+
+Converts the Lisp string <code><i>string</i></code> from <code><i>start</i></code> to <code><i>end</i></code> to an array of
+<a href="#octet">octets</a> corresponding to the <a href="#external-formats">external
+format</a> designated by <code><i>external-format</i></code>. The defaults for
+<code><i>start</i></code> and <code><i>end</i></code>
+are <code>0</code> and the length of the string. The default
+for <code><i>external-format</i></code> is <code>:LATIN1</code>.
+<p>
+In spite of the name, <code><i>string</i></code> can be any sequence of characters, but
+the function is optimized for strings.
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="octets-to-string"><b>octets-to-string</b> <i>sequence <tt>&key</tt> external-format start end</i> => <i>string</i></a>
+
+<blockquote><br> Converts the Lisp
+sequence <code><i>sequence</i></code> of <a href="#octet">octets</a>
+from <code><i>start</i></code> to <code><i>end</i></code> to a string
+using the <a href="#external-formats">external format</a> designated
+by <code><i>external-format</i></code>. The defaults for
+<code><i>start</i></code> and <code><i>end</i></code>
+are <code>0</code> and the length of the sequence. The default
+for <code><i>external-format</i></code> is <code>:LATIN1</code>.
+<p>
+This function is optimized for the case
+of <code><i>sequence</i></code> being
+a <a href="http://www.lispworks.com/documentation/HyperSpec/Body/t_vector.htm">vector</a>.
+Don't use lists if you are in hurry.
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="octet-length"><b>octet-length</b> <i>string <tt>&key</tt> external-format start end</i> => <i>length</i></a>
+
+<blockquote><br>
+
+Returns the length of the subsequence of <code><i>string</i></code> from <code><i>start</i></code> to <code><i>end</i></code> in
+<a href="#octet">octets</a> if encoded using
+the <a href="#external-formats">external format</a> designated
+by <code><i>external-format</i></code>.
+The defaults for
+<code><i>start</i></code> and <code><i>end</i></code>
+are <code>0</code> and the length of <code><i>string</i></code>. The default
+for <code><i>external-format</i></code> is <code>:LATIN1</code>.
+<p>
+In spite of the name, <code><i>string</i></code> can be any sequence of characters, but
+the function is optimized for strings.
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="char-length"><b>char-length</b> <i>sequence <tt>&key</tt> external-format start end</i> => <i>length</i></a>
+
+<blockquote><br>
+
+Kind of the inverse of <a href="#octet-length"><code>OCTET-LENGTH</code></a>.
+Returns the length of the subsequence (of <a href="#octet">octets</a>) of <code><i>sequence</i></code> from <code><i>start</i></code> to <code><i>end</i></code> in
+characters if decoded using
+the <a href="#external-formats">external format</a> designated
+by <code><i>external-format</i></code>.
+The defaults for
+<code><i>start</i></code> and <code><i>end</i></code>
+are <code>0</code> and the length of the sequence. The default
+for <code><i>external-format</i></code> is <code>:LATIN1</code>. Note that this function doesn't check for the validity of the data in <code><i>sequence</i></code>.
+<p>
+This function is optimized for the case
+of <code><i>sequence</i></code> being
+a <a href="http://www.lispworks.com/documentation/HyperSpec/Body/t_vector.htm">vector</a>.
+Don't use lists if you are in hurry.
+</blockquote>
+
+<br> <br><h3><a class=none name="position">File positions</a></h3>
+
+For <a href="#flexi-streams">flexi streams</a> as well
+as for <a href="#input-memory">in-memory
+streams</a>, <a
+href="http://www.lispworks.com/documentation/HyperSpec/Body/f_file_p.htm">FILE-POSITION</a>
+will usually return <code>NIL</code> and do nothing when a second
+argument is supplied. This is correct
+w.r.t. the <a
+href="http://www.lispworks.com/documentation/HyperSpec/">ANSI
+standard</a>, but not very helpful. However, even
+with <a
+href="http://www.nhplace.com/kent/CL/Issues/stream-definition-by-user.html">Gray
+streams</a> there is no <em>portable</em> way to implement a better
+behaviour.
+<p>
+For <a href="http://www.lispworks.com/">LispWorks</a>
+and <a href="http://clisp.sf.net/">CLISP</a>,
+<a
+href="http://www.lispworks.com/documentation/HyperSpec/Body/f_file_p.htm">FILE-POSITION</a>
+for <a href="#flexi-streams">flexi streams</a> will work as if the
+function had been applied to the underlying stream, and
+for <a href="#input-memory">in-memory streams</a> it will try to do
+something sensible if the underlying data structure is a vector
+(i.e. <em>not</em> a list). Patches for other Common Lisp
+implementations should be sent to
+the <a
+href="http://common-lisp.net/project/cl-plus-ssl/#trivial-gray-streams">trivial-gray-streams</a>
+maintainers.
+
+<br> <br><h3><a class=none name="ack">Acknowledgements</a></h3>
+
+Thanks to David Lichteblau for numerous portability patches. Thanks
+to Igor Plekhov for the KOI8-R code. Thanks to Anton Vodonosov for
+numerous patches and additions. Thanks
+to <a href="http://netzhansa.blogspot.com/">Hans Hübner</a> for
+his work on making FLEXI-STREAMS faster.
+
+<p>
+$Header: /usr/local/cvsrep/flexi-streams/doc/index.html,v 1.126 2008/08/26 10:59:24 edi Exp $
+<p><a href="http://weitz.de/index.html">BACK TO MY HOMEPAGE</a>
+
+</body>
+</html>
--- /dev/null
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: FLEXI-STREAMS; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/flexi-streams/encode.lisp,v 1.26 2008/05/26 10:55:08 edi Exp $
+
+;;; Copyright (c) 2005-2008, Dr. Edmund Weitz. All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;; * Redistributions of source code must retain the above copyright
+;;; notice, this list of conditions and the following disclaimer.
+
+;;; * 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 BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; 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 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.
+
+(in-package :flexi-streams)
+
+(defgeneric char-to-octets (format char writer)
+ (declare #.*standard-optimize-settings*)
+ (:documentation "Converts the character CHAR to a sequence of octets
+using the external format FORMAT. The conversion is performed by
+calling the unary function \(which must be a functional object) WRITER
+repeatedly each octet. The return value of this function is
+unspecified."))
+
+(defgeneric write-sequence* (format stream sequence start end)
+ (declare #.*standard-optimize-settings*)
+ (:documentation "A generic function which dispatches on the external
+format and does the real work for STREAM-WRITE-SEQUENCE."))
+
+(defgeneric string-to-octets* (format string start end)
+ (declare #.*standard-optimize-settings*)
+ (:documentation "A generic function which dispatches on the external
+format and does the real work for STRING-TO-OCTETS."))
+
+(defmethod string-to-octets* :around (format (list list) start end)
+ (declare #.*standard-optimize-settings*)
+ (string-to-octets* format (coerce list 'string*) start end))
+
+(defmacro define-sequence-writers ((format-class) &body body)
+ "Non-hygienic utility macro which defines methods for
+WRITE-SEQUENCE* and STRING-TO-OCTETS* for the class FORMAT-CLASS. For
+BODY see the docstring of DEFINE-CHAR-ENCODERS."
+ (let ((body `((locally
+ (declare #.*fixnum-optimize-settings*)
+ ,@body))))
+ `(progn
+ (defmethod string-to-octets* ((format ,format-class) string start end)
+ (declare #.*standard-optimize-settings*)
+ (declare (fixnum start end) (string string))
+ (let ((octets (make-array (compute-number-of-octets format string start end)
+ :element-type 'octet))
+ (j 0))
+ (declare (fixnum j))
+ (loop for i of-type fixnum from start below end do
+ (macrolet ((octet-writer (form)
+ `(progn
+ (setf (aref (the (array octet *) octets) j) ,form)
+ (incf j))))
+ (symbol-macrolet ((char-getter (char string i)))
+ (progn ,@body))))
+ octets))
+ (defmethod write-sequence* ((format ,format-class) stream sequence start end)
+ (declare #.*standard-optimize-settings*)
+ (declare (fixnum start end))
+ (with-accessors ((column flexi-stream-column))
+ stream
+ (let* ((octet-seen-p nil)
+ (buffer-pos 0)
+ ;; estimate should be good enough...
+ (factor (encoding-factor format))
+ ;; we don't want arbitrarily large buffer, do we?
+ (buffer-size (min +buffer-size+ (ceiling (* factor (- end start)))))
+ (buffer (make-octet-buffer buffer-size))
+ (underlying-stream (flexi-stream-stream stream)))
+ (declare (fixnum buffer-pos buffer-size)
+ (boolean octet-seen-p)
+ (type (array octet *) buffer))
+ (macrolet ((octet-writer (form)
+ `(write-octet ,form)))
+ (labels ((flush-buffer ()
+ "Sends all octets in BUFFER to the underlying stream."
+ (write-sequence buffer underlying-stream :end buffer-pos)
+ (setq buffer-pos 0))
+ (write-octet (octet)
+ "Adds one octet to the buffer and flushes it if necessary."
+ (declare (type octet octet))
+ (when (>= buffer-pos buffer-size)
+ (flush-buffer))
+ (setf (aref buffer buffer-pos) octet)
+ (incf buffer-pos))
+ (write-object (object)
+ "Dispatches to WRITE-OCTET or WRITE-CHARACTER
+depending on the type of OBJECT."
+ (etypecase object
+ (octet (setq octet-seen-p t)
+ (write-octet object))
+ (character (symbol-macrolet ((char-getter object))
+ ,@body)))))
+ (macrolet ((iterate (&body output-forms)
+ "An unhygienic macro to implement the actual
+iteration through SEQUENCE. OUTPUT-FORM is the form to retrieve one
+sequence element and put its octet representation into the buffer."
+ `(loop for index of-type fixnum from start below end
+ do (progn ,@output-forms)
+ finally (when (plusp buffer-pos)
+ (flush-buffer)))))
+ (etypecase sequence
+ (string (iterate
+ (symbol-macrolet ((char-getter (char sequence index)))
+ ,@body)))
+ (array (iterate
+ (symbol-macrolet ((char-getter (aref sequence index)))
+ ,@body)))
+ (list (iterate (write-object (nth index sequence))))))
+ ;; update the column slot, setting it to NIL if we sent
+ ;; octets
+ (setq column
+ (cond (octet-seen-p nil)
+ (t (let ((last-newline-pos (position #\Newline sequence
+ :test #'char=
+ :start start
+ :end end
+ :from-end t)))
+ (cond (last-newline-pos (- end last-newline-pos 1))
+ (column (+ column (- end start))))))))))))))))
+
+(defmacro define-char-encoders ((lf-format-class cr-format-class crlf-format-class) &body body)
+ "Non-hygienic utility macro which defines several encoding-related
+methods for the classes LF-FORMAT-CLASS, CR-FORMAT-CLASS, and
+CRLF-FORMAT-CLASS where it is assumed that CR-FORMAT-CLASS is the same
+encoding as LF-FORMAT-CLASS but with CR instead of LF line endings and
+similar for CRLF-FORMAT-CLASS, i.e. LF-FORMAT-CLASS is the base class.
+BODY is a code template for the code to convert one character to
+octets. BODY must contain a symbol CHAR-GETTER representing the form
+which is used to obtain the character and a forms like \(OCTET-WRITE
+<thing>) to write the octet <thing>. The CHAR-GETTER form might be
+called more than once."
+ `(progn
+ (defmethod char-to-octets ((format ,lf-format-class) char writer)
+ (declare #.*fixnum-optimize-settings*)
+ (declare (character char) (function writer))
+ (symbol-macrolet ((char-getter char))
+ (macrolet ((octet-writer (form)
+ `(funcall writer ,form)))
+ ,@body)))
+ (define-sequence-writers (,lf-format-class) ,@body)
+ (define-sequence-writers (,cr-format-class)
+ ;; modify the body so that the getter replaces a #\Newline
+ ;; with a #\Return
+ ,@(sublis `((char-getter . ,(with-unique-names (char)
+ `(let ((,char char-getter))
+ (declare (character ,char))
+ (if (char= ,char #\Newline)
+ #\Return
+ ,char)))))
+ body))
+ (define-sequence-writers (,crlf-format-class)
+ ;; modify the body so that we potentially write octets for
+ ;; two characters (#\Return and #\Linefeed) - the original
+ ;; body is wrapped with the WRITE-CHAR local function
+ ,(with-unique-names (char write-char)
+ `(flet ((,write-char (,char)
+ ,@(sublis `((char-getter . ,char)) body)))
+ (let ((,char char-getter))
+ (declare (character ,char))
+ (cond ((char= ,char #\Newline)
+ (,write-char #\Return)
+ (,write-char #\Linefeed))
+ (t (,write-char ,char)))))))))
+
+(define-char-encoders (flexi-latin-1-format flexi-cr-latin-1-format flexi-crlf-latin-1-format)
+ (let ((octet (char-code char-getter)))
+ (when (> octet 255)
+ (signal-encoding-error format "~S (code ~A) is not a LATIN-1 character." char-getter octet))
+ (octet-writer octet)))
+
+(define-char-encoders (flexi-ascii-format flexi-cr-ascii-format flexi-crlf-ascii-format)
+ (let ((octet (char-code char-getter)))
+ (when (> octet 127)
+ (signal-encoding-error format "~S (code ~A) is not an ASCII character." char-getter octet))
+ (octet-writer octet)))
+
+(define-char-encoders (flexi-8-bit-format flexi-cr-8-bit-format flexi-crlf-8-bit-format)
+ (with-accessors ((encoding-hash external-format-encoding-hash))
+ format
+ (let ((octet (gethash (char-code char-getter) encoding-hash)))
+ (unless octet
+ (signal-encoding-error format "~S (code ~A) is not in this encoding." char-getter octet))
+ (octet-writer octet))))
+
+(define-char-encoders (flexi-utf-8-format flexi-cr-utf-8-format flexi-crlf-utf-8-format)
+ ;; the old version using LDB was more elegant, but some Lisps had
+ ;; trouble optimizing it
+ (let ((char-code (char-code char-getter)))
+ (tagbody
+ (cond ((< char-code #x80)
+ (octet-writer char-code)
+ (go zero))
+ ((< char-code #x800)
+ (octet-writer (logior* #b11000000 (ash* char-code -6)))
+ (go one))
+ ((< char-code #x10000)
+ (octet-writer (logior* #b11100000 (ash* char-code -12)))
+ (go two))
+ (t
+ (octet-writer (logior* #b11110000 (ash* char-code -18)))))
+ (octet-writer (logior* #b10000000 (logand* #b00111111 (ash* char-code -12))))
+ two
+ (octet-writer (logior* #b10000000 (logand* #b00111111 (ash* char-code -6))))
+ one
+ (octet-writer (logior* #b10000000 (logand* #b00111111 char-code)))
+ zero)))
+
+(define-char-encoders (flexi-utf-16-le-format flexi-cr-utf-16-le-format flexi-crlf-utf-16-le-format)
+ (flet ((write-word (word)
+ (octet-writer (logand* #x00ff word))
+ (octet-writer (ash* (logand* #xff00 word) -8))))
+ (declare (inline write-word))
+ (let ((char-code (char-code char-getter)))
+ (declare (type char-code-integer char-code))
+ (cond ((< char-code #x10000)
+ (write-word char-code))
+ (t (decf char-code #x10000)
+ (write-word (logior* #xd800 (ash* char-code -10)))
+ (write-word (logior* #xdc00 (logand* #x03ff char-code))))))))
+
+(define-char-encoders (flexi-utf-16-be-format flexi-cr-utf-16-be-format flexi-crlf-utf-16-be-format)
+ (flet ((write-word (word)
+ (octet-writer (ash* (logand* #xff00 word) -8))
+ (octet-writer (logand* #x00ff word))))
+ (declare (inline write-word))
+ (let ((char-code (char-code char-getter)))
+ (declare (type char-code-integer char-code))
+ (cond ((< char-code #x10000)
+ (write-word char-code))
+ (t (decf char-code #x10000)
+ (write-word (logior* #xd800 (ash* char-code -10)))
+ (write-word (logior* #xdc00 (logand* #x03ff char-code))))))))
+
+(define-char-encoders (flexi-utf-32-le-format flexi-cr-utf-32-le-format flexi-crlf-utf-32-le-format)
+ (let ((char-code (char-code char-getter)))
+ (octet-writer (logand* #x00ff char-code))
+ (octet-writer (logand* #x00ff (ash* char-code -8)))
+ (octet-writer (logand* #x00ff (ash* char-code -16)))
+ (octet-writer (logand* #x00ff (ash* char-code -24)))))
+
+(define-char-encoders (flexi-utf-32-be-format flexi-cr-utf-32-be-format flexi-crlf-utf-32-be-format)
+ (let ((char-code (char-code char-getter)))
+ (octet-writer (logand* #x00ff (ash* char-code -24)))
+ (octet-writer (logand* #x00ff (ash* char-code -16)))
+ (octet-writer (logand* #x00ff (ash* char-code -8)))
+ (octet-writer (logand* #x00ff char-code))))
+
+(defmethod char-to-octets ((format flexi-cr-mixin) char writer)
+ (declare #.*fixnum-optimize-settings*)
+ (declare (character char))
+ (if (char= char #\Newline)
+ (call-next-method format #\Return writer)
+ (call-next-method)))
+
+(defmethod char-to-octets ((format flexi-crlf-mixin) char writer)
+ (declare #.*fixnum-optimize-settings*)
+ (declare (character char))
+ (cond ((char= char #\Newline)
+ (call-next-method format #\Return writer)
+ (call-next-method format #\Linefeed writer))
+ (t (call-next-method))))
--- /dev/null
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: FLEXI-STREAMS; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/flexi-streams/external-format.lisp,v 1.24 2008/05/26 10:55:08 edi Exp $
+
+;;; Copyright (c) 2005-2008, Dr. Edmund Weitz. All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;; * Redistributions of source code must retain the above copyright
+;;; notice, this list of conditions and the following disclaimer.
+
+;;; * 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 BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; 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 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.
+
+(in-package :flexi-streams)
+
+(defclass external-format ()
+ ((name :initarg :name
+ :reader external-format-name
+ :documentation "The name of the external format - a
+keyword.")
+ (id :initarg :id
+ :initform nil
+ :reader external-format-id
+ :documentation "If the external format denotes a Windows
+code page this ID specifies which one to use. Otherwise the
+value is ignored \(and usually NIL).")
+ (little-endian :initarg :little-endian
+ :initform *default-little-endian*
+ :reader external-format-little-endian
+ :documentation "Whether multi-octet values are
+read and written with the least significant octet first. For
+8-bit encodings like :ISO-8859-1 this value is ignored.")
+ (eol-style :initarg :eol-style
+ :reader external-format-eol-style
+ :documentation "The character\(s) to or from which
+a #\Newline will be translated - one of the keywords :CR, :LF,
+or :CRLF."))
+ (:documentation "EXTERNAL-FORMAT objects are used to denote
+encodings for flexi streams or for the string functions defined in
+strings.lisp."))
+
+(defmethod make-load-form ((thing external-format) &optional environment)
+ "Defines a way to reconstruct external formats. Needed for OpenMCL."
+ (make-load-form-saving-slots thing :environment environment))
+
+(defclass flexi-cr-mixin ()
+ ()
+ (:documentation "A mixin for external-formats where the end-of-line
+designator is #\Return."))
+
+(defclass flexi-crlf-mixin ()
+ ()
+ (:documentation "A mixin for external-formats where the end-of-line
+designator is the sequence #\Return #\Linefeed."))
+
+(defclass flexi-8-bit-format (external-format)
+ ((encoding-hash :accessor external-format-encoding-hash)
+ (decoding-table :accessor external-format-decoding-table))
+ (:documentation "The class for all flexi streams which use an 8-bit
+encoding and thus need additional slots for the encoding/decoding
+tables."))
+
+(defclass flexi-cr-8-bit-format (flexi-cr-mixin flexi-8-bit-format)
+ ()
+ (:documentation "Special class for external formats which use an
+8-bit encoding /and/ have #\Return as the line-end character."))
+
+(defclass flexi-crlf-8-bit-format (flexi-crlf-mixin flexi-8-bit-format)
+ ()
+ (:documentation "Special class for external formats which use an
+8-bit encoding /and/ have the sequence #\Return #\Linefeed as the
+line-end character."))
+
+(defclass flexi-ascii-format (flexi-8-bit-format)
+ ()
+ (:documentation "Special class for external formats which use the
+US-ASCII encoding."))
+
+(defclass flexi-cr-ascii-format (flexi-cr-mixin flexi-ascii-format)
+ ()
+ (:documentation "Special class for external formats which use the
+US-ASCII encoding /and/ have #\Return as the line-end character."))
+
+(defclass flexi-crlf-ascii-format (flexi-crlf-mixin flexi-ascii-format)
+ ()
+ (:documentation "Special class for external formats which use the
+US-ASCII encoding /and/ have the sequence #\Return #\Linefeed as the
+line-end character."))
+
+(defclass flexi-latin-1-format (flexi-8-bit-format)
+ ()
+ (:documentation "Special class for external formats which use the
+ISO-8859-1 encoding."))
+
+(defclass flexi-cr-latin-1-format (flexi-cr-mixin flexi-latin-1-format)
+ ()
+ (:documentation "Special class for external formats which use the
+ISO-8859-1 encoding /and/ have #\Return as the line-end character."))
+
+(defclass flexi-crlf-latin-1-format (flexi-crlf-mixin flexi-latin-1-format)
+ ()
+ (:documentation "Special class for external formats which use the
+ISO-8859-1 encoding /and/ have the sequence #\Return #\Linefeed as the
+line-end character."))
+
+(defclass flexi-utf-32-format (external-format)
+ ()
+ (:documentation "Abstract class for external formats which use the
+UTF-32 encoding."))
+
+(defclass flexi-utf-32-le-format (flexi-utf-32-format)
+ ()
+ (:documentation "Special class for external formats which use the
+UTF-32 encoding with little-endian byte ordering."))
+
+(defclass flexi-cr-utf-32-le-format (flexi-cr-mixin flexi-utf-32-le-format)
+ ()
+ (:documentation "Special class for external formats which use the
+UTF-32 encoding with little-endian byte ordering /and/ have #\Return
+as the line-end character."))
+
+(defclass flexi-crlf-utf-32-le-format (flexi-crlf-mixin flexi-utf-32-le-format)
+ ()
+ (:documentation "Special class for external formats which use the
+UTF-32 encoding with little-endian byte ordering /and/ have the
+sequence #\Return #\Linefeed as the line-end character."))
+
+(defclass flexi-utf-32-be-format (flexi-utf-32-format)
+ ()
+ (:documentation "Special class for external formats which use the
+UTF-32 encoding with big-endian byte ordering."))
+
+(defclass flexi-cr-utf-32-be-format (flexi-cr-mixin flexi-utf-32-be-format)
+ ()
+ (:documentation "Special class for external formats which use the
+UTF-32 encoding with big-endian byte ordering /and/ have #\Return as
+the line-end character."))
+
+(defclass flexi-crlf-utf-32-be-format (flexi-crlf-mixin flexi-utf-32-be-format)
+ ()
+ (:documentation "Special class for external formats which use the
+the UTF-32 encoding with big-endian byte ordering /and/ have the
+sequence #\Return #\Linefeed as the line-end character."))
+
+(defclass flexi-utf-16-format (external-format)
+ ()
+ (:documentation "Abstract class for external formats which use the
+UTF-16 encoding."))
+
+(defclass flexi-utf-16-le-format (flexi-utf-16-format)
+ ()
+ (:documentation "Special class for external formats which use the
+UTF-16 encoding with little-endian byte ordering."))
+
+(defclass flexi-cr-utf-16-le-format (flexi-cr-mixin flexi-utf-16-le-format)
+ ()
+ (:documentation "Special class for external formats which use the
+UTF-16 encoding with little-endian byte ordering /and/ have #\Return
+as the line-end character."))
+
+(defclass flexi-crlf-utf-16-le-format (flexi-crlf-mixin flexi-utf-16-le-format)
+ ()
+ (:documentation "Special class for external formats which use the
+UTF-16 encoding with little-endian byte ordering /and/ have the
+sequence #\Return #\Linefeed as the line-end character."))
+
+(defclass flexi-utf-16-be-format (flexi-utf-16-format)
+ ()
+ (:documentation "Special class for external formats which use the
+UTF-16 encoding with big-endian byte ordering."))
+
+(defclass flexi-cr-utf-16-be-format (flexi-cr-mixin flexi-utf-16-be-format)
+ ()
+ (:documentation "Special class for external formats which use the
+UTF-16 encoding with big-endian byte ordering /and/ have #\Return as
+the line-end character."))
+
+(defclass flexi-crlf-utf-16-be-format (flexi-crlf-mixin flexi-utf-16-be-format)
+ ()
+ (:documentation "Special class for external formats which use the
+UTF-16 encoding with big-endian byte ordering /and/ have the sequence
+#\Return #\Linefeed as the line-end character."))
+
+(defclass flexi-utf-8-format (external-format)
+ ()
+ (:documentation "Special class for external formats which use the
+UTF-8 encoding."))
+
+(defclass flexi-cr-utf-8-format (flexi-cr-mixin flexi-utf-8-format)
+ ()
+ (:documentation "Special class for external formats which use the
+UTF-8 encoding /and/ have #\Return as the line-end character."))
+
+(defclass flexi-crlf-utf-8-format (flexi-crlf-mixin flexi-utf-8-format)
+ ()
+ (:documentation "Special class for external formats which use the
+UTF-8 encoding /and/ have the sequence #\Return #\Linefeed as the
+line-end character."))
+
+(defmethod initialize-instance :after ((external-format flexi-8-bit-format) &rest initargs)
+ "Sets the fixed encoding/decoding tables for this particular
+external format."
+ (declare #.*standard-optimize-settings*)
+ (declare (ignore initargs))
+ (with-accessors ((encoding-hash external-format-encoding-hash)
+ (decoding-table external-format-decoding-table)
+ (name external-format-name)
+ (id external-format-id))
+ external-format
+ (multiple-value-setq (encoding-hash decoding-table)
+ (cond ((ascii-name-p name)
+ (values +ascii-hash+ +ascii-table+))
+ ((koi8-r-name-p name)
+ (values +koi8-r-hash+ +koi8-r-table+))
+ ((iso-8859-name-p name)
+ (values (cdr (assoc name +iso-8859-hashes+ :test #'eq))
+ (cdr (assoc name +iso-8859-tables+ :test #'eq))))
+ ((code-page-name-p name)
+ (values (cdr (assoc id +code-page-hashes+))
+ (cdr (assoc id +code-page-tables+))))))))
+
+(defun external-format-class-name (real-name &key eol-style little-endian id)
+ "Given the initargs for a general external format returns the name
+\(a symbol) of the most specific subclass matching these arguments."
+ (declare #.*standard-optimize-settings*)
+ (declare (ignore id))
+ (cond ((ascii-name-p real-name)
+ (ecase eol-style
+ (:lf 'flexi-ascii-format)
+ (:cr 'flexi-cr-ascii-format)
+ (:crlf 'flexi-crlf-ascii-format)))
+ ((eq real-name :iso-8859-1)
+ (ecase eol-style
+ (:lf 'flexi-latin-1-format)
+ (:cr 'flexi-cr-latin-1-format)
+ (:crlf 'flexi-crlf-latin-1-format)))
+ ((or (koi8-r-name-p real-name)
+ (iso-8859-name-p real-name)
+ (code-page-name-p real-name))
+ (ecase eol-style
+ (:lf 'flexi-8-bit-format)
+ (:cr 'flexi-cr-8-bit-format)
+ (:crlf 'flexi-crlf-8-bit-format)))
+ (t (ecase real-name
+ (:utf-8 (ecase eol-style
+ (:lf 'flexi-utf-8-format)
+ (:cr 'flexi-cr-utf-8-format)
+ (:crlf 'flexi-crlf-utf-8-format)))
+ (:utf-16 (ecase eol-style
+ (:lf (if little-endian
+ 'flexi-utf-16-le-format
+ 'flexi-utf-16-be-format))
+ (:cr (if little-endian
+ 'flexi-cr-utf-16-le-format
+ 'flexi-cr-utf-16-be-format))
+ (:crlf (if little-endian
+ 'flexi-crlf-utf-16-le-format
+ 'flexi-crlf-utf-16-be-format))))
+ (:utf-32 (ecase eol-style
+ (:lf (if little-endian
+ 'flexi-utf-32-le-format
+ 'flexi-utf-32-be-format))
+ (:cr (if little-endian
+ 'flexi-cr-utf-32-le-format
+ 'flexi-cr-utf-32-be-format))
+ (:crlf (if little-endian
+ 'flexi-crlf-utf-32-le-format
+ 'flexi-crlf-utf-32-be-format))))))))
+
+(defun make-external-format% (name &key (little-endian *default-little-endian*)
+ id eol-style)
+ "Used internally by MAKE-EXTERNAL-FORMAT to default some of the
+keywords arguments and to determine the right subclass of
+EXTERNAL-FORMAT."
+ (declare #.*standard-optimize-settings*)
+ (let* ((real-name (normalize-external-format-name name))
+ (initargs
+ (cond ((or (iso-8859-name-p real-name)
+ (koi8-r-name-p real-name)
+ (ascii-name-p real-name))
+ (list :eol-style (or eol-style *default-eol-style*)))
+ ((code-page-name-p real-name)
+ (list :id (or (known-code-page-id-p id)
+ (error 'external-format-error
+ :format-control "Unknown code page ID ~S"
+ :format-arguments (list id)))
+ ;; default EOL style for Windows code pages is :CRLF
+ :eol-style (or eol-style :crlf)))
+ (t (list :eol-style (or eol-style *default-eol-style*)
+ :little-endian little-endian)))))
+ (apply #'make-instance (apply #'external-format-class-name real-name initargs)
+ :name real-name
+ initargs)))
+
+(defun make-external-format (name &rest args
+ &key (little-endian *default-little-endian*)
+ id eol-style)
+ "Creates and returns an external format object as specified.
+NAME is a keyword like :LATIN1 or :UTF-8, LITTLE-ENDIAN specifies
+the `endianess' of the external format and is ignored for 8-bit
+encodings, EOL-STYLE is one of the keywords :CR, :LF, or :CRLF
+which denote the end-of-line character \(sequence), ID is the ID
+of a Windows code page \(and ignored for other encodings)."
+ (declare #.*standard-optimize-settings*)
+ ;; the keyword arguments are only there for arglist display in the IDE
+ (declare (ignore id little-endian))
+ (let ((shortcut-args (cdr (assoc name +shortcut-map+ :test #'string-equal))))
+ (cond (shortcut-args
+ (apply #'make-external-format%
+ (append shortcut-args
+ `(:eol-style ,eol-style))))
+ (t (apply #'make-external-format% name args)))))
+
+(defun maybe-convert-external-format (external-format)
+ "Given an external format designator \(a keyword, a list, or an
+EXTERNAL-FORMAT object) returns the corresponding EXTERNAL-FORMAT
+object."
+ (declare #.*standard-optimize-settings*)
+ (typecase external-format
+ (symbol (make-external-format external-format))
+ (list (apply #'make-external-format external-format))
+ (otherwise external-format)))
+
+(defun external-format-equal (ef1 ef2)
+ "Checks whether two EXTERNAL-FORMAT objects denote the same encoding."
+ (declare #.*standard-optimize-settings*)
+ (let* ((name1 (external-format-name ef1))
+ (code-page-name-p (code-page-name-p name1)))
+ ;; they must habe the same canonical name
+ (and (eq name1
+ (external-format-name ef2))
+ ;; if both are code pages the IDs must be the same
+ (or (not code-page-name-p)
+ (eql (external-format-id ef1)
+ (external-format-id ef2)))
+ ;; for non-8-bit encodings the endianess must be the same
+ (or code-page-name-p
+ (ascii-name-p name1)
+ (koi8-r-name-p name1)
+ (iso-8859-name-p name1)
+ (eq name1 :utf-8)
+ (eq (not (external-format-little-endian ef1))
+ (not (external-format-little-endian ef2))))
+ ;; the EOL style must also be the same
+ (eq (external-format-eol-style ef1)
+ (external-format-eol-style ef2)))))
+
+(defun normalize-external-format (external-format)
+ "Returns a list which is a `normalized' representation of the
+external format EXTERNAL-FORMAT. Used internally by PRINT-OBJECT, for
+example. Basically, the result is an argument list that can be fed
+back to MAKE-EXTERNAL-FORMAT to create an equivalent object."
+ (declare #.*standard-optimize-settings*)
+ (let ((name (external-format-name external-format))
+ (eol-style (external-format-eol-style external-format)))
+ (cond ((or (ascii-name-p name)
+ (koi8-r-name-p name)
+ (iso-8859-name-p name)
+ (eq name :utf-8))
+ (list name :eol-style eol-style))
+ ((code-page-name-p name)
+ (list name
+ :id (external-format-id external-format)
+ :eol-style eol-style))
+ (t (list name
+ :eol-style eol-style
+ :little-endian (external-format-little-endian external-format))))))
+
+(defmethod print-object ((object external-format) stream)
+ "How an EXTERNAL-FORMAT object is rendered. Uses
+NORMALIZE-EXTERNAL-FORMAT."
+ (print-unreadable-object (object stream :type t :identity t)
+ (prin1 (normalize-external-format object) stream)))
--- /dev/null
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/flexi-streams/flexi-streams.asd,v 1.79 2008/08/26 10:59:22 edi Exp $
+
+;;; Copyright (c) 2005-2008, Dr. Edmund Weitz. All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;; * Redistributions of source code must retain the above copyright
+;;; notice, this list of conditions and the following disclaimer.
+
+;;; * 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 BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; 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 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.
+
+(in-package :cl-user)
+
+(defpackage :flexi-streams-system
+ (:use :asdf :cl))
+
+(in-package :flexi-streams-system)
+
+(defsystem :flexi-streams
+ :version "1.0.15"
+ :serial t
+ :description "Flexible bivalent streams for Common Lisp"
+ :components ((:file "packages")
+ (:file "mapping")
+ (:file "ascii")
+ (:file "koi8-r")
+ (:file "iso-8859")
+ (:file "code-pages")
+ (:file "specials")
+ (:file "util")
+ (:file "conditions")
+ (:file "external-format")
+ (:file "length")
+ (:file "encode")
+ (:file "decode")
+ (:file "in-memory")
+ (:file "stream")
+ #+:lispworks (:file "lw-char-stream")
+ (:file "output")
+ (:file "input")
+ (:file "io")
+ (:file "strings"))
+ :depends-on (:trivial-gray-streams))
+
+(defsystem :flexi-streams-test
+ :components ((:module "test"
+ :serial t
+ :components ((:file "packages")
+ (:file "test"))))
+ :depends-on (:flexi-streams))
+
+(defmethod perform ((o test-op) (c (eql (find-system 'flexi-streams))))
+ (operate 'load-op 'flexi-streams-test)
+ (funcall (intern (symbol-name :run-all-tests)
+ (find-package :flexi-streams-test))))
--- /dev/null
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: FLEXI-STREAMS; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/flexi-streams/in-memory.lisp,v 1.31 2008/05/19 07:57:07 edi Exp $
+
+;;; Copyright (c) 2005-2008, Dr. Edmund Weitz. All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;; * Redistributions of source code must retain the above copyright
+;;; notice, this list of conditions and the following disclaimer.
+
+;;; * 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 BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; 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 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.
+
+(in-package :flexi-streams)
+
+(defclass in-memory-stream (trivial-gray-stream-mixin)
+ ((transformer :initarg :transformer
+ :accessor in-memory-stream-transformer
+ :documentation "A function used to transform the
+written/read octet to the value stored/retrieved in/from the
+underlying vector.")
+ #+:cmu
+ (open-p :initform t
+ :accessor in-memory-stream-open-p
+ :documentation "For CMUCL we have to keep track of this
+manually."))
+ (:documentation "An IN-MEMORY-STREAM is a binary stream that reads
+octets from or writes octets to a sequence in RAM."))
+
+(defclass in-memory-input-stream (in-memory-stream fundamental-binary-input-stream)
+ ()
+ (:documentation "An IN-MEMORY-INPUT-STREAM is a binary stream that
+reads octets from a sequence in RAM."))
+
+#+:cmu
+(defmethod output-stream-p ((stream in-memory-input-stream))
+ "Explicitly states whether this is an output stream."
+ (declare (optimize speed))
+ nil)
+
+(defclass in-memory-output-stream (in-memory-stream fundamental-binary-output-stream)
+ ()
+ (:documentation "An IN-MEMORY-OUTPUT-STREAM is a binary stream that
+writes octets to a sequence in RAM."))
+
+#+:cmu
+(defmethod input-stream-p ((stream in-memory-output-stream))
+ "Explicitly states whether this is an input stream."
+ (declare (optimize speed))
+ nil)
+
+(defclass list-stream ()
+ ((list :initarg :list
+ :accessor list-stream-list
+ :documentation "The underlying list of the stream."))
+ (:documentation "A LIST-STREAM is a mixin for IN-MEMORY streams
+where the underlying sequence is a list."))
+
+(defclass vector-stream ()
+ ((vector :initarg :vector
+ :accessor vector-stream-vector
+ :documentation "The underlying vector of the stream which
+\(for output) must always be adjustable and have a fill pointer."))
+ (:documentation "A VECTOR-STREAM is a mixin for IN-MEMORY streams
+where the underlying sequence is a vector."))
+
+(defclass list-input-stream (list-stream in-memory-input-stream)
+ ()
+ (:documentation "A binary input stream that gets its data from an
+associated list of octets."))
+
+(defclass vector-input-stream (vector-stream in-memory-input-stream)
+ ((index :initarg :index
+ :accessor vector-stream-index
+ :type (integer 0 #.array-dimension-limit)
+ :documentation "An index into the underlying vector denoting
+the current position.")
+ (end :initarg :end
+ :accessor vector-stream-end
+ :type (integer 0 #.array-dimension-limit)
+ :documentation "An index into the underlying vector denoting
+the end of the available data."))
+ (:documentation "A binary input stream that gets its data from an
+associated vector of octets."))
+
+(defclass vector-output-stream (vector-stream in-memory-output-stream)
+ ()
+ (:documentation "A binary output stream that writes its data to an
+associated vector."))
+
+#+:cmu
+(defmethod open-stream-p ((stream in-memory-stream))
+ "Returns a true value if STREAM is open. See ANSI standard."
+ (declare #.*standard-optimize-settings*)
+ (in-memory-stream-open-p stream))
+
+#+:cmu
+(defmethod close ((stream in-memory-stream) &key abort)
+ "Closes the stream STREAM. See ANSI standard."
+ (declare #.*standard-optimize-settings*)
+ (declare (ignore abort))
+ (prog1
+ (in-memory-stream-open-p stream)
+ (setf (in-memory-stream-open-p stream) nil)))
+
+(defmethod check-if-open ((stream in-memory-stream))
+ "Checks if STREAM is open and signals an error otherwise."
+ (declare #.*standard-optimize-settings*)
+ (unless (open-stream-p stream)
+ (error 'in-memory-stream-closed-error
+ :stream stream)))
+
+(defmethod stream-element-type ((stream in-memory-stream))
+ "The element type is always OCTET by definition."
+ (declare #.*standard-optimize-settings*)
+ 'octet)
+
+(defmethod transform-octet ((stream in-memory-stream) octet)
+ "Applies the transformer of STREAM to octet and returns the result."
+ (declare #.*standard-optimize-settings*)
+ (funcall (or (in-memory-stream-transformer stream)
+ #'identity) octet))
+
+(defmethod stream-read-byte ((stream list-input-stream))
+ "Reads one byte by simply popping it off of the top of the list."
+ (declare #.*standard-optimize-settings*)
+ (check-if-open stream)
+ (with-accessors ((list list-stream-list))
+ stream
+ (transform-octet stream (or (pop list) (return-from stream-read-byte :eof)))))
+
+(defmethod stream-listen ((stream list-input-stream))
+ "Checks whether list is not empty."
+ (declare #.*standard-optimize-settings*)
+ (check-if-open stream)
+ (with-accessors ((list list-stream-list))
+ stream
+ list))
+
+(defmethod stream-read-sequence ((stream list-input-stream) sequence start end &key)
+ "Repeatedly pops elements from the list until it's empty."
+ (declare #.*standard-optimize-settings*)
+ (declare (fixnum start end))
+ (with-accessors ((list list-stream-list))
+ stream
+ (loop for index of-type fixnum from start below end
+ while list
+ do (setf (elt sequence index) (pop list))
+ finally (return index))))
+
+(defmethod stream-read-byte ((stream vector-input-stream))
+ "Reads one byte and increments INDEX pointer unless we're beyond
+END pointer."
+ (declare #.*standard-optimize-settings*)
+ (check-if-open stream)
+ (with-accessors ((index vector-stream-index)
+ (end vector-stream-end)
+ (vector vector-stream-vector))
+ stream
+ (let ((current-index index))
+ (declare (fixnum current-index))
+ (cond ((< current-index (the fixnum end))
+ (incf (the fixnum index))
+ (transform-octet stream (aref vector current-index)))
+ (t :eof)))))
+
+(defmethod stream-listen ((stream vector-input-stream))
+ "Checking whether INDEX is beyond END."
+ (declare #.*standard-optimize-settings*)
+ (check-if-open stream)
+ (with-accessors ((index vector-stream-index)
+ (end vector-stream-end))
+ stream
+ (< (the fixnum index) (the fixnum end))))
+
+(defmethod stream-read-sequence ((stream vector-input-stream) sequence start end &key)
+ "Traverses both sequences in parallel until the end of one of them
+is reached."
+ (declare #.*standard-optimize-settings*)
+ (declare (fixnum start end))
+ (loop with vector-end of-type fixnum = (vector-stream-end stream)
+ with vector = (vector-stream-vector stream)
+ for index of-type fixnum from start below end
+ for vector-index of-type fixnum = (vector-stream-index stream)
+ while (< vector-index vector-end)
+ do (setf (elt sequence index)
+ (aref vector vector-index))
+ (incf (the fixnum (vector-stream-index stream)))
+ finally (return index)))
+
+(defmethod stream-write-byte ((stream vector-output-stream) byte)
+ "Writes a byte \(octet) by extending the underlying vector."
+ (declare #.*standard-optimize-settings*)
+ (check-if-open stream)
+ (with-accessors ((vector vector-stream-vector))
+ stream
+ (vector-push-extend (transform-octet stream byte) vector)))
+
+(defmethod stream-write-sequence ((stream vector-output-stream) sequence start end &key)
+ "Just calls VECTOR-PUSH-EXTEND repeatedly."
+ (declare #.*standard-optimize-settings*)
+ (declare (fixnum start end))
+ (with-accessors ((vector vector-stream-vector))
+ stream
+ (loop for index of-type fixnum from start below end
+ do (vector-push-extend (transform-octet stream (elt sequence index)) vector))
+ sequence))
+
+(defmethod stream-file-position ((stream vector-input-stream))
+ "Simply returns the index into the underlying vector."
+ (declare #.*standard-optimize-settings*)
+ (with-accessors ((index vector-stream-index))
+ stream
+ index))
+
+(defmethod (setf stream-file-position) (position-spec (stream vector-input-stream))
+ "Sets the index into the underlying vector if POSITION-SPEC is acceptable."
+ (declare #.*standard-optimize-settings*)
+ (with-accessors ((index vector-stream-index)
+ (end vector-stream-end))
+ stream
+ (setq index
+ (case position-spec
+ (:start 0)
+ (:end end)
+ (otherwise
+ (unless (integerp position-spec)
+ (error 'in-memory-stream-position-spec-error
+ :format-control "Unknown file position designator: ~S."
+ :format-arguments (list position-spec)
+ :stream stream
+ :position-spec position-spec))
+ (unless (<= 0 position-spec end)
+ (error 'in-memory-stream-position-spec-error
+ :format-control "File position designator ~S is out of bounds."
+ :format-arguments (list position-spec)
+ :stream stream
+ :position-spec position-spec))
+ position-spec)))
+ position-spec))
+
+(defmethod stream-file-position ((stream vector-output-stream))
+ "Simply returns the fill pointer of the underlying vector."
+ (declare #.*standard-optimize-settings*)
+ (with-accessors ((vector vector-stream-vector))
+ stream
+ (fill-pointer vector)))
+
+(defmethod (setf stream-file-position) (position-spec (stream vector-output-stream))
+ "Sets the fill pointer underlying vector if POSITION-SPEC is
+acceptable. Adjusts the vector if necessary."
+ (declare #.*standard-optimize-settings*)
+ (with-accessors ((vector vector-stream-vector))
+ stream
+ (let* ((total-size (array-total-size vector))
+ (new-fill-pointer
+ (case position-spec
+ (:start 0)
+ (:end
+ (warn "File position designator :END doesn't really make sense for an output stream.")
+ total-size)
+ (otherwise
+ (unless (integerp position-spec)
+ (error 'in-memory-stream-position-spec-error
+ :format-control "Unknown file position designator: ~S."
+ :format-arguments (list position-spec)
+ :stream stream
+ :position-spec position-spec))
+ (unless (<= 0 position-spec array-total-size-limit)
+ (error 'in-memory-stream-position-spec-error
+ :format-control "File position designator ~S is out of bounds."
+ :format-arguments (list position-spec)
+ :stream stream
+ :position-spec position-spec))
+ position-spec))))
+ (declare (fixnum total-size new-fill-pointer))
+ (when (> new-fill-pointer total-size)
+ (adjust-array vector new-fill-pointer))
+ (setf (fill-pointer vector) new-fill-pointer)
+ position-spec)))
+
+(defmethod make-in-memory-input-stream ((vector vector) &key (start 0)
+ (end (length vector))
+ transformer)
+ "Returns a binary input stream which will supply, in order, the
+octets in the subsequence of VECTOR bounded by START and END.
+Each octet returned will be transformed in turn by the optional
+TRANSFORMER function."
+ (declare #.*standard-optimize-settings*)
+ (make-instance 'vector-input-stream
+ :vector vector
+ :index start
+ :end end
+ :transformer transformer))
+
+(defmethod make-in-memory-input-stream ((list list) &key (start 0)
+ (end (length list))
+ transformer)
+ "Returns a binary input stream which will supply, in order, the
+octets in the subsequence of LIST bounded by START and END. Each
+octet returned will be transformed in turn by the optional
+TRANSFORMER function."
+ (declare #.*standard-optimize-settings*)
+ (make-instance 'list-input-stream
+ :list (subseq list start end)
+ :transformer transformer))
+
+(defun make-output-vector (&key (element-type 'octet))
+ "Creates and returns an array which can be used as the underlying
+vector for a VECTOR-OUTPUT-STREAM."
+ (declare #.*standard-optimize-settings*)
+ (make-array 0 :adjustable t
+ :fill-pointer 0
+ :element-type element-type))
+
+(defun make-in-memory-output-stream (&key (element-type 'octet) transformer)
+ "Returns a binary output stream which accepts objects of type
+ELEMENT-TYPE \(a subtype of OCTET) and makes available a sequence
+that contains the octes that were actually output. The octets
+stored will each be transformed by the optional TRANSFORMER
+function."
+ (declare #.*standard-optimize-settings*)
+ (make-instance 'vector-output-stream
+ :vector (make-output-vector :element-type element-type)
+ :transformer transformer))
+
+(defmethod get-output-stream-sequence ((stream in-memory-output-stream) &key as-list)
+ "Returns a vector containing, in order, all the octets that have
+been output to the IN-MEMORY stream STREAM. This operation clears any
+octets on STREAM, so the vector contains only those octets which have
+been output since the last call to GET-OUTPUT-STREAM-SEQUENCE or since
+the creation of the stream, whichever occurred most recently. If
+AS-LIST is true the return value is coerced to a list."
+ (declare #.*standard-optimize-settings*)
+ (with-accessors ((vector vector-stream-vector))
+ stream
+ (prog1
+ (if as-list
+ (coerce vector 'list)
+ vector)
+ (setq vector
+ (make-output-vector)))))
+
+(defmethod output-stream-sequence-length ((stream in-memory-output-stream))
+ "Returns the current length of the underlying vector of the
+IN-MEMORY output stream STREAM."
+ (declare (optimize speed))
+ (with-accessors ((vector vector-stream-vector))
+ stream
+ (length (the (simple-array * (*)) vector))))
+
+(defmacro with-input-from-sequence ((var sequence &key start end transformer)
+ &body body)
+ "Creates an IN-MEMORY input stream from SEQUENCE using the
+parameters START and END, binds VAR to this stream and then
+executes the code in BODY. A function TRANSFORMER may optionally
+be specified to transform the returned octets. The stream is
+automatically closed on exit from WITH-INPUT-FROM-SEQUENCE, no
+matter whether the exit is normal or abnormal. The return value
+of this macro is the return value of BODY."
+ (with-rebinding (sequence)
+ `(let (,var)
+ (unwind-protect
+ (progn
+ (setq ,var (make-in-memory-input-stream ,sequence
+ :start (or ,start 0)
+ :end (or ,end (length ,sequence))
+ :transformer ,transformer))
+ ,@body)
+ (when ,var (close ,var))))))
+
+(defmacro with-output-to-sequence ((var &key as-list (element-type ''octet) transformer)
+ &body body)
+ "Creates an IN-MEMORY output stream, binds VAR to this stream
+and then executes the code in BODY. The stream stores data of
+type ELEMENT-TYPE \(a subtype of OCTET) which is \(optionally)
+transformed by the function TRANSFORMER prior to storage. The
+stream is automatically closed on exit from
+WITH-OUTPUT-TO-SEQUENCE, no matter whether the exit is normal or
+abnormal. The return value of this macro is a vector \(or a list
+if AS-LIST is true) containing the octets that were sent to the
+stream within BODY."
+ `(let (,var)
+ (unwind-protect
+ (progn
+ (setq ,var (make-in-memory-output-stream :element-type ,element-type
+ :transformer ,transformer))
+ ,@body
+ (get-output-stream-sequence ,var :as-list ,as-list))
+ (when ,var (close ,var)))))
--- /dev/null
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: FLEXI-STREAMS; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/flexi-streams/input.lisp,v 1.78 2008/05/25 19:25:44 edi Exp $
+
+;;; Copyright (c) 2005-2008, Dr. Edmund Weitz. All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;; * Redistributions of source code must retain the above copyright
+;;; notice, this list of conditions and the following disclaimer.
+
+;;; * 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 BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; 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 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.
+
+(in-package :flexi-streams)
+
+#-:lispworks
+(defmethod read-byte* ((flexi-input-stream flexi-input-stream))
+ "Reads one byte \(octet) from the underlying stream of
+FLEXI-OUTPUT-STREAM \(or from the internal stack if it's not
+empty)."
+ (declare #.*standard-optimize-settings*)
+ ;; we're using S instead of STREAM here because of an
+ ;; issue with SBCL:
+ ;; <http://article.gmane.org/gmane.lisp.steel-bank.general/1386>
+ (with-accessors ((position flexi-stream-position)
+ (bound flexi-stream-bound)
+ (octet-stack flexi-stream-octet-stack)
+ (s flexi-stream-stream))
+ flexi-input-stream
+ (declare (integer position)
+ (type (or null integer) bound))
+ (when (and bound
+ (>= position bound))
+ (return-from read-byte* nil))
+ (incf position)
+ (or (pop octet-stack)
+ (read-byte s nil nil)
+ (progn (decf position) nil))))
+
+#+:lispworks
+(defmethod read-byte* ((flexi-input-stream flexi-input-stream))
+ "Reads one byte \(octet) from the underlying \(binary) stream of
+FLEXI-OUTPUT-STREAM \(or from the internal stack if it's not empty)."
+ (declare #.*standard-optimize-settings*)
+ (with-accessors ((position flexi-stream-position)
+ (bound flexi-stream-bound)
+ (octet-stack flexi-stream-octet-stack)
+ (stream flexi-stream-stream))
+ flexi-input-stream
+ (declare (integer position)
+ (type (or null integer) bound))
+ (when (and bound
+ (>= position bound))
+ (return-from read-byte* nil))
+ (incf position)
+ (or (pop octet-stack)
+ (read-byte stream nil nil)
+ (progn (decf position) nil))))
+
+#+:lispworks
+(defmethod read-byte* ((flexi-input-stream flexi-char-input-stream))
+ "Reads one byte \(octet) from the underlying stream of
+FLEXI-OUTPUT-STREAM \(or from the internal stack if it's not empty).
+Only used for LispWorks bivalent streams which aren't binary."
+ (declare #.*standard-optimize-settings*)
+ (with-accessors ((position flexi-stream-position)
+ (bound flexi-stream-bound)
+ (octet-stack flexi-stream-octet-stack)
+ (stream flexi-stream-stream))
+ flexi-input-stream
+ (declare (integer position)
+ (type (or null integer) bound))
+ (when (and bound
+ (>= position bound))
+ (return-from read-byte* nil))
+ (incf position)
+ (or (pop octet-stack)
+ ;; we use READ-SEQUENCE because READ-BYTE doesn't work with all
+ ;; bivalent streams in LispWorks
+ (let* ((buffer (make-array 1 :element-type 'octet))
+ (new-position (read-sequence buffer stream)))
+ (cond ((zerop new-position)
+ (decf position) nil)
+ (t (aref buffer 0)))))))
+
+(defmethod stream-clear-input ((flexi-input-stream flexi-input-stream))
+ "Calls the corresponding method for the underlying input stream
+and also clears the value of the OCTET-STACK slot."
+ (declare #.*standard-optimize-settings*)
+ ;; note that we don't reset the POSITION slot
+ (with-accessors ((octet-stack flexi-stream-octet-stack)
+ (stream flexi-stream-stream))
+ flexi-input-stream
+ (setq octet-stack nil)
+ (clear-input stream)))
+
+(defmethod stream-listen ((flexi-input-stream flexi-input-stream))
+ "Calls the corresponding method for the underlying input stream
+but first checks if \(old) input is available in the OCTET-STACK
+slot."
+ (declare #.*standard-optimize-settings*)
+ (with-accessors ((position flexi-stream-position)
+ (bound flexi-stream-bound)
+ (octet-stack flexi-stream-octet-stack)
+ (stream flexi-stream-stream))
+ flexi-input-stream
+ (declare (integer position)
+ (type (or null integer) bound))
+ (when (and bound
+ (>= position bound))
+ (return-from stream-listen nil))
+ (or octet-stack (listen stream))))
+
+(defmethod stream-read-byte ((stream flexi-input-stream))
+ "Reads one byte \(octet) from the underlying stream."
+ (declare #.*standard-optimize-settings*)
+ ;; set LAST-CHAR-CODE slot to NIL because we can't UNREAD-CHAR after
+ ;; this operation
+ (with-accessors ((last-char-code flexi-stream-last-char-code)
+ (last-octet flexi-stream-last-octet))
+ stream
+ (setq last-char-code nil)
+ (let ((octet (read-byte* stream)))
+ (setq last-octet octet)
+ (or octet :eof))))
+
+(defun unread-char% (char flexi-input-stream)
+ "Used internally to put a character CHAR which was already read back
+on the stream. Uses the OCTET-STACK slot and decrements the POSITION
+slot accordingly."
+ (declare #.*standard-optimize-settings*)
+ (with-accessors ((position flexi-stream-position)
+ (octet-stack flexi-stream-octet-stack)
+ (external-format flexi-stream-external-format))
+ flexi-input-stream
+ (let ((counter 0) octets-reversed)
+ (declare (fixnum counter))
+ (flet ((writer (octet)
+ (incf counter)
+ (push octet octets-reversed)))
+ (declare (dynamic-extent (function writer)))
+ (char-to-octets external-format char #'writer)
+ (decf position counter)
+ (setq octet-stack (nreconc octets-reversed octet-stack))))))
+
+(defmethod stream-read-char ((stream flexi-input-stream))
+ (declare #.*standard-optimize-settings*)
+ ;; note that we do nothing for the :LF EOL style because we assume
+ ;; that #\Newline is the same as #\Linefeed in all Lisps which will
+ ;; use this library
+ (with-accessors ((external-format flexi-stream-external-format)
+ (last-octet flexi-stream-last-octet)
+ (last-char-code flexi-stream-last-char-code))
+ stream
+ ;; set LAST-OCTET slot to NIL because we can't UNREAD-BYTE after
+ ;; this operation
+ (setq last-octet nil)
+ (flet ((reader ()
+ (read-byte* stream))
+ (unreader (char)
+ (unread-char% char stream)))
+ (declare (dynamic-extent (function reader) (function unreader)))
+ (let* ((*current-unreader* #'unreader)
+ (char-code (or (octets-to-char-code external-format #'reader)
+ (return-from stream-read-char :eof))))
+ ;; remember this character and its char code for UNREAD-CHAR
+ (setq last-char-code char-code)
+ (or (code-char char-code) char-code)))))
+
+(defmethod stream-read-char-no-hang ((stream flexi-input-stream))
+ "Reads one character if the underlying stream has at least one
+octet available."
+ (declare #.*standard-optimize-settings*)
+ ;; note that this may block for non-8-bit encodings - I think
+ ;; there's no easy way to handle this correctly
+ (and (stream-listen stream)
+ (stream-read-char stream)))
+
+(defmethod stream-read-sequence ((flexi-input-stream flexi-input-stream) sequence start end &key)
+ "An optimized version which uses a buffer underneath. The function
+can deliver characters as well as octets and it decides what to do
+based on the element type of the sequence \(which takes precedence)
+and the element type of the stream. What you'll really get might also
+depend on your Lisp. Some of the implementations are more picky than
+others - see for example FLEXI-STREAMS-TEST::SEQUENCE-TEST."
+ (declare #.*standard-optimize-settings*)
+ (declare (fixnum start end))
+ (with-accessors ((octet-stack flexi-stream-octet-stack)
+ (external-format flexi-stream-external-format)
+ (last-octet flexi-stream-last-octet)
+ (last-char-code flexi-stream-last-char-code)
+ (element-type flexi-stream-element-type)
+ (stream flexi-stream-stream))
+ flexi-input-stream
+ (when (>= start end)
+ (return-from stream-read-sequence start))
+ (when (or (subtypep (etypecase sequence
+ (vector (array-element-type sequence))
+ (list t))
+ 'integer)
+ (and (not (stringp sequence))
+ (type-equal element-type 'octet)))
+ ;; if binary data is requested, just read from the underlying
+ ;; stream directly and skip the rest (but flush octet stack
+ ;; first)
+ (let ((index start))
+ (declare (fixnum index))
+ (when octet-stack
+ (replace sequence octet-stack :start1 start :end1 end)
+ (let ((octets-flushed (min (length octet-stack) (- end start))))
+ (incf index octets-flushed)
+ (setq octet-stack (nthcdr octets-flushed octet-stack))))
+ (setq index (read-sequence sequence stream :start index :end end))
+ (when (> index start)
+ (setq last-char-code nil
+ last-octet (elt sequence (1- index))))
+ (return-from stream-read-sequence index)))
+ ;; otherwise hand over to the external format to do the work
+ (read-sequence* external-format flexi-input-stream sequence start end)))
+
+(defmethod stream-unread-char ((stream flexi-input-stream) char)
+ "Implements UNREAD-CHAR for streams of type FLEXI-INPUT-STREAM.
+Makes sure CHAR will only be unread if it was the last character
+read and if it was read with the same encoding that's currently
+being used by the stream."
+ (declare #.*standard-optimize-settings*)
+ (with-accessors ((last-char-code flexi-stream-last-char-code))
+ stream
+ (unless last-char-code
+ (error 'flexi-stream-error
+ :format-control "No character to unread from this stream \(or external format has changed or last reading operation was binary)."))
+ (unless (= (char-code char) last-char-code)
+ (error 'flexi-stream-error
+ :format-control "Last character read (~S) was different from ~S."
+ :format-arguments (list (code-char last-char-code) char)))
+ (unread-char% char stream)
+ (setq last-char-code nil)
+ nil))
+
+(defmethod unread-byte (byte (flexi-input-stream flexi-input-stream))
+ "Similar to UNREAD-CHAR in that it `unreads' the last octet from
+STREAM. Note that you can only call UNREAD-BYTE after a corresponding
+READ-BYTE."
+ (declare #.*standard-optimize-settings*)
+ (with-accessors ((last-octet flexi-stream-last-octet)
+ (octet-stack flexi-stream-octet-stack)
+ (position flexi-stream-position))
+ flexi-input-stream
+ (unless last-octet
+ (error 'flexi-stream-error
+ :format-control "No byte to unread from this stream \(or last reading operation read a character)."))
+ (unless (= byte last-octet)
+ (error 'flexi-stream-error
+ :format-control "Last byte read was different from #x~X."
+ :format-arguments (list byte)))
+ (setq last-octet nil)
+ (decf (the integer position))
+ (push byte octet-stack)
+ nil))
+
+(defmethod peek-byte ((flexi-input-stream flexi-input-stream)
+ &optional peek-type (eof-error-p t) eof-value)
+ "PEEK-BYTE is like PEEK-CHAR, i.e. it returns an octet from
+FLEXI-INPUT-STREAM without actually removing it. If PEEK-TYPE is NIL
+the next octet is returned, if PEEK-TYPE is T, the next octet which is
+not 0 is returned, if PEEK-TYPE is an octet, the next octet which
+equals PEEK-TYPE is returned. EOF-ERROR-P and EOF-VALUE are
+interpreted as usual."
+ (declare #.*standard-optimize-settings*)
+ (loop for octet = (read-byte flexi-input-stream eof-error-p eof-value)
+ until (cond ((null peek-type))
+ ((eql octet eof-value))
+ ((eq peek-type t)
+ (plusp octet))
+ (t (= octet peek-type)))
+ finally (unless (eql octet eof-value)
+ (unread-byte octet flexi-input-stream))
+ (return octet)))
\ No newline at end of file
--- /dev/null
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: FLEXI-STREAMS; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/flexi-streams/io.lisp,v 1.2 2008/05/20 23:44:45 edi Exp $
+
+;;; Copyright (c) 2005-2008, Dr. Edmund Weitz. All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;; * Redistributions of source code must retain the above copyright
+;;; notice, this list of conditions and the following disclaimer.
+
+;;; * 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 BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; 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 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.
+
+(in-package :flexi-streams)
+
+(defmethod reset-input-state ((flexi-io-stream flexi-io-stream))
+ "This method is used to clear any state associated with previous
+input before output is attempted on the stream. It can fail if the
+octet stack is not empty and the stream can't be `rewound'."
+ (declare #.*standard-optimize-settings*)
+ (with-accessors ((last-char-code flexi-stream-last-char-code)
+ (last-octet flexi-stream-last-octet)
+ (octet-stack flexi-stream-octet-stack)
+ (stream flexi-stream-stream))
+ flexi-io-stream
+ (when octet-stack
+ (unless (maybe-rewind stream (length octet-stack))
+ (error 'flexi-stream-out-of-sync-error
+ :stream flexi-io-stream))
+ (setq octet-stack nil))
+ (setq last-octet nil
+ last-char-code nil)))
+
+(defmethod stream-write-byte :before ((stream flexi-io-stream) byte)
+ (declare #.*standard-optimize-settings*)
+ (declare (ignore byte))
+ (reset-input-state stream))
+
+(defmethod stream-write-char :before ((stream flexi-io-stream) char)
+ (declare #.*standard-optimize-settings*)
+ (declare (ignore char))
+ (reset-input-state stream))
+
+(defmethod stream-write-sequence :before ((stream flexi-io-stream) sequence start end &key)
+ (declare #.*standard-optimize-settings*)
+ (declare (ignore sequence start end))
+ (reset-input-state stream))
+
+(defmethod stream-clear-output :before ((stream flexi-io-stream))
+ (declare #.*standard-optimize-settings*)
+ (reset-input-state stream))
+
+(defmethod reset-output-state ((flexi-io-stream flexi-io-stream))
+ "This method is used to clear any state associated with previous
+output before the stream is used for input."
+ (declare #.*standard-optimize-settings*)
+ (with-accessors ((column flexi-stream-column))
+ flexi-io-stream
+ (setq column nil)))
+
+(defmethod stream-read-byte :before ((stream flexi-io-stream))
+ (declare #.*standard-optimize-settings*)
+ (reset-output-state stream))
+
+(defmethod stream-read-char :before ((stream flexi-io-stream))
+ (declare #.*standard-optimize-settings*)
+ (reset-output-state stream))
+
+(defmethod stream-read-sequence :before ((stream flexi-io-stream) sequence start end &key)
+ (declare #.*standard-optimize-settings*)
+ (declare (ignore sequence start end))
+ (reset-output-state stream))
+
+(defmethod stream-unread-char :before ((stream flexi-io-stream) char)
+ (declare #.*standard-optimize-settings*)
+ (declare (ignore char))
+ (reset-output-state stream))
+
+(defmethod unread-byte :before (byte (stream flexi-io-stream))
+ (declare #.*standard-optimize-settings*)
+ (declare (ignore byte))
+ (reset-output-state stream))
+
+(defmethod stream-clear-input :before ((stream flexi-io-stream))
+ (declare #.*standard-optimize-settings*)
+ (reset-output-state stream))
+
+(defmethod write-byte* :after (byte (stream flexi-io-stream))
+ "Keep POSITION slot up to date even when performing output."
+ (declare #.*standard-optimize-settings*)
+ (declare (ignore byte))
+ (with-accessors ((position flexi-stream-position))
+ stream
+ (incf position)))
\ No newline at end of file
--- /dev/null
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: FLEXI-STREAMS; Base: 10 -*-\r
+;;; $Header: /usr/local/cvsrep/flexi-streams/iso-8859.lisp,v 1.7 2008/05/18 21:32:15 edi Exp $\r
+\r
+;;; Copyright (c) 2005-2008, Dr. Edmund Weitz. All rights reserved.\r
+\r
+;;; Redistribution and use in source and binary forms, with or without\r
+;;; modification, are permitted provided that the following conditions\r
+;;; are met:\r
+\r
+;;; * Redistributions of source code must retain the above copyright\r
+;;; notice, this list of conditions and the following disclaimer.\r
+\r
+;;; * Redistributions in binary form must reproduce the above\r
+;;; copyright notice, this list of conditions and the following\r
+;;; disclaimer in the documentation and/or other materials\r
+;;; provided with the distribution.\r
+\r
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED\r
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED\r
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE\r
+;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY\r
+;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL\r
+;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE\r
+;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS\r
+;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,\r
+;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING\r
+;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS\r
+;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.\r
+\r
+(in-package :flexi-streams)\r
+\r
+;;; the following code was auto-generated from files which can be\r
+;;; found at <ftp://ftp.unicode.org/Public/MAPPINGS/ISO8859/>\r
+\r
+(defconstant +iso-8859-tables+\r
+ `((:iso-8859-1 . ,(make-decoding-table '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255))) \r
+ (:iso-8859-2 . ,(make-decoding-table '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 260 728 321 164 317 346 167 168 352 350 356 377 173 381 379 176 261 731 322 180 318 347 711 184 353 351 357 378 733 382 380 340 193 194 258 196 313 262 199 268 201 280 203 282 205 206 270 272 323 327 211 212 336 214 215 344 366 218 368 220 221 354 223 341 225 226 259 228 314 263 231 269 233 281 235 283 237 238 271 273 324 328 243 244 337 246 247 345 367 250 369 252 253 355 729))) \r
+ (:iso-8859-3 . ,(make-decoding-table '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 294 728 163 164 65533 292 167 168 304 350 286 308 173 65533 379 176 295 178 179 180 181 293 183 184 305 351 287 309 189 65533 380 192 193 194 65533 196 266 264 199 200 201 202 203 204 205 206 207 65533 209 210 211 212 288 214 215 284 217 218 219 220 364 348 223 224 225 226 65533 228 267 265 231 232 233 234 235 236 237 238 239 65533 241 242 243 244 289 246 247 285 249 250 251 252 365 349 729))) \r
+ (:iso-8859-4 . ,(make-decoding-table '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 260 312 342 164 296 315 167 168 352 274 290 358 173 381 175 176 261 731 343 180 297 316 711 184 353 275 291 359 330 382 331 256 193 194 195 196 197 198 302 268 201 280 203 278 205 206 298 272 325 332 310 212 213 214 215 216 370 218 219 220 360 362 223 257 225 226 227 228 229 230 303 269 233 281 235 279 237 238 299 273 326 333 311 244 245 246 247 248 371 250 251 252 361 363 729))) \r
+ (:iso-8859-5 . ,(make-decoding-table '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 173 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 8470 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 167 1118 1119))) \r
+ (:iso-8859-6 . ,(make-decoding-table '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 65533 65533 65533 164 65533 65533 65533 65533 65533 65533 65533 1548 173 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 1563 65533 65533 65533 1567 65533 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 65533 65533 65533 65533 65533 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533))) \r
+ (:iso-8859-7 . ,(make-decoding-table '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 8216 8217 163 8364 8367 166 167 168 169 890 171 172 173 65533 8213 176 177 178 179 900 901 902 183 904 905 906 187 908 189 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 65533 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 65533))) \r
+ (:iso-8859-8 . ,(make-decoding-table '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 65533 162 163 164 165 166 167 168 169 215 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 247 187 188 189 190 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 8215 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 65533 65533 8206 8207 65533))) \r
+ (:iso-8859-9 . ,(make-decoding-table '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 286 209 210 211 212 213 214 215 216 217 218 219 220 304 350 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 287 241 242 243 244 245 246 247 248 249 250 251 252 305 351 255))) \r
+ (:iso-8859-10 . ,(make-decoding-table '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 260 274 290 298 296 310 167 315 272 352 358 381 173 362 330 176 261 275 291 299 297 311 183 316 273 353 359 382 8213 363 331 256 193 194 195 196 197 198 302 268 201 280 203 278 205 206 207 208 325 332 211 212 213 214 360 216 370 218 219 220 221 222 223 257 225 226 227 228 229 230 303 269 233 281 235 279 237 238 239 240 326 333 243 244 245 246 361 248 371 250 251 252 253 254 312))) \r
+ (:iso-8859-11 . ,(make-decoding-table '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 3585 3586 3587 3588 3589 3590 3591 3592 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 3613 3614 3615 3616 3617 3618 3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 3629 3630 3631 3632 3633 3634 3635 3636 3637 3638 3639 3640 3641 3642 65533 65533 65533 65533 3647 3648 3649 3650 3651 3652 3653 3654 3655 3656 3657 3658 3659 3660 3661 3662 3663 3664 3665 3666 3667 3668 3669 3670 3671 3672 3673 3674 3675 65533 65533 65533 65533))) \r
+ (:iso-8859-13 . ,(make-decoding-table '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 8221 162 163 164 8222 166 167 216 169 342 171 172 173 174 198 176 177 178 179 8220 181 182 183 248 185 343 187 188 189 190 230 260 302 256 262 196 197 280 274 268 201 377 278 290 310 298 315 352 323 325 211 332 213 214 215 370 321 346 362 220 379 381 223 261 303 257 263 228 229 281 275 269 233 378 279 291 311 299 316 353 324 326 243 333 245 246 247 371 322 347 363 252 380 382 8217))) \r
+ (:iso-8859-14 . ,(make-decoding-table '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 7682 7683 163 266 267 7690 167 7808 169 7810 7691 7922 173 174 376 7710 7711 288 289 7744 7745 182 7766 7809 7767 7811 7776 7923 7812 7813 7777 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 372 209 210 211 212 213 214 7786 216 217 218 219 220 221 374 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 373 241 242 243 244 245 246 7787 248 249 250 251 252 253 375 255))) \r
+ (:iso-8859-15 . ,(make-decoding-table '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 8364 165 352 167 353 169 170 171 172 173 174 175 176 177 178 179 381 181 182 183 382 185 186 187 338 339 376 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255))) \r
+ (:iso-8859-16 . ,(make-decoding-table '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 260 261 321 8364 8222 352 167 353 169 536 171 377 173 378 379 176 177 268 322 381 8221 182 183 382 269 537 187 338 339 376 380 192 193 194 258 196 262 198 199 200 201 202 203 204 205 206 207 272 323 210 211 212 336 214 346 368 217 218 219 220 280 538 223 224 225 226 259 228 263 230 231 232 233 234 235 236 237 238 239 273 324 242 243 244 337 246 347 369 249 250 251 252 281 539 255))))\r
+ "A list of the ISO-8859 encodings where each element is a cons\r
+with the car being a keyword denoting the encoding and the cdr\r
+being a vector enumerating the corresponding character codes.")\r
--- /dev/null
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: FLEXI-STREAMS; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/flexi-streams/koi8-r.lisp,v 1.2 2008/05/18 21:32:15 edi Exp $
+
+;;; Copyright (c) 2006, Igor Plekhov. All rights reserved.
+;;; Copyright (c) 2006-2008, Dr. Edmund Weitz. All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;; * Redistributions of source code must retain the above copyright
+;;; notice, this list of conditions and the following disclaimer.
+
+;;; * 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 BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; 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 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.
+
+(in-package :flexi-streams)
+
+;; http://unicode.org/Public/MAPPINGS/VENDORS/MISC/KOI8-R.TXT
+(defconstant +koi8-r-table+
+ (make-decoding-table '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 9472 9474 9484 9488 9492 9496 9500 9508 9516 9524 9532 9600 9604 9608 9612 9616 9617 9618 9619 8992 9632 8729 8730 8776 8804 8805 160 8993 176 178 183 247 9552 9553 9554 1105 9555 9556 9557 9558 9559 9560 9561 9562 9563 9564 9565 9566 9567 9568 9569 1025 9570 9571 9572 9573 9574 9575 9576 9577 9578 9579 9580 169 1102 1072 1073 1094 1076 1077 1092 1075 1093 1080 1081 1082 1083 1084 1085 1086 1087 1103 1088 1089 1090 1091 1078 1074 1100 1099 1079 1096 1101 1097 1095 1098 1070 1040 1041 1062 1044 1045 1060 1043 1061 1048 1049 1050 1051 1052 1053 1054 1055 1071 1056 1057 1058 1059 1046 1042 1068 1067 1047 1064 1069 1065 1063 1066))
+ "An array enumerating the character codes for the KOI8-R encoding.")
--- /dev/null
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: FLEXI-STREAMS; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/flexi-streams/length.lisp,v 1.6 2008/05/29 10:25:14 edi Exp $
+
+;;; Copyright (c) 2005-2008, Dr. Edmund Weitz. All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;; * Redistributions of source code must retain the above copyright
+;;; notice, this list of conditions and the following disclaimer.
+
+;;; * 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 BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; 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 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.
+
+(in-package :flexi-streams)
+
+(defgeneric encoding-factor (format)
+ (:documentation "Given an external format FORMAT, returns a factor
+which denotes the octets to characters ratio to expect when
+encoding/decoding. If the returned value is an integer, the factor is
+assumed to be exact. If it is a \(double) float, the factor is
+supposed to be based on heuristics and usually not exact.
+
+This factor is used in string.lisp.")
+ (declare #.*standard-optimize-settings*))
+
+(defmethod encoding-factor ((format flexi-8-bit-format))
+ (declare #.*standard-optimize-settings*)
+ ;; 8-bit encodings map octets to characters in an exact one-to-one
+ ;; fashion
+ 1)
+
+(defmethod encoding-factor ((format flexi-utf-8-format))
+ (declare #.*standard-optimize-settings*)
+ ;; UTF-8 characters can be anything from one to six octets, but we
+ ;; assume that the "overhead" is only about 5 percent - this
+ ;; estimate is obviously very much dependant on the content
+ 1.05d0)
+
+(defmethod encoding-factor ((format flexi-utf-16-format))
+ (declare #.*standard-optimize-settings*)
+ ;; usually one character maps to two octets, but characters with
+ ;; code points above #x10000 map to four octets - we assume that we
+ ;; usually don't see these characters but of course have to return a
+ ;; float
+ 2.0d0)
+
+(defmethod encoding-factor ((format flexi-utf-32-format))
+ (declare #.*standard-optimize-settings*)
+ ;; UTF-32 always matches every character to four octets
+ 4)
+
+(defmethod encoding-factor ((format flexi-crlf-mixin))
+ (declare #.*standard-optimize-settings*)
+ ;; if the sequence #\Return #\Linefeed is the line-end marker, this
+ ;; obviously makes encodings potentially longer and definitely makes
+ ;; the estimate unexact
+ (* 1.02d0 (call-next-method)))
+
+(defgeneric check-end (format start end i)
+ (declare #.*fixnum-optimize-settings*)
+ (:documentation "Helper function used below to determine if we tried
+to read past the end of the sequence.")
+ (:method (format start end i)
+ (declare #.*fixnum-optimize-settings*)
+ (declare (ignore start))
+ (declare (fixnum end i))
+ (when (> i end)
+ (signal-encoding-error format "This sequence can't be decoded ~
+using ~A as it is too short. ~A octet~:P missing at the end."
+ (external-format-name format)
+ (- i end))))
+ (:method ((format flexi-utf-16-format) start end i)
+ (declare #.*fixnum-optimize-settings*)
+ (declare (fixnum start end i))
+ (declare (ignore i))
+ ;; don't warn twice
+ (when (evenp (- end start))
+ (call-next-method))))
+
+(defgeneric compute-number-of-chars (format sequence start end)
+ (declare #.*standard-optimize-settings*)
+ (:documentation "Computes the exact number of characters required to
+decode the sequence of octets in SEQUENCE from START to END using the
+external format FORMAT."))
+
+(defmethod compute-number-of-chars :around (format (list list) start end)
+ (declare #.*standard-optimize-settings*)
+ (call-next-method format (coerce list 'vector) start end))
+
+(defmethod compute-number-of-chars ((format flexi-8-bit-format) sequence start end)
+ (declare #.*fixnum-optimize-settings*)
+ (declare (fixnum start end))
+ (declare (ignore sequence))
+ (- end start))
+
+(defmethod compute-number-of-chars ((format flexi-crlf-mixin) sequence start end)
+ ;; this method only applies to the 8-bit formats as all other
+ ;; formats with CRLF line endings have their own specialized methods
+ ;; below
+ (declare #.*fixnum-optimize-settings*)
+ (declare (fixnum start end) (vector sequence))
+ (let ((i start)
+ (length (- end start)))
+ (declare (fixnum i length))
+ (loop
+ (when (>= i end)
+ (return))
+ (let ((position (search #.(vector +cr+ +lf+) sequence :start2 i :end2 end :test #'=)))
+ (unless position
+ (return))
+ (setq i (1+ position))
+ (decf length)))
+ length))
+
+(defmethod compute-number-of-chars ((format flexi-utf-8-format) sequence start end)
+ (declare #.*fixnum-optimize-settings*)
+ (declare (fixnum start end) (vector sequence))
+ (let ((sum 0)
+ (i start))
+ (declare (fixnum i sum))
+ (loop
+ (when (>= i end)
+ (return))
+ (let* ((octet (aref sequence i))
+ ;; note that there are no validity checks here
+ (length (cond ((not (logbitp 7 octet)) 1)
+ ((= #b11000000 (logand* octet #b11100000)) 2)
+ ((= #b11100000 (logand* octet #b11110000)) 3)
+ (t 4))))
+ (declare (fixnum length) (type octet octet))
+ (incf sum)
+ (incf i length)))
+ (check-end format start end i)
+ sum))
+
+(defmethod compute-number-of-chars ((format flexi-crlf-utf-8-format) sequence start end)
+ (declare #.*fixnum-optimize-settings*)
+ (declare (fixnum start end) (vector sequence))
+ (let ((sum 0)
+ (i start)
+ (last-octet 0))
+ (declare (fixnum i sum) (type octet last-octet))
+ (loop
+ (when (>= i end)
+ (return))
+ (let* ((octet (aref sequence i))
+ ;; note that there are no validity checks here
+ (length (cond ((not (logbitp 7 octet)) 1)
+ ((= #b11000000 (logand* octet #b11100000)) 2)
+ ((= #b11100000 (logand* octet #b11110000)) 3)
+ (t 4))))
+ (declare (fixnum length) (type octet octet))
+ (unless (and (= octet +lf+) (= last-octet +cr+))
+ (incf sum))
+ (incf i length)
+ (setq last-octet octet)))
+ (check-end format start end i)
+ sum))
+
+(defmethod compute-number-of-chars :before ((format flexi-utf-16-format) sequence start end)
+ (declare #.*fixnum-optimize-settings*)
+ (declare (fixnum start end) (vector sequence))
+ (declare (ignore sequence))
+ (when (oddp (- end start))
+ (signal-encoding-error format "~A octet~:P cannot be decoded ~
+using UTF-16 as ~:*~A is not even."
+ (- end start))))
+
+(defmethod compute-number-of-chars ((format flexi-utf-16-le-format) sequence start end)
+ (declare #.*fixnum-optimize-settings*)
+ (declare (fixnum start end))
+ (let ((sum 0)
+ (i start))
+ (declare (fixnum i sum))
+ (decf end 2)
+ (loop
+ (when (> i end)
+ (return))
+ (let* ((high-octet (aref sequence (1+ i)))
+ (length (cond ((<= #xd8 high-octet #xdf) 4)
+ (t 2))))
+ (declare (fixnum length) (type octet high-octet))
+ (incf sum)
+ (incf i length)))
+ (check-end format start (+ end 2) i)
+ sum))
+
+(defmethod compute-number-of-chars ((format flexi-utf-16-be-format) sequence start end)
+ (declare #.*fixnum-optimize-settings*)
+ (declare (fixnum start end) (vector sequence))
+ (let ((sum 0)
+ (i start))
+ (declare (fixnum i sum))
+ (decf end 2)
+ (loop
+ (when (> i end)
+ (return))
+ (let* ((high-octet (aref sequence i))
+ (length (cond ((<= #xd8 high-octet #xdf) 4)
+ (t 2))))
+ (declare (fixnum length) (type octet high-octet))
+ (incf sum)
+ (incf i length)))
+ (check-end format start (+ end 2) i)
+ sum))
+
+(defmethod compute-number-of-chars ((format flexi-crlf-utf-16-le-format) sequence start end)
+ (declare #.*fixnum-optimize-settings*)
+ (declare (fixnum start end) (vector sequence))
+ (let ((sum 0)
+ (i start)
+ (last-octet 0))
+ (declare (fixnum i sum) (type octet last-octet))
+ (decf end 2)
+ (loop
+ (when (> i end)
+ (return))
+ (let* ((high-octet (aref sequence (1+ i)))
+ (length (cond ((<= #xd8 high-octet #xdf) 4)
+ (t 2))))
+ (declare (fixnum length) (type octet high-octet))
+ (unless (and (zerop high-octet)
+ (= (the octet (aref sequence i)) +lf+)
+ (= last-octet +cr+))
+ (incf sum))
+ (setq last-octet (if (zerop high-octet)
+ (aref sequence i)
+ 0))
+ (incf i length)))
+ (check-end format start (+ end 2) i)
+ sum))
+
+(defmethod compute-number-of-chars ((format flexi-crlf-utf-16-be-format) sequence start end)
+ (declare #.*fixnum-optimize-settings*)
+ (declare (fixnum start end) (vector sequence))
+ (let ((sum 0)
+ (i start)
+ (last-octet 0))
+ (declare (fixnum i sum) (type octet last-octet))
+ (decf end 2)
+ (loop
+ (when (> i end)
+ (return))
+ (let* ((high-octet (aref sequence i))
+ (length (cond ((<= #xd8 high-octet #xdf) 4)
+ (t 2))))
+ (declare (fixnum length) (type octet high-octet))
+ (unless (and (zerop high-octet)
+ (= (the octet (aref sequence (1+ i))) +lf+)
+ (= last-octet +cr+))
+ (incf sum))
+ (setq last-octet (if (zerop high-octet)
+ (aref sequence (1+ i))
+ 0))
+ (incf i length)))
+ (check-end format start (+ end 2) i)
+ sum))
+
+(defmethod compute-number-of-chars :before ((format flexi-utf-32-format) sequence start end)
+ (declare #.*fixnum-optimize-settings*)
+ (declare (fixnum start end))
+ (declare (ignore sequence))
+ (let ((length (- end start)))
+ (when (plusp (mod length 4))
+ (signal-encoding-error format "~A octet~:P cannot be decoded ~
+using UTF-32 as ~:*~A is not a multiple-value of four."
+ length))))
+
+(defmethod compute-number-of-chars ((format flexi-utf-32-format) sequence start end)
+ (declare #.*fixnum-optimize-settings*)
+ (declare (fixnum start end))
+ (declare (ignore sequence))
+ (ceiling (- end start) 4))
+
+(defmethod compute-number-of-chars ((format flexi-crlf-utf-32-le-format) sequence start end)
+ (declare #.*fixnum-optimize-settings*)
+ (declare (fixnum start end) (vector sequence))
+ (let ((i start)
+ (length (ceiling (- end start) 4)))
+ (decf end 8)
+ (loop
+ (when (> i end)
+ (return))
+ (cond ((loop for j of-type fixnum from i
+ for octet across #.(vector +cr+ 0 0 0 +lf+ 0 0 0)
+ always (= octet (aref sequence j)))
+ (decf length)
+ (incf i 8))
+ (t (incf i 4))))
+ length))
+
+(defmethod compute-number-of-chars ((format flexi-crlf-utf-32-be-format) sequence start end)
+ (declare #.*fixnum-optimize-settings*)
+ (declare (fixnum start end) (vector sequence))
+ (let ((i start)
+ (length (ceiling (- end start) 4)))
+ (decf end 8)
+ (loop
+ (when (> i end)
+ (return))
+ (cond ((loop for j of-type fixnum from i
+ for octet across #.(vector 0 0 0 +cr+ 0 0 0 +lf+)
+ always (= octet (aref sequence j)))
+ (decf length)
+ (incf i 8))
+ (t (incf i 4))))
+ length))
+
+(defgeneric compute-number-of-octets (format sequence start end)
+ (declare #.*standard-optimize-settings*)
+ (:documentation "Computes the exact number of octets required to
+encode the sequence of characters in SEQUENCE from START to END using
+the external format FORMAT."))
+
+(defmethod compute-number-of-octets :around (format (list list) start end)
+ (declare #.*standard-optimize-settings*)
+ (call-next-method format (coerce list 'string*) start end))
+
+(defmethod compute-number-of-octets ((format flexi-8-bit-format) string start end)
+ (declare #.*fixnum-optimize-settings*)
+ (declare (fixnum start end))
+ (declare (ignore string))
+ (- end start))
+
+(defmethod compute-number-of-octets ((format flexi-utf-8-format) string start end)
+ (declare #.*fixnum-optimize-settings*)
+ (declare (fixnum start end) (string string))
+ (let ((sum 0)
+ (i start))
+ (declare (fixnum i sum))
+ (loop
+ (when (>= i end)
+ (return))
+ (let* ((char-code (char-code (char string i)))
+ (char-length (cond ((< char-code #x80) 1)
+ ((< char-code #x800) 2)
+ ((< char-code #x10000) 3)
+ (t 4))))
+ (declare (fixnum char-length) (type char-code-integer char-code))
+ (incf sum char-length)
+ (incf i)))
+ sum))
+
+(defmethod compute-number-of-octets ((format flexi-crlf-utf-8-format) string start end)
+ (declare #.*fixnum-optimize-settings*)
+ (declare (fixnum start end) (string string))
+ (let ((sum 0)
+ (i start))
+ (declare (fixnum i sum))
+ (loop
+ (when (>= i end)
+ (return))
+ (let* ((char-code (char-code (char string i)))
+ (char-length (cond ((= char-code #.(char-code #\Newline)) 2)
+ ((< char-code #x80) 1)
+ ((< char-code #x800) 2)
+ ((< char-code #x10000) 3)
+ (t 4))))
+ (declare (fixnum char-length) (type char-code-integer char-code))
+ (incf sum char-length)
+ (incf i)))
+ sum))
+
+(defmethod compute-number-of-octets ((format flexi-utf-16-format) string start end)
+ (declare #.*fixnum-optimize-settings*)
+ (declare (fixnum start end) (string string))
+ (let ((sum 0)
+ (i start))
+ (declare (fixnum i sum))
+ (loop
+ (when (>= i end)
+ (return))
+ (let* ((char-code (char-code (char string i)))
+ (char-length (cond ((< char-code #x10000) 2)
+ (t 4))))
+ (declare (fixnum char-length) (type char-code-integer char-code))
+ (incf sum char-length)
+ (incf i)))
+ sum))
+
+(defmethod compute-number-of-octets ((format flexi-crlf-utf-16-le-format) string start end)
+ (declare #.*fixnum-optimize-settings*)
+ (declare (fixnum start end) (string string))
+ (let ((sum 0)
+ (i start))
+ (declare (fixnum i sum))
+ (loop
+ (when (>= i end)
+ (return))
+ (let* ((char-code (char-code (char string i)))
+ (char-length (cond ((= char-code #.(char-code #\Newline)) 4)
+ ((< char-code #x10000) 2)
+ (t 4))))
+ (declare (fixnum char-length) (type char-code-integer char-code))
+ (incf sum char-length)
+ (incf i)))
+ sum))
+
+(defmethod compute-number-of-octets ((format flexi-crlf-utf-16-be-format) string start end)
+ (declare #.*fixnum-optimize-settings*)
+ (declare (fixnum start end) (string string))
+ (let ((sum 0)
+ (i start))
+ (declare (fixnum i sum))
+ (loop
+ (when (>= i end)
+ (return))
+ (let* ((char-code (char-code (char string i)))
+ (char-length (cond ((= char-code #.(char-code #\Newline)) 4)
+ ((< char-code #x10000) 2)
+ (t 4))))
+ (declare (fixnum char-length) (type char-code-integer char-code))
+ (incf sum char-length)
+ (incf i)))
+ sum))
+
+(defmethod compute-number-of-octets ((format flexi-utf-32-format) string start end)
+ (declare #.*fixnum-optimize-settings*)
+ (declare (fixnum start end))
+ (declare (ignore string))
+ (* 4 (- end start)))
+
+(defmethod compute-number-of-octets ((format flexi-crlf-mixin) string start end)
+ (declare #.*fixnum-optimize-settings*)
+ (declare (fixnum start end) (string string))
+ (+ (call-next-method)
+ (* (case (external-format-name format)
+ (:utf-32 4)
+ (otherwise 1))
+ (count #\Newline string :start start :end end :test #'char=))))
+
+(defgeneric character-length (format char)
+ (declare #.*fixnum-optimize-settings*)
+ (:documentation "Returns the number of octets needed to encode the
+single character CHAR.")
+ (:method (format char)
+ (compute-number-of-octets format (string char) 0 1)))
+
+(defmethod character-length :around ((format flexi-crlf-mixin) (char (eql #\Newline)))
+ (declare #.*fixnum-optimize-settings*)
+ (+ (call-next-method format +cr+)
+ (call-next-method format +lf+)))
+
+(defmethod character-length ((format flexi-8-bit-format) char)
+ (declare #.*fixnum-optimize-settings*)
+ (declare (ignore char))
+ 1)
+
+(defmethod character-length ((format flexi-utf-32-format) char)
+ (declare #.*fixnum-optimize-settings*)
+ (declare (ignore char))
+ 4)
\ No newline at end of file
--- /dev/null
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: FLEXI-STREAMS; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/flexi-streams/lw-char-stream.lisp,v 1.1 2008/05/23 14:43:09 edi Exp $
+
+;;; Copyright (c) 2005-2008, Dr. Edmund Weitz. All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;; * Redistributions of source code must retain the above copyright
+;;; notice, this list of conditions and the following disclaimer.
+
+;;; * 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 BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; 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 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.
+
+(in-package :flexi-streams)
+
+(defclass flexi-char-output-stream (flexi-output-stream)
+ ()
+ (:documentation "This class is for output streams where the
+underlying stream is bivalent but not binary. It exists solely for
+the purpose of optimizing output to binary streams on LispWorks. See
+WRITE-BYTE*."))
+
+(defclass flexi-char-input-stream (flexi-input-stream)
+ ()
+ (:documentation "This class is for input streams where the
+underlying stream is bivalent but not binary. It exists solely for
+the purpose of optimizing input to binary streams on LispWorks. See
+READ-BYTE*."))
+
+(defclass flexi-char-io-stream (flexi-char-input-stream flexi-char-output-stream flexi-io-stream)
+ ()
+ (:documentation "This class is for bidirectional streams where the
+underlying stream is bivalent but not binary. It exists solely for
+the purpose of optimizing input and output from/to binary streams on
+LispWorks. See READ-BYTE* and WRITE-BYTE*."))
+
+(defmethod initialize-instance :after ((flexi-stream flexi-output-stream) &rest initargs)
+ "Might change the class of FLEXI-STREAM for optimization purposes.
+Only needed for LispWorks."
+ (declare #.*standard-optimize-settings*)
+ (declare (ignore initargs))
+ (with-accessors ((stream flexi-stream-stream))
+ flexi-stream
+ (unless (subtypep (stream-element-type stream) 'octet)
+ (change-class flexi-stream
+ (typecase flexi-stream
+ (flexi-io-stream 'flexi-char-io-stream)
+ (otherwise 'flexi-char-output-stream))))))
+
+(defmethod initialize-instance :after ((flexi-stream flexi-input-stream) &rest initargs)
+ "Might change the class of FLEXI-STREAM for optimization purposes.
+Only needed for LispWorks."
+ (declare #.*standard-optimize-settings*)
+ (declare (ignore initargs))
+ (with-accessors ((stream flexi-stream-stream))
+ flexi-stream
+ (unless (subtypep (stream-element-type stream) 'octet)
+ (change-class flexi-stream
+ (typecase flexi-stream
+ (flexi-io-stream 'flexi-char-io-stream)
+ (otherwise 'flexi-char-input-stream))))))
--- /dev/null
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: FLEXI-STREAMS; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/flexi-streams/mapping.lisp,v 1.3 2008/05/25 19:07:53 edi Exp $
+
+;;; Copyright (c) 2005-2008, Dr. Edmund Weitz. All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;; * Redistributions of source code must retain the above copyright
+;;; notice, this list of conditions and the following disclaimer.
+
+;;; * 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 BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; 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 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.
+
+(in-package :flexi-streams)
+
+(deftype octet ()
+ "A shortcut for \(UNSIGNED-BYTE 8)."
+ '(unsigned-byte 8))
+
+(deftype char* ()
+ "Convenience shortcut to paper over the difference between LispWorks
+and the other Lisps."
+ #+:lispworks 'lw:simple-char
+ #-:lispworks 'character)
+
+(deftype string* ()
+ "Convenience shortcut to paper over the difference between LispWorks
+and the other Lisps."
+ #+:lispworks 'lw:text-string
+ #-:lispworks 'string)
+
+(deftype char-code-integer ()
+ "The subtype of integers which can be returned by the function CHAR-CODE."
+ #-:cmu '(integer 0 #.(1- char-code-limit))
+ #+:cmu '(integer 0 65533))
+
+(deftype code-point ()
+ "The subtype of integers that's just big enough to hold all Unicode
+codepoints.
+
+See for example <http://unicode.org/glossary/#C>."
+ '(mod #x110000))
+
+(defmacro defconstant (name value &optional doc)
+ "Make sure VALUE is evaluated only once \(to appease SBCL)."
+ `(cl:defconstant ,name (if (boundp ',name) (symbol-value ',name) ,value)
+ ,@(when doc (list doc))))
+
+(defun invert-table (table)
+ "`Inverts' an array which maps octets to character codes to a hash
+table which maps character codes to octets."
+ (let ((hash (make-hash-table)))
+ (loop for octet from 0
+ for char-code across table
+ unless (= char-code 65533)
+ do (setf (gethash char-code hash) octet))
+ hash))
+
+(defun make-decoding-table (list)
+ "Creates and returns an array which contains the elements in the
+list LIST and has an element type that's suitable for character
+codes."
+ (make-array (length list)
+ :element-type 'char-code-integer
+ :initial-contents list))
\ No newline at end of file
--- /dev/null
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: FLEXI-STREAMS; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/flexi-streams/output.lisp,v 1.65 2008/05/24 23:15:25 edi Exp $
+
+;;; Copyright (c) 2005-2008, Dr. Edmund Weitz. All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;; * Redistributions of source code must retain the above copyright
+;;; notice, this list of conditions and the following disclaimer.
+
+;;; * 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 BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; 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 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.
+
+(in-package :flexi-streams)
+
+(defgeneric write-byte* (byte stream)
+ (declare #.*standard-optimize-settings*)
+ (:documentation "Writes one byte \(octet) to the underlying stream
+STREAM."))
+
+#-:lispworks
+(defmethod write-byte* (byte (flexi-output-stream flexi-output-stream))
+ (declare #.*standard-optimize-settings*)
+ (with-accessors ((stream flexi-stream-stream))
+ flexi-output-stream
+ (write-byte byte stream)))
+
+#+:lispworks
+(defmethod write-byte* (byte (flexi-output-stream flexi-output-stream))
+ (declare #.*standard-optimize-settings*)
+ (with-accessors ((stream flexi-stream-stream))
+ flexi-output-stream
+ (write-byte byte stream)))
+
+#+:lispworks
+(defmethod write-byte* (byte (flexi-output-stream flexi-char-output-stream))
+ "This method is only used for LispWorks bivalent streams which
+aren't binary."
+ (declare #.*standard-optimize-settings*)
+ ;; we use WRITE-SEQUENCE because WRITE-BYTE doesn't work with all
+ ;; bivalent streams in LispWorks (4.4.6)
+ (with-accessors ((stream flexi-stream-stream))
+ flexi-output-stream
+ (write-sequence (make-array 1 :element-type 'octet
+ :initial-element byte)
+ stream)
+ byte))
+
+(defmethod stream-write-char ((stream flexi-output-stream) char)
+ (declare #.*standard-optimize-settings*)
+ (with-accessors ((external-format flexi-stream-external-format))
+ stream
+ (flet ((writer (octet)
+ (write-byte* octet stream)))
+ (declare (dynamic-extent (function writer)))
+ (char-to-octets external-format char #'writer))))
+
+(defmethod stream-write-char :after ((stream flexi-output-stream) char)
+ (declare #.*standard-optimize-settings*)
+ ;; update the column unless we're in the middle of the line and
+ ;; the current value is NIL
+ (with-accessors ((column flexi-stream-column))
+ stream
+ (cond ((char= char #\Newline) (setq column 0))
+ (column (incf (the integer column))))))
+
+(defmethod stream-clear-output ((flexi-output-stream flexi-output-stream))
+ "Simply calls the corresponding method for the underlying
+output stream."
+ (declare #.*standard-optimize-settings*)
+ (with-accessors ((stream flexi-stream-stream))
+ flexi-output-stream
+ (clear-output stream)))
+
+(defmethod stream-finish-output ((flexi-output-stream flexi-output-stream))
+ "Simply calls the corresponding method for the underlying
+output stream."
+ (declare #.*standard-optimize-settings*)
+ (with-accessors ((stream flexi-stream-stream))
+ flexi-output-stream
+ (finish-output stream)))
+
+(defmethod stream-force-output ((flexi-output-stream flexi-output-stream))
+ "Simply calls the corresponding method for the underlying
+output stream."
+ (declare #.*standard-optimize-settings*)
+ (with-accessors ((stream flexi-stream-stream))
+ flexi-output-stream
+ (force-output stream)))
+
+(defmethod stream-line-column ((flexi-output-stream flexi-output-stream))
+ "Returns the column stored in the COLUMN slot of the
+FLEXI-OUTPUT-STREAM object STREAM."
+ (declare #.*standard-optimize-settings*)
+ (with-accessors ((column flexi-stream-column))
+ flexi-output-stream
+ column))
+
+(defmethod stream-write-byte ((flexi-output-stream flexi-output-stream) byte)
+ "Writes a byte \(octet) to the underlying stream."
+ (declare #.*standard-optimize-settings*)
+ (with-accessors ((column flexi-stream-column))
+ flexi-output-stream
+ ;; set column to NIL because we don't know how to handle binary
+ ;; output mixed with character output
+ (setq column nil)
+ (write-byte* byte flexi-output-stream)))
+
+#+:allegro
+(defmethod stream-terpri ((stream flexi-output-stream))
+ "Writes a #\Newline character to the underlying stream."
+ (declare #.*standard-optimize-settings*)
+ ;; needed for AllegroCL - grrr...
+ (stream-write-char stream #\Newline))
+
+(defmethod stream-write-sequence ((flexi-output-stream flexi-output-stream) sequence start end &key)
+ "An optimized version which uses a buffer underneath. The function
+can accepts characters as well as octets and it decides what to do
+based on the element type of the sequence \(if possible) or on the
+individual elements, i.e. you can mix characters and octets in
+SEQUENCE if you want. Whether that really works might also depend on
+your Lisp, some of the implementations are more picky than others."
+ (declare #.*standard-optimize-settings*)
+ (declare (fixnum start end))
+ (with-accessors ((column flexi-stream-column)
+ (external-format flexi-stream-external-format)
+ (stream flexi-stream-stream))
+ flexi-output-stream
+ (when (>= start end)
+ (return-from stream-write-sequence sequence))
+ (when (and (vectorp sequence)
+ (subtypep (array-element-type sequence) 'integer))
+ ;; if this is pure binary output, just send all the stuff to the
+ ;; underlying stream directly and skip the rest
+ (setq column nil)
+ (return-from stream-write-sequence
+ (write-sequence sequence stream :start start :end end)))
+ ;; otherwise hand over to the external format to do the work
+ (write-sequence* external-format flexi-output-stream sequence start end))
+ sequence)
+
+(defmethod stream-write-string ((stream flexi-output-stream) string
+ &optional (start 0) (end (length string)))
+ "Simply hands over to the optimized method for STREAM-WRITE-SEQUENCE."
+ (declare #.*standard-optimize-settings*)
+ (stream-write-sequence stream string start (or end (length string))))
--- /dev/null
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/flexi-streams/packages.lisp,v 1.39 2008/05/30 07:50:31 edi Exp $
+
+;;; Copyright (c) 2005-2008, Dr. Edmund Weitz. All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;; * Redistributions of source code must retain the above copyright
+;;; notice, this list of conditions and the following disclaimer.
+
+;;; * 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 BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; 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 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.
+
+(in-package :cl-user)
+
+(unless (find-symbol (symbol-name :stream-file-position) :trivial-gray-streams)
+ (error "You need a newer version of TRIVIAL-GRAY-STREAMS."))
+
+(defpackage :flexi-streams
+ (:use :cl :trivial-gray-streams)
+ (:nicknames :flex)
+ (:shadow #+:lispworks :with-accessors
+ :defconstant)
+ (:export :*default-eol-style*
+ :*default-little-endian*
+ :*substitution-char*
+ :accept-overlong-sequence
+ :char-length
+ :external-format-condition
+ :external-format-condition-external-format
+ :external-format-eol-style
+ :external-format-error
+ :external-format-encoding-error
+ :external-format-equal
+ :external-format-id
+ :external-format-little-endian
+ :external-format-name
+ :flexi-input-stream
+ :flexi-output-stream
+ :flexi-io-stream
+ :flexi-stream
+ :flexi-stream-bound
+ :flexi-stream-column
+ :flexi-stream-external-format
+ :flexi-stream-element-type
+ :flexi-stream-element-type-error
+ :flexi-stream-element-type-error-element-type
+ :flexi-stream-error
+ :flexi-stream-out-of-sync-error
+ :flexi-stream-position
+ :flexi-stream-stream
+ :get-output-stream-sequence
+ :in-memory-stream
+ :in-memory-stream-closed-error
+ :in-memory-stream-error
+ :in-memory-stream-position-spec-error
+ :in-memory-stream-position-spec-error-position-spec
+ :in-memory-input-stream
+ :in-memory-output-stream
+ :list-stream
+ :make-external-format
+ :make-in-memory-input-stream
+ :make-in-memory-output-stream
+ :make-flexi-stream
+ :octet
+ :octet-length
+ :octets-to-string
+ :output-stream-sequence-length
+ :peek-byte
+ :string-to-octets
+ :unread-byte
+ :vector-stream
+ :with-input-from-sequence
+ :with-output-to-sequence))
--- /dev/null
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: FLEXI-STREAMS; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/flexi-streams/specials.lisp,v 1.33 2008/05/25 01:40:54 edi Exp $
+
+;;; Copyright (c) 2005-2008, Dr. Edmund Weitz. All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;; * Redistributions of source code must retain the above copyright
+;;; notice, this list of conditions and the following disclaimer.
+
+;;; * 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 BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; 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 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.
+
+(in-package :flexi-streams)
+
+(defvar *standard-optimize-settings*
+ '(optimize
+ speed
+ (safety 0)
+ (space 0)
+ (debug 1)
+ (compilation-speed 0))
+ "The standard optimize settings used by most declaration expressions.")
+
+(defvar *fixnum-optimize-settings*
+ '(optimize
+ speed
+ (safety 0)
+ (space 0)
+ (debug 1)
+ (compilation-speed 0)
+ #+:lispworks (hcl:fixnum-safety 0))
+ "Like *STANDARD-OPTIMIZE-SETTINGS*, but \(on LispWorks) with all
+arithmetic being fixnum arithmetic.")
+
+(defconstant +lf+ (char-code #\Linefeed))
+
+(defconstant +cr+ (char-code #\Return))
+
+(defvar *current-unreader* nil
+ "A unary function which might be called to `unread' a character
+\(i.e. the sequence of octets it represents).
+
+Used by the function OCTETS-TO-CHAR-CODE and must always be bound to a
+suitable functional object when this function is called.")
+
+(defvar +name-map+
+ '((:utf8 . :utf-8)
+ (:utf16 . :utf-16)
+ (:ucs2 . :utf-16)
+ (:ucs-2 . :utf-16)
+ (:unicode . :utf-16)
+ (:utf32 . :utf-32)
+ (:ucs4 . :utf-32)
+ (:ucs-4 . :utf-32)
+ (:ascii . :us-ascii)
+ (:koi8r . :koi8-r)
+ (:latin-1 . :iso-8859-1)
+ (:latin1 . :iso-8859-1)
+ (:latin-2 . :iso-8859-2)
+ (:latin2 . :iso-8859-2)
+ (:latin-3 . :iso-8859-3)
+ (:latin3 . :iso-8859-3)
+ (:latin-4 . :iso-8859-4)
+ (:latin4 . :iso-8859-4)
+ (:cyrillic . :iso-8859-5)
+ (:arabic . :iso-8859-6)
+ (:greek . :iso-8859-7)
+ (:hebrew . :iso-8859-8)
+ (:latin-5 . :iso-8859-9)
+ (:latin5 . :iso-8859-9)
+ (:latin-6 . :iso-8859-10)
+ (:latin6 . :iso-8859-10)
+ (:thai . :iso-8859-11)
+ (:latin-7 . :iso-8859-13)
+ (:latin7 . :iso-8859-13)
+ (:latin-8 . :iso-8859-14)
+ (:latin8 . :iso-8859-14)
+ (:latin-9 . :iso-8859-15)
+ (:latin9 . :iso-8859-15)
+ (:latin-0 . :iso-8859-15)
+ (:latin0 . :iso-8859-15)
+ (:latin-10 . :iso-8859-16)
+ (:latin10 . :iso-8859-16)
+ (:codepage . :code-page)
+ #+(and :lispworks :win32)
+ (win32:code-page . :code-page))
+ "An alist which mapes alternative names for external formats to
+their canonical counterparts.")
+
+(defvar +shortcut-map+
+ '((:ucs-2le . (:ucs-2 :little-endian t))
+ (:ucs-2be . (:ucs-2 :little-endian nil))
+ (:ucs-4le . (:ucs-4 :little-endian t))
+ (:ucs-4be . (:ucs-4 :little-endian nil))
+ (:utf-16le . (:utf-16 :little-endian t))
+ (:utf-16be . (:utf-16 :little-endian nil))
+ (:utf-32le . (:utf-32 :little-endian t))
+ (:utf-32be . (:utf-32 :little-endian nil))
+ (:ibm437 . (:code-page :id 437))
+ (:ibm850 . (:code-page :id 850))
+ (:ibm852 . (:code-page :id 852))
+ (:ibm855 . (:code-page :id 855))
+ (:ibm857 . (:code-page :id 857))
+ (:ibm860 . (:code-page :id 860))
+ (:ibm861 . (:code-page :id 861))
+ (:ibm862 . (:code-page :id 862))
+ (:ibm863 . (:code-page :id 863))
+ (:ibm864 . (:code-page :id 864))
+ (:ibm865 . (:code-page :id 865))
+ (:ibm866 . (:code-page :id 866))
+ (:ibm869 . (:code-page :id 869))
+ (:windows-1250 . (:code-page :id 1250))
+ (:windows-1251 . (:code-page :id 1251))
+ (:windows-1252 . (:code-page :id 1252))
+ (:windows-1253 . (:code-page :id 1253))
+ (:windows-1254 . (:code-page :id 1254))
+ (:windows-1255 . (:code-page :id 1255))
+ (:windows-1256 . (:code-page :id 1256))
+ (:windows-1257 . (:code-page :id 1257))
+ (:windows-1258 . (:code-page :id 1258)))
+ "An alist which maps shortcuts for external formats to their
+long forms.")
+
+(defvar *default-eol-style*
+ #+:win32 :crlf
+ #-:win32 :lf
+ "The end-of-line style used by external formats if none is
+explicitly given. Depends on the OS the code is compiled on.")
+
+(defvar *default-little-endian*
+ #+:little-endian t
+ #-:little-endian nil
+ "Whether external formats are little-endian by default
+\(i.e. unless explicitly specified). Depends on the platform
+the code is compiled on.")
+
+(defvar *substitution-char* nil
+ "If this value is not NIL, it should be a character which is used
+\(as if by a USE-VALUE restart) whenever during reading an error of
+type FLEXI-STREAM-ENCODING-ERROR would have been signalled otherwise.")
+
+(defconstant +iso-8859-hashes+
+ (loop for (name . table) in +iso-8859-tables+
+ collect (cons name (invert-table table)))
+ "An alist which maps names for ISO-8859 encodings to hash
+tables which map character codes to the corresponding octets.")
+
+(defconstant +code-page-hashes+
+ (loop for (id . table) in +code-page-tables+
+ collect (cons id (invert-table table)))
+ "An alist which maps IDs of Windows code pages to hash tables
+which map character codes to the corresponding octets.")
+
+(defconstant +ascii-hash+ (invert-table +ascii-table+)
+ "A hash table which maps US-ASCII character codes to the
+corresponding octets.")
+
+(defconstant +koi8-r-hash+ (invert-table +koi8-r-table+)
+ "A hash table which maps KOI8-R character codes to the
+corresponding octets.")
+
+(defconstant +buffer-size+ 8192
+ "Default size for buffers used for internal purposes.")
+
+(pushnew :flexi-streams *features*)
+
+;; stuff for Nikodemus Siivola's HYPERDOC
+;; see <http://common-lisp.net/project/hyperdoc/>
+;; and <http://www.cliki.net/hyperdoc>
+;; also used by LW-ADD-ONS
+
+(defvar *hyperdoc-base-uri* "http://weitz.de/flexi-streams/")
+
+(let ((exported-symbols-alist
+ (loop for symbol being the external-symbols of :flexi-streams
+ collect (cons symbol
+ (concatenate 'string
+ "#"
+ (string-downcase symbol))))))
+ (defun hyperdoc-lookup (symbol type)
+ (declare (ignore type))
+ (cdr (assoc symbol
+ exported-symbols-alist
+ :test #'eq))))
--- /dev/null
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: FLEXI-STREAMS; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/flexi-streams/stream.lisp,v 1.61 2008/05/19 22:32:56 edi Exp $
+
+;;; Copyright (c) 2005-2008, Dr. Edmund Weitz. All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;; * Redistributions of source code must retain the above copyright
+;;; notice, this list of conditions and the following disclaimer.
+
+;;; * 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 BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; 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 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.
+
+(in-package :flexi-streams)
+
+(defclass flexi-stream (trivial-gray-stream-mixin)
+ ((stream :initarg :stream
+ :reader flexi-stream-stream
+ :documentation "The actual stream that's used for
+input and/or output. It must be capable of reading/writing
+octets with READ-SEQUENCE and/or WRITE-SEQUENCE.")
+ (external-format :initform (make-external-format :iso-8859-1)
+ :initarg :flexi-stream-external-format
+ :accessor flexi-stream-external-format
+ :documentation "The encoding currently used
+by this stream. Can be changed on the fly.")
+ (element-type :initform 'char*
+ :initarg :element-type
+ :accessor flexi-stream-element-type
+ :documentation "The element type of this stream."))
+ (:documentation "A FLEXI-STREAM object is a stream that's
+`layered' atop an existing binary/bivalent stream in order to
+allow for multi-octet external formats. FLEXI-STREAM itself is a
+mixin and should not be instantiated."))
+
+(defmethod initialize-instance :after ((flexi-stream flexi-stream) &rest initargs)
+ "Makes sure the EXTERNAL-FORMAT and ELEMENT-TYPE slots contain
+reasonable values."
+ (declare #.*standard-optimize-settings*)
+ (declare (ignore initargs))
+ (with-accessors ((external-format flexi-stream-external-format)
+ (element-type flexi-stream-element-type))
+ flexi-stream
+ (unless (or (subtypep element-type 'character)
+ (subtypep element-type 'octet))
+ (error 'flexi-stream-element-type-error
+ :element-type element-type
+ :stream flexi-stream))
+ (setq external-format (maybe-convert-external-format external-format))))
+
+(defmethod (setf flexi-stream-external-format) :around (new-value (flexi-stream flexi-stream))
+ "Converts the new value to an EXTERNAL-FORMAT object if
+necessary."
+ (declare #.*standard-optimize-settings*)
+ (call-next-method (maybe-convert-external-format new-value) flexi-stream))
+
+(defmethod (setf flexi-stream-element-type) :before (new-value (flexi-stream flexi-stream))
+ "Checks whether the new value makes sense before it is set."
+ (declare #.*standard-optimize-settings*)
+ (unless (or (subtypep new-value 'character)
+ (type-equal new-value 'octet))
+ (error 'flexi-stream-element-type-error
+ :element-type new-value
+ :stream flexi-stream)))
+
+(defmethod stream-element-type ((stream flexi-stream))
+ "Returns the element type that was provided by the creator of
+the stream."
+ (declare #.*standard-optimize-settings*)
+ (with-accessors ((element-type flexi-stream-element-type))
+ stream
+ element-type))
+
+(defmethod close ((stream flexi-stream) &key abort)
+ "Closes the flexi stream by closing the underlying `real'
+stream."
+ (declare #.*standard-optimize-settings*)
+ (with-accessors ((stream flexi-stream-stream))
+ stream
+ (cond ((open-stream-p stream)
+ (close stream :abort abort))
+ (t nil))))
+
+(defmethod open-stream-p ((stream flexi-stream))
+ "A flexi stream is open if its underlying stream is open."
+ (declare #.*standard-optimize-settings*)
+ (with-accessors ((stream flexi-stream-stream))
+ stream
+ (open-stream-p stream)))
+
+(defmethod stream-file-position ((stream flexi-stream))
+ "Dispatch to method for underlying stream."
+ (declare #.*standard-optimize-settings*)
+ (with-accessors ((stream flexi-stream-stream))
+ stream
+ (file-position stream)))
+
+(defmethod (setf stream-file-position) (position-spec (stream flexi-stream))
+ "Dispatch to method for underlying stream."
+ (declare #.*standard-optimize-settings*)
+ (with-accessors ((underlying-stream flexi-stream-stream))
+ stream
+ (if (file-position underlying-stream position-spec)
+ (setf (flexi-stream-position stream) (file-position underlying-stream))
+ nil)))
+
+(defclass flexi-output-stream (flexi-stream fundamental-binary-output-stream
+ fundamental-character-output-stream)
+ ((column :initform 0
+ :accessor flexi-stream-column
+ :documentation "The current output column. A
+non-negative integer or NIL."))
+ (:documentation "A FLEXI-OUTPUT-STREAM is a FLEXI-STREAM that
+can actually be instatiated and used for output. Don't use
+MAKE-INSTANCE to create a new FLEXI-OUTPUT-STREAM but use
+MAKE-FLEXI-STREAM instead."))
+
+#+:cmu
+(defmethod input-stream-p ((stream flexi-output-stream))
+ "Explicitly states whether this is an input stream."
+ (declare #.*standard-optimize-settings*)
+ nil)
+
+(defclass flexi-input-stream (flexi-stream fundamental-binary-input-stream
+ fundamental-character-input-stream)
+ ((last-char-code :initform nil
+ :accessor flexi-stream-last-char-code
+ :documentation "This slot either holds NIL or the
+last character \(code) read successfully. This is mainly used for
+UNREAD-CHAR sanity checks.")
+ (last-octet :initform nil
+ :accessor flexi-stream-last-octet
+ :documentation "This slot either holds NIL or the last
+octet read successfully from the stream using a `binary' operation
+such as READ-BYTE. This is mainly used for UNREAD-BYTE sanity
+checks.")
+ (octet-stack :initform nil
+ :accessor flexi-stream-octet-stack
+ :documentation "A small buffer which holds octets
+that were already read from the underlying stream but not yet
+used to produce characters. This is mainly used if we have to
+look ahead for a CR/LF line ending.")
+ (position :initform 0
+ :initarg :position
+ :type integer
+ :accessor flexi-stream-position
+ :documentation "The position within the stream where each
+octet read counts as one.")
+ (bound :initform nil
+ :initarg :bound
+ :type (or null integer)
+ :accessor flexi-stream-bound
+ :documentation "When this is not NIL, it must be an integer
+and the stream will behave as if no more data is available as soon as
+POSITION is greater or equal than this value."))
+ (:documentation "A FLEXI-INPUT-STREAM is a FLEXI-STREAM that
+can actually be instatiated and used for input. Don't use
+MAKE-INSTANCE to create a new FLEXI-INPUT-STREAM but use
+MAKE-FLEXI-STREAM instead."))
+
+#+:cmu
+(defmethod output-stream-p ((stream flexi-input-stream))
+ "Explicitly states whether this is an output stream."
+ (declare #.*standard-optimize-settings*)
+ nil)
+
+(defclass flexi-io-stream (flexi-input-stream flexi-output-stream)
+ ()
+ (:documentation "A FLEXI-IO-STREAM is a FLEXI-STREAM that can
+actually be instatiated and used for input and output. Don't use
+MAKE-INSTANCE to create a new FLEXI-IO-STREAM but use
+MAKE-FLEXI-STREAM instead."))
+
+#+:cmu
+(defmethod input-stream-p ((stream flexi-io-stream))
+ "Explicitly states whether this is an input stream."
+ (declare #.*standard-optimize-settings*)
+ t)
+
+#+:cmu
+(defmethod output-stream-p ((stream flexi-io-stream))
+ "Explicitly states whether this is an output stream."
+ (declare #.*standard-optimize-settings*)
+ t)
+
+(defun make-flexi-stream (stream &rest args
+ &key (external-format (make-external-format :iso-8859-1))
+ element-type column position bound)
+ "Creates and returns a new flexi stream. STREAM must be an open
+binary or `bivalent' stream, i.e. it must be capable of
+reading/writing octets with READ-SEQUENCE and/or WRITE-SEQUENCE. The
+resulting flexi stream is an input stream if and only if STREAM is an
+input stream. Likewise, it's an output stream if and only if STREAM
+is an output stream. The default for ELEMENT-TYPE is LW:SIMPLE-CHAR
+on LispWorks and CHARACTER on other Lisps. EXTERNAL-FORMAT must be an
+EXTERNAL-FORMAT object or a symbol or a list denoting such an object.
+COLUMN is the initial column of the stream which is either a
+non-negative integer or NIL. The COLUMN argument must only be used
+for output streams. POSITION \(only used for input streams) should be
+an integer and it denotes the position the stream is in - it will be
+increased by one for each octet read. BOUND \(only used for input
+streams) should be NIL or an integer. If BOUND is not NIL and
+POSITION has gone beyond BOUND, then the stream will behave as if no
+more input is available."
+ (declare #.*standard-optimize-settings*)
+ ;; these arguments are ignored - they are only there to provide a
+ ;; meaningful parameter list for IDEs
+ (declare (ignore element-type column position bound))
+ (unless (and (streamp stream)
+ (open-stream-p stream))
+ (error "~S should have been an open stream." stream))
+ (apply #'make-instance
+ ;; actual type depends on STREAM
+ (cond ((and (input-stream-p stream)
+ (output-stream-p stream))
+ 'flexi-io-stream)
+ ((input-stream-p stream)
+ 'flexi-input-stream)
+ ((output-stream-p stream)
+ 'flexi-output-stream)
+ (t
+ (error "~S is neither an input nor an output stream." stream)))
+ :stream stream
+ :flexi-stream-external-format external-format
+ (sans args :external-format)))
--- /dev/null
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: FLEXI-STREAMS; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/flexi-streams/strings.lisp,v 1.34 2008/05/26 10:55:08 edi Exp $
+
+;;; Copyright (c) 2005-2008, Dr. Edmund Weitz. All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;; * Redistributions of source code must retain the above copyright
+;;; notice, this list of conditions and the following disclaimer.
+
+;;; * 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 BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; 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 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.
+
+(in-package :flexi-streams)
+
+(defun string-to-octets (string &key
+ (external-format :latin1)
+ (start 0) (end (length string)))
+ "Converts the Lisp string STRING from START to END to an array of
+octets corresponding to the external format designated by
+EXTERNAL-FORMAT.
+
+In spite of the name, STRING can be any sequence of characters, but
+the function is optimized for strings."
+ (declare #.*standard-optimize-settings*)
+ (setq external-format (maybe-convert-external-format external-format))
+ ;; the external format knows how to do it...
+ (string-to-octets* external-format string start end))
+
+(defun octets-to-string (sequence &key
+ (external-format :latin1)
+ (start 0) (end (length sequence)))
+ "Converts the Lisp sequence SEQUENCE of octets from START to END to
+a string using the external format designated by EXTERNAL-FORMAT.
+
+This function is optimized for the case of SEQUENCE being a vector.
+Don't use lists if you're in a hurry."
+ (declare #.*standard-optimize-settings*)
+ (declare (fixnum start end))
+ (setq external-format (maybe-convert-external-format external-format))
+ ;; the external format knows how to do it...
+ (octets-to-string* external-format sequence start end))
+
+(defun octet-length (string &key (external-format :latin1) (start 0) (end (length string)))
+ "Returns the length of the substring of STRING from START to END in
+octets if encoded using the external format EXTERNAL-FORMAT.
+
+In spite of the name, STRING can be any sequence of characters, but
+the function is optimized for strings."
+ (declare #.*standard-optimize-settings*)
+ (declare (fixnum start end))
+ (setq external-format (maybe-convert-external-format external-format))
+ (compute-number-of-octets external-format string start end))
+
+(defun char-length (sequence &key (external-format :latin1) (start 0) (end (length sequence)))
+ "Kind of the inverse of OCTET-LENGTH. Returns the length of the
+subsequence \(of octets) of SEQUENCE from START to END in characters
+if decoded using the external format EXTERNAL-FORMAT. Note that this
+function doesn't check for the validity of the data in SEQUENCE.
+
+This function is optimized for the case of SEQUENCE being a vector.
+Don't use lists if you're in a hurry."
+ (declare #.*standard-optimize-settings*)
+ (declare (fixnum start end))
+ (setq external-format (maybe-convert-external-format external-format))
+ (compute-number-of-chars external-format sequence start end))
--- /dev/null
+The reference files in this directory were created/converted using a
+mixture of GNU recode and the native internationalization facilities
+of LispWorks and AllegroCL, i.e. we're not testing FLEXI-STREAMS
+against files created by itself (which would be kind of useless).
\ No newline at end of file
--- /dev/null
+:õøàä úàå íéîùä úà íéäìà àøá úéùàøá à 1\ríåäú éðô-ìò êùçå åäáå åäú äúéä õøàäå á 2\r:íéîä éðô-ìò úôçøî íéäìà çåøå\r:øåà-éäéå øåà éäé íéäìà øîàéå â 3\ríéäìà ìãáéå áåè-éë øåàä-úà íéäìà àøéå ã 4\r:êùçä ïéáå øåàä ïéá\räìéì àø÷ êùçìå íåé øåàì íéäìà àø÷éå ä 5\r:ãçà íåé ø÷á-éäéå áøò-éäéå\réäéå íéîä êåúá òé÷ø éäé íéäìà øîàéå å 6\r:íéîì íéî ïéá ìéãáî\røùà íéîä ïéá ìãáéå òé÷øä-úà íéäìà ùòéå æ 7\ròé÷øì ìòî øùà íéîä ïéáå òé÷øì úçúî\r:ïë-éäéå\rø÷á-éäéå áøò-éäéå íéîù òé÷øì íéäìà àø÷éå ç 8\r:éðù íåé\ríå÷î-ìà íéîùä úçúî íéîä åå÷é íéäìà øîàéå è 9\r:ïë-éäéå äùáéä äàøúå ãçà\ràø÷ íéîä äå÷îìå õøà äùáéì íéäìà àø÷éå é 10\r:áåè-éë íéäìà àøéå íéîé\ròøæ òéøæî áùò àùã õøàä àùãú íéäìà øîàéå àé 11\rõøàä-ìò åá-åòøæ øùà åðéîì éøô äùò éøô õò\r:ïë-éäéå\rõòå åäðéîì òøæ òéøæî áùò àùã õøàä àöåúå áé 12\ríéäìà àøéå åäðéîì åá-åòøæ øùà éøô-äùò\r:áåè-éë\r:éùéìù íåé ø÷á-éäéå áøò-éäéå âé 13\rìéãáäì íéîùä òé÷øá úøàî éäé íéäìà øîàéå ãé 14\ríéãòåîìå úúàì åéäå äìéìä ïéáå íåéä ïéá\r:íéðùå íéîéìå\rõøàä-ìò øéàäì íéîùä òé÷øá úøåàîì åéäå åè 15\r:ïë-éäéå\røåàîä-úà íéìãâä úøàîä éðù-úà íéäìà ùòéå æè 16\rúìùîîì ïè÷ä øåàîä-úàå íåéä úìùîîì ìãâä\r:íéáëåëä úàå äìéìä\røéàäì íéîùä òé÷øá íéäìà íúà ïúéå æé 17\r:õøàä-ìò\rïéáå øåàä ïéá ìéãáäìå äìéìáå íåéá ìùîìå çé 18\r:áåè-éë íéäìà àøéå êùçä\r:éòéáø íåé ø÷á-éäéå áøò-éäéå èé 19\róåòå äéç ùôð õøù íéîä åöøùé íéäìà øîàéå ë 20\r:íéîùä òé÷ø éðô-ìò õøàä-ìò óôåòé\rùôð-ìë úàå íéìãâä íðéðúä-úà íéäìà àøáéå àë 21\rúàå íäðéîì íéîä åöøù øùà úùîøä äéçä\r:áåè-éë íéäìà àøéå åäðéîì óðë óåò-ìë\råàìîå åáøå åøô øîàì íéäìà íúà êøáéå áë 22\r:õøàá áøé óåòäå íéîéá íéîä-úà\r:éùéîç íåé ø÷á-éäéå áøò-éäéå âë 23\räîäá äðéîì äéç ùôð õøàä àöåú íéäìà øîàéå ãë 24\r:ïë-éäéå äðéîì õøà-åúéçå ùîøå\räîäáä-úàå äðéîì õøàä úéç-úà íéäìà ùòéå äë 25\ríéäìà àøéå åäðéîì äîãàä ùîø-ìë úàå äðéîì\r:áåè-éë\råðúåîãë åðîìöá íãà äùòð íéäìà øîàéå åë 26\räîäááå íéîùä óåòáå íéä úâãá åãøéå\r:õøàä-ìò ùîøä ùîøä-ìëáå õøàä-ìëáå\ràøá íéäìà íìöá åîìöá íãàä-úà íéäìà àøáéå æë 27\r:íúà àøá äá÷ðå øëæ åúà\råáøå åøô íéäìà íäì øîàéå íéäìà íúà êøáéå çë 28\róåòáå íéä úâãá åãøå äùáëå õøàä-úà åàìîå\r:õøàä-ìò úùîøä äéç-ìëáå íéîùä\ròøæ áùò-ìë-úà íëì éúúð äðä íéäìà øîàéå èë 29\råá-øùà õòä-ìë-úàå õøàä-ìë éðô-ìò øùà òøæ\r:äìëàì äéäé íëì òøæ òøæ õò-éøô\rùîåø ìëìå íéîùä óåò-ìëìå õøàä úéç-ìëìå ì 30\ráùò ÷øé-ìë-úà äéç ùôð åá-øùà õøàä-ìò\r:ïë-éäéå äìëàì\rãàî áåè-äðäå äùò øùà-ìë-úà íéäìà àøéå àì 31\r:éùùä íåé ø÷á-éäéå áø\r
\ No newline at end of file
--- /dev/null
+:õøàä úàå íéîùä úà íéäìà àøá úéùàøá à 1\r
+íåäú éðô-ìò êùçå åäáå åäú äúéä õøàäå á 2\r
+:íéîä éðô-ìò úôçøî íéäìà çåøå\r
+:øåà-éäéå øåà éäé íéäìà øîàéå â 3\r
+íéäìà ìãáéå áåè-éë øåàä-úà íéäìà àøéå ã 4\r
+:êùçä ïéáå øåàä ïéá\r
+äìéì àø÷ êùçìå íåé øåàì íéäìà àø÷éå ä 5\r
+:ãçà íåé ø÷á-éäéå áøò-éäéå\r
+éäéå íéîä êåúá òé÷ø éäé íéäìà øîàéå å 6\r
+:íéîì íéî ïéá ìéãáî\r
+øùà íéîä ïéá ìãáéå òé÷øä-úà íéäìà ùòéå æ 7\r
+òé÷øì ìòî øùà íéîä ïéáå òé÷øì úçúî\r
+:ïë-éäéå\r
+ø÷á-éäéå áøò-éäéå íéîù òé÷øì íéäìà àø÷éå ç 8\r
+:éðù íåé\r
+íå÷î-ìà íéîùä úçúî íéîä åå÷é íéäìà øîàéå è 9\r
+:ïë-éäéå äùáéä äàøúå ãçà\r
+àø÷ íéîä äå÷îìå õøà äùáéì íéäìà àø÷éå é 10\r
+:áåè-éë íéäìà àøéå íéîé\r
+òøæ òéøæî áùò àùã õøàä àùãú íéäìà øîàéå àé 11\r
+õøàä-ìò åá-åòøæ øùà åðéîì éøô äùò éøô õò\r
+:ïë-éäéå\r
+õòå åäðéîì òøæ òéøæî áùò àùã õøàä àöåúå áé 12\r
+íéäìà àøéå åäðéîì åá-åòøæ øùà éøô-äùò\r
+:áåè-éë\r
+:éùéìù íåé ø÷á-éäéå áøò-éäéå âé 13\r
+ìéãáäì íéîùä òé÷øá úøàî éäé íéäìà øîàéå ãé 14\r
+íéãòåîìå úúàì åéäå äìéìä ïéáå íåéä ïéá\r
+:íéðùå íéîéìå\r
+õøàä-ìò øéàäì íéîùä òé÷øá úøåàîì åéäå åè 15\r
+:ïë-éäéå\r
+øåàîä-úà íéìãâä úøàîä éðù-úà íéäìà ùòéå æè 16\r
+úìùîîì ïè÷ä øåàîä-úàå íåéä úìùîîì ìãâä\r
+:íéáëåëä úàå äìéìä\r
+øéàäì íéîùä òé÷øá íéäìà íúà ïúéå æé 17\r
+:õøàä-ìò\r
+ïéáå øåàä ïéá ìéãáäìå äìéìáå íåéá ìùîìå çé 18\r
+:áåè-éë íéäìà àøéå êùçä\r
+:éòéáø íåé ø÷á-éäéå áøò-éäéå èé 19\r
+óåòå äéç ùôð õøù íéîä åöøùé íéäìà øîàéå ë 20\r
+:íéîùä òé÷ø éðô-ìò õøàä-ìò óôåòé\r
+ùôð-ìë úàå íéìãâä íðéðúä-úà íéäìà àøáéå àë 21\r
+úàå íäðéîì íéîä åöøù øùà úùîøä äéçä\r
+:áåè-éë íéäìà àøéå åäðéîì óðë óåò-ìë\r
+åàìîå åáøå åøô øîàì íéäìà íúà êøáéå áë 22\r
+:õøàá áøé óåòäå íéîéá íéîä-úà\r
+:éùéîç íåé ø÷á-éäéå áøò-éäéå âë 23\r
+äîäá äðéîì äéç ùôð õøàä àöåú íéäìà øîàéå ãë 24\r
+:ïë-éäéå äðéîì õøà-åúéçå ùîøå\r
+äîäáä-úàå äðéîì õøàä úéç-úà íéäìà ùòéå äë 25\r
+íéäìà àøéå åäðéîì äîãàä ùîø-ìë úàå äðéîì\r
+:áåè-éë\r
+åðúåîãë åðîìöá íãà äùòð íéäìà øîàéå åë 26\r
+äîäááå íéîùä óåòáå íéä úâãá åãøéå\r
+:õøàä-ìò ùîøä ùîøä-ìëáå õøàä-ìëáå\r
+àøá íéäìà íìöá åîìöá íãàä-úà íéäìà àøáéå æë 27\r
+:íúà àøá äá÷ðå øëæ åúà\r
+åáøå åøô íéäìà íäì øîàéå íéäìà íúà êøáéå çë 28\r
+óåòáå íéä úâãá åãøå äùáëå õøàä-úà åàìîå\r
+:õøàä-ìò úùîøä äéç-ìëáå íéîùä\r
+òøæ áùò-ìë-úà íëì éúúð äðä íéäìà øîàéå èë 29\r
+åá-øùà õòä-ìë-úàå õøàä-ìë éðô-ìò øùà òøæ\r
+:äìëàì äéäé íëì òøæ òøæ õò-éøô\r
+ùîåø ìëìå íéîùä óåò-ìëìå õøàä úéç-ìëìå ì 30\r
+áùò ÷øé-ìë-úà äéç ùôð åá-øùà õøàä-ìò\r
+:ïë-éäéå äìëàì\r
+ãàî áåè-äðäå äùò øùà-ìë-úà íéäìà àøéå àì 31\r
+:éùùä íåé ø÷á-éäéå áø\r
--- /dev/null
+:õøàä úàå íéîùä úà íéäìà àøá úéùàøá à 1
+íåäú éðô-ìò êùçå åäáå åäú äúéä õøàäå á 2
+:íéîä éðô-ìò úôçøî íéäìà çåøå
+:øåà-éäéå øåà éäé íéäìà øîàéå â 3
+íéäìà ìãáéå áåè-éë øåàä-úà íéäìà àøéå ã 4
+:êùçä ïéáå øåàä ïéá
+äìéì àø÷ êùçìå íåé øåàì íéäìà àø÷éå ä 5
+:ãçà íåé ø÷á-éäéå áøò-éäéå
+éäéå íéîä êåúá òé÷ø éäé íéäìà øîàéå å 6
+:íéîì íéî ïéá ìéãáî
+øùà íéîä ïéá ìãáéå òé÷øä-úà íéäìà ùòéå æ 7
+òé÷øì ìòî øùà íéîä ïéáå òé÷øì úçúî
+:ïë-éäéå
+ø÷á-éäéå áøò-éäéå íéîù òé÷øì íéäìà àø÷éå ç 8
+:éðù íåé
+íå÷î-ìà íéîùä úçúî íéîä åå÷é íéäìà øîàéå è 9
+:ïë-éäéå äùáéä äàøúå ãçà
+àø÷ íéîä äå÷îìå õøà äùáéì íéäìà àø÷éå é 10
+:áåè-éë íéäìà àøéå íéîé
+òøæ òéøæî áùò àùã õøàä àùãú íéäìà øîàéå àé 11
+õøàä-ìò åá-åòøæ øùà åðéîì éøô äùò éøô õò
+:ïë-éäéå
+õòå åäðéîì òøæ òéøæî áùò àùã õøàä àöåúå áé 12
+íéäìà àøéå åäðéîì åá-åòøæ øùà éøô-äùò
+:áåè-éë
+:éùéìù íåé ø÷á-éäéå áøò-éäéå âé 13
+ìéãáäì íéîùä òé÷øá úøàî éäé íéäìà øîàéå ãé 14
+íéãòåîìå úúàì åéäå äìéìä ïéáå íåéä ïéá
+:íéðùå íéîéìå
+õøàä-ìò øéàäì íéîùä òé÷øá úøåàîì åéäå åè 15
+:ïë-éäéå
+øåàîä-úà íéìãâä úøàîä éðù-úà íéäìà ùòéå æè 16
+úìùîîì ïè÷ä øåàîä-úàå íåéä úìùîîì ìãâä
+:íéáëåëä úàå äìéìä
+øéàäì íéîùä òé÷øá íéäìà íúà ïúéå æé 17
+:õøàä-ìò
+ïéáå øåàä ïéá ìéãáäìå äìéìáå íåéá ìùîìå çé 18
+:áåè-éë íéäìà àøéå êùçä
+:éòéáø íåé ø÷á-éäéå áøò-éäéå èé 19
+óåòå äéç ùôð õøù íéîä åöøùé íéäìà øîàéå ë 20
+:íéîùä òé÷ø éðô-ìò õøàä-ìò óôåòé
+ùôð-ìë úàå íéìãâä íðéðúä-úà íéäìà àøáéå àë 21
+úàå íäðéîì íéîä åöøù øùà úùîøä äéçä
+:áåè-éë íéäìà àøéå åäðéîì óðë óåò-ìë
+åàìîå åáøå åøô øîàì íéäìà íúà êøáéå áë 22
+:õøàá áøé óåòäå íéîéá íéîä-úà
+:éùéîç íåé ø÷á-éäéå áøò-éäéå âë 23
+äîäá äðéîì äéç ùôð õøàä àöåú íéäìà øîàéå ãë 24
+:ïë-éäéå äðéîì õøà-åúéçå ùîøå
+äîäáä-úàå äðéîì õøàä úéç-úà íéäìà ùòéå äë 25
+íéäìà àøéå åäðéîì äîãàä ùîø-ìë úàå äðéîì
+:áåè-éë
+åðúåîãë åðîìöá íãà äùòð íéäìà øîàéå åë 26
+äîäááå íéîùä óåòáå íéä úâãá åãøéå
+:õøàä-ìò ùîøä ùîøä-ìëáå õøàä-ìëáå
+àøá íéäìà íìöá åîìöá íãàä-úà íéäìà àøáéå æë 27
+:íúà àøá äá÷ðå øëæ åúà
+åáøå åøô íéäìà íäì øîàéå íéäìà íúà êøáéå çë 28
+óåòáå íéä úâãá åãøå äùáëå õøàä-úà åàìîå
+:õøàä-ìò úùîøä äéç-ìëáå íéîùä
+òøæ áùò-ìë-úà íëì éúúð äðä íéäìà øîàéå èë 29
+åá-øùà õòä-ìë-úàå õøàä-ìë éðô-ìò øùà òøæ
+:äìëàì äéäé íëì òøæ òøæ õò-éøô
+ùîåø ìëìå íéîùä óåò-ìëìå õøàä úéç-ìëìå ì 30
+áùò ÷øé-ìë-úà äéç ùôð åá-øùà õøàä-ìò
+:ïë-éäéå äìëàì
+ãàî áåè-äðäå äùò øùà-ìë-úà íéäìà àøéå àì 31
+:éùùä íåé ø÷á-éäéå áø
--- /dev/null
+:ץראה תאו םימשה תא םיהלא ארב תישארב א 1\rםוהת ינפ-לע ךשחו והבו והת התיה ץראהו ב 2\r:םימה ינפ-לע תפחרמ םיהלא חורו\r:רוא-יהיו רוא יהי םיהלא רמאיו ג 3\rםיהלא לדביו בוט-יכ רואה-תא םיהלא אריו ד 4\r:ךשחה ןיבו רואה ןיב\rהליל ארק ךשחלו םוי רואל םיהלא ארקיו ה 5\r:דחא םוי רקב-יהיו ברע-יהיו\rיהיו םימה ךותב עיקר יהי םיהלא רמאיו ו 6\r:םימל םימ ןיב לידבמ\rרשא םימה ןיב לדביו עיקרה-תא םיהלא שעיו ז 7\rעיקרל לעמ רשא םימה ןיבו עיקרל תחתמ\r:ןכ-יהיו\rרקב-יהיו ברע-יהיו םימש עיקרל םיהלא ארקיו ח 8\r:ינש םוי\rםוקמ-לא םימשה תחתמ םימה ווקי םיהלא רמאיו ט 9\r:ןכ-יהיו השביה הארתו דחא\rארק םימה הוקמלו ץרא השביל םיהלא ארקיו י 10\r:בוט-יכ םיהלא אריו םימי\rערז עירזמ בשע אשד ץראה אשדת םיהלא רמאיו אי 11\rץראה-לע וב-וערז רשא ונימל ירפ השע ירפ ץע\r:ןכ-יהיו\rץעו והנימל ערז עירזמ בשע אשד ץראה אצותו בי 12\rםיהלא אריו והנימל וב-וערז רשא ירפ-השע\r:בוט-יכ\r:ישילש םוי רקב-יהיו ברע-יהיו גי 13\rלידבהל םימשה עיקרב תראמ יהי םיהלא רמאיו די 14\rםידעומלו תתאל ויהו הלילה ןיבו םויה ןיב\r:םינשו םימילו\rץראה-לע ריאהל םימשה עיקרב תרואמל ויהו וט 15\r:ןכ-יהיו\rרואמה-תא םילדגה תראמה ינש-תא םיהלא שעיו זט 16\rתלשממל ןטקה רואמה-תאו םויה תלשממל לדגה\r:םיבכוכה תאו הלילה\rריאהל םימשה עיקרב םיהלא םתא ןתיו זי 17\r:ץראה-לע\rןיבו רואה ןיב לידבהלו הלילבו םויב לשמלו חי 18\r:בוט-יכ םיהלא אריו ךשחה\r:יעיבר םוי רקב-יהיו ברע-יהיו טי 19\rףועו היח שפנ ץרש םימה וצרשי םיהלא רמאיו כ 20\r:םימשה עיקר ינפ-לע ץראה-לע ףפועי\rשפנ-לכ תאו םילדגה םנינתה-תא םיהלא ארביו אכ 21\rתאו םהנימל םימה וצרש רשא תשמרה היחה\r:בוט-יכ םיהלא אריו והנימל ףנכ ףוע-לכ\rואלמו וברו ורפ רמאל םיהלא םתא ךרביו בכ 22\r:ץראב ברי ףועהו םימיב םימה-תא\r:ישימח םוי רקב-יהיו ברע-יהיו גכ 23\rהמהב הנימל היח שפנ ץראה אצות םיהלא רמאיו דכ 24\r:ןכ-יהיו הנימל ץרא-ותיחו שמרו\rהמהבה-תאו הנימל ץראה תיח-תא םיהלא שעיו הכ 25\rםיהלא אריו והנימל המדאה שמר-לכ תאו הנימל\r:בוט-יכ\rונתומדכ ונמלצב םדא השענ םיהלא רמאיו וכ 26\rהמהבבו םימשה ףועבו םיה תגדב ודריו\r:ץראה-לע שמרה שמרה-לכבו ץראה-לכבו\rארב םיהלא םלצב ומלצב םדאה-תא םיהלא ארביו זכ 27\r:םתא ארב הבקנו רכז ותא\rוברו ורפ םיהלא םהל רמאיו םיהלא םתא ךרביו חכ 28\rףועבו םיה תגדב ודרו השבכו ץראה-תא ואלמו\r:ץראה-לע תשמרה היח-לכבו םימשה\rערז בשע-לכ-תא םכל יתתנ הנה םיהלא רמאיו טכ 29\rוב-רשא ץעה-לכ-תאו ץראה-לכ ינפ-לע רשא ערז\r:הלכאל היהי םכל ערז ערז ץע-ירפ\rשמור לכלו םימשה ףוע-לכלו ץראה תיח-לכלו ל 30\rבשע קרי-לכ-תא היח שפנ וב-רשא ץראה-לע\r:ןכ-יהיו הלכאל\rדאמ בוט-הנהו השע רשא-לכ-תא םיהלא אריו אל 31\r:יששה םוי רקב-יהיו בר\r
\ No newline at end of file
--- /dev/null
+:ץראה תאו םימשה תא םיהלא ארב תישארב א 1\r
+םוהת ינפ-לע ךשחו והבו והת התיה ץראהו ב 2\r
+:םימה ינפ-לע תפחרמ םיהלא חורו\r
+:רוא-יהיו רוא יהי םיהלא רמאיו ג 3\r
+םיהלא לדביו בוט-יכ רואה-תא םיהלא אריו ד 4\r
+:ךשחה ןיבו רואה ןיב\r
+הליל ארק ךשחלו םוי רואל םיהלא ארקיו ה 5\r
+:דחא םוי רקב-יהיו ברע-יהיו\r
+יהיו םימה ךותב עיקר יהי םיהלא רמאיו ו 6\r
+:םימל םימ ןיב לידבמ\r
+רשא םימה ןיב לדביו עיקרה-תא םיהלא שעיו ז 7\r
+עיקרל לעמ רשא םימה ןיבו עיקרל תחתמ\r
+:ןכ-יהיו\r
+רקב-יהיו ברע-יהיו םימש עיקרל םיהלא ארקיו ח 8\r
+:ינש םוי\r
+םוקמ-לא םימשה תחתמ םימה ווקי םיהלא רמאיו ט 9\r
+:ןכ-יהיו השביה הארתו דחא\r
+ארק םימה הוקמלו ץרא השביל םיהלא ארקיו י 10\r
+:בוט-יכ םיהלא אריו םימי\r
+ערז עירזמ בשע אשד ץראה אשדת םיהלא רמאיו אי 11\r
+ץראה-לע וב-וערז רשא ונימל ירפ השע ירפ ץע\r
+:ןכ-יהיו\r
+ץעו והנימל ערז עירזמ בשע אשד ץראה אצותו בי 12\r
+םיהלא אריו והנימל וב-וערז רשא ירפ-השע\r
+:בוט-יכ\r
+:ישילש םוי רקב-יהיו ברע-יהיו גי 13\r
+לידבהל םימשה עיקרב תראמ יהי םיהלא רמאיו די 14\r
+םידעומלו תתאל ויהו הלילה ןיבו םויה ןיב\r
+:םינשו םימילו\r
+ץראה-לע ריאהל םימשה עיקרב תרואמל ויהו וט 15\r
+:ןכ-יהיו\r
+רואמה-תא םילדגה תראמה ינש-תא םיהלא שעיו זט 16\r
+תלשממל ןטקה רואמה-תאו םויה תלשממל לדגה\r
+:םיבכוכה תאו הלילה\r
+ריאהל םימשה עיקרב םיהלא םתא ןתיו זי 17\r
+:ץראה-לע\r
+ןיבו רואה ןיב לידבהלו הלילבו םויב לשמלו חי 18\r
+:בוט-יכ םיהלא אריו ךשחה\r
+:יעיבר םוי רקב-יהיו ברע-יהיו טי 19\r
+ףועו היח שפנ ץרש םימה וצרשי םיהלא רמאיו כ 20\r
+:םימשה עיקר ינפ-לע ץראה-לע ףפועי\r
+שפנ-לכ תאו םילדגה םנינתה-תא םיהלא ארביו אכ 21\r
+תאו םהנימל םימה וצרש רשא תשמרה היחה\r
+:בוט-יכ םיהלא אריו והנימל ףנכ ףוע-לכ\r
+ואלמו וברו ורפ רמאל םיהלא םתא ךרביו בכ 22\r
+:ץראב ברי ףועהו םימיב םימה-תא\r
+:ישימח םוי רקב-יהיו ברע-יהיו גכ 23\r
+המהב הנימל היח שפנ ץראה אצות םיהלא רמאיו דכ 24\r
+:ןכ-יהיו הנימל ץרא-ותיחו שמרו\r
+המהבה-תאו הנימל ץראה תיח-תא םיהלא שעיו הכ 25\r
+םיהלא אריו והנימל המדאה שמר-לכ תאו הנימל\r
+:בוט-יכ\r
+ונתומדכ ונמלצב םדא השענ םיהלא רמאיו וכ 26\r
+המהבבו םימשה ףועבו םיה תגדב ודריו\r
+:ץראה-לע שמרה שמרה-לכבו ץראה-לכבו\r
+ארב םיהלא םלצב ומלצב םדאה-תא םיהלא ארביו זכ 27\r
+:םתא ארב הבקנו רכז ותא\r
+וברו ורפ םיהלא םהל רמאיו םיהלא םתא ךרביו חכ 28\r
+ףועבו םיה תגדב ודרו השבכו ץראה-תא ואלמו\r
+:ץראה-לע תשמרה היח-לכבו םימשה\r
+ערז בשע-לכ-תא םכל יתתנ הנה םיהלא רמאיו טכ 29\r
+וב-רשא ץעה-לכ-תאו ץראה-לכ ינפ-לע רשא ערז\r
+:הלכאל היהי םכל ערז ערז ץע-ירפ\r
+שמור לכלו םימשה ףוע-לכלו ץראה תיח-לכלו ל 30\r
+בשע קרי-לכ-תא היח שפנ וב-רשא ץראה-לע\r
+:ןכ-יהיו הלכאל\r
+דאמ בוט-הנהו השע רשא-לכ-תא םיהלא אריו אל 31\r
+:יששה םוי רקב-יהיו בר\r
--- /dev/null
+:ץראה תאו םימשה תא םיהלא ארב תישארב א 1
+םוהת ינפ-לע ךשחו והבו והת התיה ץראהו ב 2
+:םימה ינפ-לע תפחרמ םיהלא חורו
+:רוא-יהיו רוא יהי םיהלא רמאיו ג 3
+םיהלא לדביו בוט-יכ רואה-תא םיהלא אריו ד 4
+:ךשחה ןיבו רואה ןיב
+הליל ארק ךשחלו םוי רואל םיהלא ארקיו ה 5
+:דחא םוי רקב-יהיו ברע-יהיו
+יהיו םימה ךותב עיקר יהי םיהלא רמאיו ו 6
+:םימל םימ ןיב לידבמ
+רשא םימה ןיב לדביו עיקרה-תא םיהלא שעיו ז 7
+עיקרל לעמ רשא םימה ןיבו עיקרל תחתמ
+:ןכ-יהיו
+רקב-יהיו ברע-יהיו םימש עיקרל םיהלא ארקיו ח 8
+:ינש םוי
+םוקמ-לא םימשה תחתמ םימה ווקי םיהלא רמאיו ט 9
+:ןכ-יהיו השביה הארתו דחא
+ארק םימה הוקמלו ץרא השביל םיהלא ארקיו י 10
+:בוט-יכ םיהלא אריו םימי
+ערז עירזמ בשע אשד ץראה אשדת םיהלא רמאיו אי 11
+ץראה-לע וב-וערז רשא ונימל ירפ השע ירפ ץע
+:ןכ-יהיו
+ץעו והנימל ערז עירזמ בשע אשד ץראה אצותו בי 12
+םיהלא אריו והנימל וב-וערז רשא ירפ-השע
+:בוט-יכ
+:ישילש םוי רקב-יהיו ברע-יהיו גי 13
+לידבהל םימשה עיקרב תראמ יהי םיהלא רמאיו די 14
+םידעומלו תתאל ויהו הלילה ןיבו םויה ןיב
+:םינשו םימילו
+ץראה-לע ריאהל םימשה עיקרב תרואמל ויהו וט 15
+:ןכ-יהיו
+רואמה-תא םילדגה תראמה ינש-תא םיהלא שעיו זט 16
+תלשממל ןטקה רואמה-תאו םויה תלשממל לדגה
+:םיבכוכה תאו הלילה
+ריאהל םימשה עיקרב םיהלא םתא ןתיו זי 17
+:ץראה-לע
+ןיבו רואה ןיב לידבהלו הלילבו םויב לשמלו חי 18
+:בוט-יכ םיהלא אריו ךשחה
+:יעיבר םוי רקב-יהיו ברע-יהיו טי 19
+ףועו היח שפנ ץרש םימה וצרשי םיהלא רמאיו כ 20
+:םימשה עיקר ינפ-לע ץראה-לע ףפועי
+שפנ-לכ תאו םילדגה םנינתה-תא םיהלא ארביו אכ 21
+תאו םהנימל םימה וצרש רשא תשמרה היחה
+:בוט-יכ םיהלא אריו והנימל ףנכ ףוע-לכ
+ואלמו וברו ורפ רמאל םיהלא םתא ךרביו בכ 22
+:ץראב ברי ףועהו םימיב םימה-תא
+:ישימח םוי רקב-יהיו ברע-יהיו גכ 23
+המהב הנימל היח שפנ ץראה אצות םיהלא רמאיו דכ 24
+:ןכ-יהיו הנימל ץרא-ותיחו שמרו
+המהבה-תאו הנימל ץראה תיח-תא םיהלא שעיו הכ 25
+םיהלא אריו והנימל המדאה שמר-לכ תאו הנימל
+:בוט-יכ
+ונתומדכ ונמלצב םדא השענ םיהלא רמאיו וכ 26
+המהבבו םימשה ףועבו םיה תגדב ודריו
+:ץראה-לע שמרה שמרה-לכבו ץראה-לכבו
+ארב םיהלא םלצב ומלצב םדאה-תא םיהלא ארביו זכ 27
+:םתא ארב הבקנו רכז ותא
+וברו ורפ םיהלא םהל רמאיו םיהלא םתא ךרביו חכ 28
+ףועבו םיה תגדב ודרו השבכו ץראה-תא ואלמו
+:ץראה-לע תשמרה היח-לכבו םימשה
+ערז בשע-לכ-תא םכל יתתנ הנה םיהלא רמאיו טכ 29
+וב-רשא ץעה-לכ-תאו ץראה-לכ ינפ-לע רשא ערז
+:הלכאל היהי םכל ערז ערז ץע-ירפ
+שמור לכלו םימשה ףוע-לכלו ץראה תיח-לכלו ל 30
+בשע קרי-לכ-תא היח שפנ וב-רשא ץראה-לע
+:ןכ-יהיו הלכאל
+דאמ בוט-הנהו השע רשא-לכ-תא םיהלא אריו אל 31
+:יששה םוי רקב-יהיו בר
--- /dev/null
+Als Gregor Samsa eines Morgens aus unruhigen Träumen erwachte, fand er sich in seinem Bett zu einem ungeheueren Ungeziefer verwandelt. Er lag auf seinem panzerartig harten Rücken und sah, wenn er den Kopf ein wenig hob, seinen gewölbten, braunen, von bogenförmigen Versteifungen geteilten Bauch, auf dessen Höhe sich die Bettdecke, zum gänzlichen Niedergleiten bereit, kaum noch erhalten konnte. Seine vielen, im Vergleich zu seinem sonstigen Umfang kläglich dünnen Beine flimmerten ihm hilflos vor den Augen.\r\r»Was ist mit mir geschehen?«, dachte er. Es war kein Traum. Sein Zimmer, ein richtiges, nur etwas zu kleines Menschenzimmer, lag ruhig zwischen den vier wohlbekannten Wänden. Über dem Tisch, auf dem eine auseinandergepackte Musterkollektion von Tuchwaren ausgebreitet war - Samsa war Reisender - hing das Bild, das er vor kurzem aus einer illustrierten Zeitschrift ausgeschnitten und in einem hübschen, vergoldeten Rahmen untergebracht hatte. Es stellte eine Dame dar, die mit einem Pelzhut und einer Pelzboa versehen, aufrecht dasaß und einen schweren Pelzmuff, in dem ihr ganzer Unterarm verschwunden war, dem Beschauer entgegenhob.\r\rGregors Blick richtete sich dann zum Fenster, und das trübe Wetter - man hörte Regentropfen auf das Fensterblech aufschlagen - machte ihn ganz melancholisch. »Wie wäre es, wenn ich noch ein wenig weiterschliefe und alle Narrheiten vergäße«, dachte er, aber das war gänzlich undurchführbar, denn er war gewöhnt, auf der rechten Seite zu schlafen, konnte sich aber in seinem gegenwärtigen Zustand nicht in diese Lage bringen. Mit welcher Kraft er sich auch auf die rechte Seite warf, immer wieder schaukelte er in die Rückenlage zurück. Er versuchte es wohl hundertmal, schloß die Augen, um die zappelnden Beine nicht sehen zu müssen, und ließ erst ab, als er in der Seite einen noch nie gefühlten, leichten, dumpfen Schmerz zu fühlen begann.\r\r»Ach Gott«, dachte er, »was für einen anstrengenden Beruf habe ich gewählt! Tag aus, Tag ein auf der Reise. Die geschäftlichen Aufregungen sind viel größer, als im eigentlichen Geschäft zu Hause, und außerdem ist mir noch diese Plage des Reisens auferlegt, die Sorgen um die Zuganschlüsse, das unregelmäßige, schlechte Essen, ein immer wechselnder, nie andauernder, nie herzlich werdender menschlicher Verkehr. Der Teufel soll das alles holen!« Er fühlte ein leichtes Jucken oben auf dem Bauch; schob sich auf dem Rücken langsam näher zum Bettpfosten, um den Kopf besser heben zu können; fand die juckende Stelle, die mit lauter kleinen weißen Pünktchen besetzt war, die er nicht zu beurteilen verstand; und wollte mit einem Bein die Stelle betasten, zog es aber gleich zurück, denn bei der Berührung umwehten ihn Kälteschauer.\r\rEr glitt wieder in seine frühere Lage zurück. »Dies frühzeitige Aufstehen«, dachte er, »macht einen ganz blödsinnig. Der Mensch muß seinen Schlaf haben. Andere Reisende leben wie Haremsfrauen. Wenn ich zum Beispiel im Laufe des Vormittags ins Gasthaus zurückgehe, um die erlangten Aufträge zu überschreiben, sitzen diese Herren erst beim Frühstück. Das sollte ich bei meinem Chef versuchen; ich würde auf der Stelle hinausfliegen. Wer weiß übrigens, ob das nicht sehr gut für mich wäre. Wenn ich mich nicht wegen meiner Eltern zurückhielte, ich hätte längst gekündigt, ich wäre vor den Chef hin getreten und hätte ihm meine Meinung von Grund des Herzens aus gesagt. Vom Pult hätte er fallen müssen! Es ist auch eine sonderbare Art, sich auf das Pult zu setzen und von der Höhe herab mit dem Angestellten zu reden, der überdies wegen der Schwerhörigkeit des Chefs ganz nahe herantreten muß. Nun, die Hoffnung ist noch nicht gänzlich aufgegeben; habe ich einmal das Geld beisammen, um die Schuld der Eltern an ihn abzuzahlen - es dürfte noch fünf bis sechs Jahre dauern - , mache ich die Sache unbedingt. Dann wird der große Schnitt gemacht. Vorläufig allerdings muß ich aufstehen, denn mein Zug fährt um fünf.«\r\rUnd er sah zur Weckuhr hinüber, die auf dem Kasten tickte. »Himmlischer Vater!«, dachte er. Es war halb sieben Uhr, und die Zeiger gingen ruhig vorwärts, es war sogar halb vorüber, es näherte sich schon dreiviertel. Sollte der Wecker nicht geläutet haben? Man sah vom Bett aus, daß er auf vier Uhr richtig eingestellt war; gewiß hatte er auch geläutet. Ja, aber war es möglich, dieses möbelerschütternde Läuten ruhig zu verschlafen? Nun, ruhig hatte er ja nicht geschlafen, aber wahrscheinlich desto fester. Was aber sollte er jetzt tun? Der nächste Zug ging um sieben Uhr; um den einzuholen, hätte er sich unsinnig beeilen müssen, und die Kollektion war noch nicht eingepackt, und er selbst fühlte sich durchaus nicht besonders frisch und beweglich. Und selbst wenn er den Zug einholte, ein Donnerwetter des Chefs war nicht zu vermeiden, denn der Geschäftsdiener hatte beim Fünfuhrzug gewartet und die Meldung von seiner Versäumnis längst erstattet. Es war eine Kreatur des Chefs, ohne Rückgrat und Verstand. Wie nun, wenn er sich krank meldete? Das wäre aber äußerst peinlich und verdächtig, denn Gregor war während seines fünfjährigen Dienstes noch nicht einmal krank gewesen. Gewiß würde der Chef mit dem Krankenkassenarzt kommen, würde den Eltern wegen des faulen Sohnes Vorwürfe machen und alle Einwände durch den Hinweis auf den Krankenkassenarzt abschneiden, für den es ja überhaupt nur ganz gesunde, aber arbeitsscheue Menschen gibt. Und hätte er übrigens in diesem Falle so ganz unrecht? Gregor fühlte sich tatsächlich, abgesehen von einer nach dem langen Schlaf wirklich überflüssigen Schläfrigkeit, ganz wohl und hatte sogar einen besonders kräftigen Hunger. \r
\ No newline at end of file
--- /dev/null
+Als Gregor Samsa eines Morgens aus unruhigen Träumen erwachte, fand er sich in seinem Bett zu einem ungeheueren Ungeziefer verwandelt. Er lag auf seinem panzerartig harten Rücken und sah, wenn er den Kopf ein wenig hob, seinen gewölbten, braunen, von bogenförmigen Versteifungen geteilten Bauch, auf dessen Höhe sich die Bettdecke, zum gänzlichen Niedergleiten bereit, kaum noch erhalten konnte. Seine vielen, im Vergleich zu seinem sonstigen Umfang kläglich dünnen Beine flimmerten ihm hilflos vor den Augen.\r
+\r
+»Was ist mit mir geschehen?«, dachte er. Es war kein Traum. Sein Zimmer, ein richtiges, nur etwas zu kleines Menschenzimmer, lag ruhig zwischen den vier wohlbekannten Wänden. Über dem Tisch, auf dem eine auseinandergepackte Musterkollektion von Tuchwaren ausgebreitet war - Samsa war Reisender - hing das Bild, das er vor kurzem aus einer illustrierten Zeitschrift ausgeschnitten und in einem hübschen, vergoldeten Rahmen untergebracht hatte. Es stellte eine Dame dar, die mit einem Pelzhut und einer Pelzboa versehen, aufrecht dasaß und einen schweren Pelzmuff, in dem ihr ganzer Unterarm verschwunden war, dem Beschauer entgegenhob.\r
+\r
+Gregors Blick richtete sich dann zum Fenster, und das trübe Wetter - man hörte Regentropfen auf das Fensterblech aufschlagen - machte ihn ganz melancholisch. »Wie wäre es, wenn ich noch ein wenig weiterschliefe und alle Narrheiten vergäße«, dachte er, aber das war gänzlich undurchführbar, denn er war gewöhnt, auf der rechten Seite zu schlafen, konnte sich aber in seinem gegenwärtigen Zustand nicht in diese Lage bringen. Mit welcher Kraft er sich auch auf die rechte Seite warf, immer wieder schaukelte er in die Rückenlage zurück. Er versuchte es wohl hundertmal, schloß die Augen, um die zappelnden Beine nicht sehen zu müssen, und ließ erst ab, als er in der Seite einen noch nie gefühlten, leichten, dumpfen Schmerz zu fühlen begann.\r
+\r
+»Ach Gott«, dachte er, »was für einen anstrengenden Beruf habe ich gewählt! Tag aus, Tag ein auf der Reise. Die geschäftlichen Aufregungen sind viel größer, als im eigentlichen Geschäft zu Hause, und außerdem ist mir noch diese Plage des Reisens auferlegt, die Sorgen um die Zuganschlüsse, das unregelmäßige, schlechte Essen, ein immer wechselnder, nie andauernder, nie herzlich werdender menschlicher Verkehr. Der Teufel soll das alles holen!« Er fühlte ein leichtes Jucken oben auf dem Bauch; schob sich auf dem Rücken langsam näher zum Bettpfosten, um den Kopf besser heben zu können; fand die juckende Stelle, die mit lauter kleinen weißen Pünktchen besetzt war, die er nicht zu beurteilen verstand; und wollte mit einem Bein die Stelle betasten, zog es aber gleich zurück, denn bei der Berührung umwehten ihn Kälteschauer.\r
+\r
+Er glitt wieder in seine frühere Lage zurück. »Dies frühzeitige Aufstehen«, dachte er, »macht einen ganz blödsinnig. Der Mensch muß seinen Schlaf haben. Andere Reisende leben wie Haremsfrauen. Wenn ich zum Beispiel im Laufe des Vormittags ins Gasthaus zurückgehe, um die erlangten Aufträge zu überschreiben, sitzen diese Herren erst beim Frühstück. Das sollte ich bei meinem Chef versuchen; ich würde auf der Stelle hinausfliegen. Wer weiß übrigens, ob das nicht sehr gut für mich wäre. Wenn ich mich nicht wegen meiner Eltern zurückhielte, ich hätte längst gekündigt, ich wäre vor den Chef hin getreten und hätte ihm meine Meinung von Grund des Herzens aus gesagt. Vom Pult hätte er fallen müssen! Es ist auch eine sonderbare Art, sich auf das Pult zu setzen und von der Höhe herab mit dem Angestellten zu reden, der überdies wegen der Schwerhörigkeit des Chefs ganz nahe herantreten muß. Nun, die Hoffnung ist noch nicht gänzlich aufgegeben; habe ich einmal das Geld beisammen, um die Schuld der Eltern an ihn abzuzahlen - es dürfte noch fünf bis sechs Jahre dauern - , mache ich die Sache unbedingt. Dann wird der große Schnitt gemacht. Vorläufig allerdings muß ich aufstehen, denn mein Zug fährt um fünf.«\r
+\r
+Und er sah zur Weckuhr hinüber, die auf dem Kasten tickte. »Himmlischer Vater!«, dachte er. Es war halb sieben Uhr, und die Zeiger gingen ruhig vorwärts, es war sogar halb vorüber, es näherte sich schon dreiviertel. Sollte der Wecker nicht geläutet haben? Man sah vom Bett aus, daß er auf vier Uhr richtig eingestellt war; gewiß hatte er auch geläutet. Ja, aber war es möglich, dieses möbelerschütternde Läuten ruhig zu verschlafen? Nun, ruhig hatte er ja nicht geschlafen, aber wahrscheinlich desto fester. Was aber sollte er jetzt tun? Der nächste Zug ging um sieben Uhr; um den einzuholen, hätte er sich unsinnig beeilen müssen, und die Kollektion war noch nicht eingepackt, und er selbst fühlte sich durchaus nicht besonders frisch und beweglich. Und selbst wenn er den Zug einholte, ein Donnerwetter des Chefs war nicht zu vermeiden, denn der Geschäftsdiener hatte beim Fünfuhrzug gewartet und die Meldung von seiner Versäumnis längst erstattet. Es war eine Kreatur des Chefs, ohne Rückgrat und Verstand. Wie nun, wenn er sich krank meldete? Das wäre aber äußerst peinlich und verdächtig, denn Gregor war während seines fünfjährigen Dienstes noch nicht einmal krank gewesen. Gewiß würde der Chef mit dem Krankenkassenarzt kommen, würde den Eltern wegen des faulen Sohnes Vorwürfe machen und alle Einwände durch den Hinweis auf den Krankenkassenarzt abschneiden, für den es ja überhaupt nur ganz gesunde, aber arbeitsscheue Menschen gibt. Und hätte er übrigens in diesem Falle so ganz unrecht? Gregor fühlte sich tatsächlich, abgesehen von einer nach dem langen Schlaf wirklich überflüssigen Schläfrigkeit, ganz wohl und hatte sogar einen besonders kräftigen Hunger. \r
--- /dev/null
+Als Gregor Samsa eines Morgens aus unruhigen Träumen erwachte, fand er sich in seinem Bett zu einem ungeheueren Ungeziefer verwandelt. Er lag auf seinem panzerartig harten Rücken und sah, wenn er den Kopf ein wenig hob, seinen gewölbten, braunen, von bogenförmigen Versteifungen geteilten Bauch, auf dessen Höhe sich die Bettdecke, zum gänzlichen Niedergleiten bereit, kaum noch erhalten konnte. Seine vielen, im Vergleich zu seinem sonstigen Umfang kläglich dünnen Beine flimmerten ihm hilflos vor den Augen.
+
+»Was ist mit mir geschehen?«, dachte er. Es war kein Traum. Sein Zimmer, ein richtiges, nur etwas zu kleines Menschenzimmer, lag ruhig zwischen den vier wohlbekannten Wänden. Über dem Tisch, auf dem eine auseinandergepackte Musterkollektion von Tuchwaren ausgebreitet war - Samsa war Reisender - hing das Bild, das er vor kurzem aus einer illustrierten Zeitschrift ausgeschnitten und in einem hübschen, vergoldeten Rahmen untergebracht hatte. Es stellte eine Dame dar, die mit einem Pelzhut und einer Pelzboa versehen, aufrecht dasaß und einen schweren Pelzmuff, in dem ihr ganzer Unterarm verschwunden war, dem Beschauer entgegenhob.
+
+Gregors Blick richtete sich dann zum Fenster, und das trübe Wetter - man hörte Regentropfen auf das Fensterblech aufschlagen - machte ihn ganz melancholisch. »Wie wäre es, wenn ich noch ein wenig weiterschliefe und alle Narrheiten vergäße«, dachte er, aber das war gänzlich undurchführbar, denn er war gewöhnt, auf der rechten Seite zu schlafen, konnte sich aber in seinem gegenwärtigen Zustand nicht in diese Lage bringen. Mit welcher Kraft er sich auch auf die rechte Seite warf, immer wieder schaukelte er in die Rückenlage zurück. Er versuchte es wohl hundertmal, schloß die Augen, um die zappelnden Beine nicht sehen zu müssen, und ließ erst ab, als er in der Seite einen noch nie gefühlten, leichten, dumpfen Schmerz zu fühlen begann.
+
+»Ach Gott«, dachte er, »was für einen anstrengenden Beruf habe ich gewählt! Tag aus, Tag ein auf der Reise. Die geschäftlichen Aufregungen sind viel größer, als im eigentlichen Geschäft zu Hause, und außerdem ist mir noch diese Plage des Reisens auferlegt, die Sorgen um die Zuganschlüsse, das unregelmäßige, schlechte Essen, ein immer wechselnder, nie andauernder, nie herzlich werdender menschlicher Verkehr. Der Teufel soll das alles holen!« Er fühlte ein leichtes Jucken oben auf dem Bauch; schob sich auf dem Rücken langsam näher zum Bettpfosten, um den Kopf besser heben zu können; fand die juckende Stelle, die mit lauter kleinen weißen Pünktchen besetzt war, die er nicht zu beurteilen verstand; und wollte mit einem Bein die Stelle betasten, zog es aber gleich zurück, denn bei der Berührung umwehten ihn Kälteschauer.
+
+Er glitt wieder in seine frühere Lage zurück. »Dies frühzeitige Aufstehen«, dachte er, »macht einen ganz blödsinnig. Der Mensch muß seinen Schlaf haben. Andere Reisende leben wie Haremsfrauen. Wenn ich zum Beispiel im Laufe des Vormittags ins Gasthaus zurückgehe, um die erlangten Aufträge zu überschreiben, sitzen diese Herren erst beim Frühstück. Das sollte ich bei meinem Chef versuchen; ich würde auf der Stelle hinausfliegen. Wer weiß übrigens, ob das nicht sehr gut für mich wäre. Wenn ich mich nicht wegen meiner Eltern zurückhielte, ich hätte längst gekündigt, ich wäre vor den Chef hin getreten und hätte ihm meine Meinung von Grund des Herzens aus gesagt. Vom Pult hätte er fallen müssen! Es ist auch eine sonderbare Art, sich auf das Pult zu setzen und von der Höhe herab mit dem Angestellten zu reden, der überdies wegen der Schwerhörigkeit des Chefs ganz nahe herantreten muß. Nun, die Hoffnung ist noch nicht gänzlich aufgegeben; habe ich einmal das Geld beisammen, um die Schuld der Eltern an ihn abzuzahlen - es dürfte noch fünf bis sechs Jahre dauern - , mache ich die Sache unbedingt. Dann wird der große Schnitt gemacht. Vorläufig allerdings muß ich aufstehen, denn mein Zug fährt um fünf.«
+
+Und er sah zur Weckuhr hinüber, die auf dem Kasten tickte. »Himmlischer Vater!«, dachte er. Es war halb sieben Uhr, und die Zeiger gingen ruhig vorwärts, es war sogar halb vorüber, es näherte sich schon dreiviertel. Sollte der Wecker nicht geläutet haben? Man sah vom Bett aus, daß er auf vier Uhr richtig eingestellt war; gewiß hatte er auch geläutet. Ja, aber war es möglich, dieses möbelerschütternde Läuten ruhig zu verschlafen? Nun, ruhig hatte er ja nicht geschlafen, aber wahrscheinlich desto fester. Was aber sollte er jetzt tun? Der nächste Zug ging um sieben Uhr; um den einzuholen, hätte er sich unsinnig beeilen müssen, und die Kollektion war noch nicht eingepackt, und er selbst fühlte sich durchaus nicht besonders frisch und beweglich. Und selbst wenn er den Zug einholte, ein Donnerwetter des Chefs war nicht zu vermeiden, denn der Geschäftsdiener hatte beim Fünfuhrzug gewartet und die Meldung von seiner Versäumnis längst erstattet. Es war eine Kreatur des Chefs, ohne Rückgrat und Verstand. Wie nun, wenn er sich krank meldete? Das wäre aber äußerst peinlich und verdächtig, denn Gregor war während seines fünfjährigen Dienstes noch nicht einmal krank gewesen. Gewiß würde der Chef mit dem Krankenkassenarzt kommen, würde den Eltern wegen des faulen Sohnes Vorwürfe machen und alle Einwände durch den Hinweis auf den Krankenkassenarzt abschneiden, für den es ja überhaupt nur ganz gesunde, aber arbeitsscheue Menschen gibt. Und hätte er übrigens in diesem Falle so ganz unrecht? Gregor fühlte sich tatsächlich, abgesehen von einer nach dem langen Schlaf wirklich überflüssigen Schläfrigkeit, ganz wohl und hatte sogar einen besonders kräftigen Hunger.
--- /dev/null
+Als Gregor Samsa eines Morgens aus unruhigen Träumen erwachte, fand er sich in seinem Bett zu einem ungeheueren Ungeziefer verwandelt. Er lag auf seinem panzerartig harten Rücken und sah, wenn er den Kopf ein wenig hob, seinen gewölbten, braunen, von bogenförmigen Versteifungen geteilten Bauch, auf dessen Höhe sich die Bettdecke, zum gänzlichen Niedergleiten bereit, kaum noch erhalten konnte. Seine vielen, im Vergleich zu seinem sonstigen Umfang kläglich dünnen Beine flimmerten ihm hilflos vor den Augen.\r\r»Was ist mit mir geschehen?«, dachte er. Es war kein Traum. Sein Zimmer, ein richtiges, nur etwas zu kleines Menschenzimmer, lag ruhig zwischen den vier wohlbekannten Wänden. Über dem Tisch, auf dem eine auseinandergepackte Musterkollektion von Tuchwaren ausgebreitet war - Samsa war Reisender - hing das Bild, das er vor kurzem aus einer illustrierten Zeitschrift ausgeschnitten und in einem hübschen, vergoldeten Rahmen untergebracht hatte. Es stellte eine Dame dar, die mit einem Pelzhut und einer Pelzboa versehen, aufrecht dasaß und einen schweren Pelzmuff, in dem ihr ganzer Unterarm verschwunden war, dem Beschauer entgegenhob.\r\rGregors Blick richtete sich dann zum Fenster, und das trübe Wetter - man hörte Regentropfen auf das Fensterblech aufschlagen - machte ihn ganz melancholisch. »Wie wäre es, wenn ich noch ein wenig weiterschliefe und alle Narrheiten vergäße«, dachte er, aber das war gänzlich undurchführbar, denn er war gewöhnt, auf der rechten Seite zu schlafen, konnte sich aber in seinem gegenwärtigen Zustand nicht in diese Lage bringen. Mit welcher Kraft er sich auch auf die rechte Seite warf, immer wieder schaukelte er in die Rückenlage zurück. Er versuchte es wohl hundertmal, schloß die Augen, um die zappelnden Beine nicht sehen zu müssen, und ließ erst ab, als er in der Seite einen noch nie gefühlten, leichten, dumpfen Schmerz zu fühlen begann.\r\r»Ach Gott«, dachte er, »was für einen anstrengenden Beruf habe ich gewählt! Tag aus, Tag ein auf der Reise. Die geschäftlichen Aufregungen sind viel größer, als im eigentlichen Geschäft zu Hause, und außerdem ist mir noch diese Plage des Reisens auferlegt, die Sorgen um die Zuganschlüsse, das unregelmäßige, schlechte Essen, ein immer wechselnder, nie andauernder, nie herzlich werdender menschlicher Verkehr. Der Teufel soll das alles holen!« Er fühlte ein leichtes Jucken oben auf dem Bauch; schob sich auf dem Rücken langsam näher zum Bettpfosten, um den Kopf besser heben zu können; fand die juckende Stelle, die mit lauter kleinen weißen Pünktchen besetzt war, die er nicht zu beurteilen verstand; und wollte mit einem Bein die Stelle betasten, zog es aber gleich zurück, denn bei der Berührung umwehten ihn Kälteschauer.\r\rEr glitt wieder in seine frühere Lage zurück. »Dies frühzeitige Aufstehen«, dachte er, »macht einen ganz blödsinnig. Der Mensch muß seinen Schlaf haben. Andere Reisende leben wie Haremsfrauen. Wenn ich zum Beispiel im Laufe des Vormittags ins Gasthaus zurückgehe, um die erlangten Aufträge zu überschreiben, sitzen diese Herren erst beim Frühstück. Das sollte ich bei meinem Chef versuchen; ich würde auf der Stelle hinausfliegen. Wer weiß übrigens, ob das nicht sehr gut für mich wäre. Wenn ich mich nicht wegen meiner Eltern zurückhielte, ich hätte längst gekündigt, ich wäre vor den Chef hin getreten und hätte ihm meine Meinung von Grund des Herzens aus gesagt. Vom Pult hätte er fallen müssen! Es ist auch eine sonderbare Art, sich auf das Pult zu setzen und von der Höhe herab mit dem Angestellten zu reden, der überdies wegen der Schwerhörigkeit des Chefs ganz nahe herantreten muß. Nun, die Hoffnung ist noch nicht gänzlich aufgegeben; habe ich einmal das Geld beisammen, um die Schuld der Eltern an ihn abzuzahlen - es dürfte noch fünf bis sechs Jahre dauern - , mache ich die Sache unbedingt. Dann wird der große Schnitt gemacht. Vorläufig allerdings muß ich aufstehen, denn mein Zug fährt um fünf.«\r\rUnd er sah zur Weckuhr hinüber, die auf dem Kasten tickte. »Himmlischer Vater!«, dachte er. Es war halb sieben Uhr, und die Zeiger gingen ruhig vorwärts, es war sogar halb vorüber, es näherte sich schon dreiviertel. Sollte der Wecker nicht geläutet haben? Man sah vom Bett aus, daß er auf vier Uhr richtig eingestellt war; gewiß hatte er auch geläutet. Ja, aber war es möglich, dieses möbelerschütternde Läuten ruhig zu verschlafen? Nun, ruhig hatte er ja nicht geschlafen, aber wahrscheinlich desto fester. Was aber sollte er jetzt tun? Der nächste Zug ging um sieben Uhr; um den einzuholen, hätte er sich unsinnig beeilen müssen, und die Kollektion war noch nicht eingepackt, und er selbst fühlte sich durchaus nicht besonders frisch und beweglich. Und selbst wenn er den Zug einholte, ein Donnerwetter des Chefs war nicht zu vermeiden, denn der Geschäftsdiener hatte beim Fünfuhrzug gewartet und die Meldung von seiner Versäumnis längst erstattet. Es war eine Kreatur des Chefs, ohne Rückgrat und Verstand. Wie nun, wenn er sich krank meldete? Das wäre aber äußerst peinlich und verdächtig, denn Gregor war während seines fünfjährigen Dienstes noch nicht einmal krank gewesen. Gewiß würde der Chef mit dem Krankenkassenarzt kommen, würde den Eltern wegen des faulen Sohnes Vorwürfe machen und alle Einwände durch den Hinweis auf den Krankenkassenarzt abschneiden, für den es ja überhaupt nur ganz gesunde, aber arbeitsscheue Menschen gibt. Und hätte er übrigens in diesem Falle so ganz unrecht? Gregor fühlte sich tatsächlich, abgesehen von einer nach dem langen Schlaf wirklich überflüssigen Schläfrigkeit, ganz wohl und hatte sogar einen besonders kräftigen Hunger. \r
\ No newline at end of file
--- /dev/null
+Als Gregor Samsa eines Morgens aus unruhigen Träumen erwachte, fand er sich in seinem Bett zu einem ungeheueren Ungeziefer verwandelt. Er lag auf seinem panzerartig harten Rücken und sah, wenn er den Kopf ein wenig hob, seinen gewölbten, braunen, von bogenförmigen Versteifungen geteilten Bauch, auf dessen Höhe sich die Bettdecke, zum gänzlichen Niedergleiten bereit, kaum noch erhalten konnte. Seine vielen, im Vergleich zu seinem sonstigen Umfang kläglich dünnen Beine flimmerten ihm hilflos vor den Augen.\r
+\r
+»Was ist mit mir geschehen?«, dachte er. Es war kein Traum. Sein Zimmer, ein richtiges, nur etwas zu kleines Menschenzimmer, lag ruhig zwischen den vier wohlbekannten Wänden. Über dem Tisch, auf dem eine auseinandergepackte Musterkollektion von Tuchwaren ausgebreitet war - Samsa war Reisender - hing das Bild, das er vor kurzem aus einer illustrierten Zeitschrift ausgeschnitten und in einem hübschen, vergoldeten Rahmen untergebracht hatte. Es stellte eine Dame dar, die mit einem Pelzhut und einer Pelzboa versehen, aufrecht dasaß und einen schweren Pelzmuff, in dem ihr ganzer Unterarm verschwunden war, dem Beschauer entgegenhob.\r
+\r
+Gregors Blick richtete sich dann zum Fenster, und das trübe Wetter - man hörte Regentropfen auf das Fensterblech aufschlagen - machte ihn ganz melancholisch. »Wie wäre es, wenn ich noch ein wenig weiterschliefe und alle Narrheiten vergäße«, dachte er, aber das war gänzlich undurchführbar, denn er war gewöhnt, auf der rechten Seite zu schlafen, konnte sich aber in seinem gegenwärtigen Zustand nicht in diese Lage bringen. Mit welcher Kraft er sich auch auf die rechte Seite warf, immer wieder schaukelte er in die Rückenlage zurück. Er versuchte es wohl hundertmal, schloß die Augen, um die zappelnden Beine nicht sehen zu müssen, und ließ erst ab, als er in der Seite einen noch nie gefühlten, leichten, dumpfen Schmerz zu fühlen begann.\r
+\r
+»Ach Gott«, dachte er, »was für einen anstrengenden Beruf habe ich gewählt! Tag aus, Tag ein auf der Reise. Die geschäftlichen Aufregungen sind viel größer, als im eigentlichen Geschäft zu Hause, und außerdem ist mir noch diese Plage des Reisens auferlegt, die Sorgen um die Zuganschlüsse, das unregelmäßige, schlechte Essen, ein immer wechselnder, nie andauernder, nie herzlich werdender menschlicher Verkehr. Der Teufel soll das alles holen!« Er fühlte ein leichtes Jucken oben auf dem Bauch; schob sich auf dem Rücken langsam näher zum Bettpfosten, um den Kopf besser heben zu können; fand die juckende Stelle, die mit lauter kleinen weißen Pünktchen besetzt war, die er nicht zu beurteilen verstand; und wollte mit einem Bein die Stelle betasten, zog es aber gleich zurück, denn bei der Berührung umwehten ihn Kälteschauer.\r
+\r
+Er glitt wieder in seine frühere Lage zurück. »Dies frühzeitige Aufstehen«, dachte er, »macht einen ganz blödsinnig. Der Mensch muß seinen Schlaf haben. Andere Reisende leben wie Haremsfrauen. Wenn ich zum Beispiel im Laufe des Vormittags ins Gasthaus zurückgehe, um die erlangten Aufträge zu überschreiben, sitzen diese Herren erst beim Frühstück. Das sollte ich bei meinem Chef versuchen; ich würde auf der Stelle hinausfliegen. Wer weiß übrigens, ob das nicht sehr gut für mich wäre. Wenn ich mich nicht wegen meiner Eltern zurückhielte, ich hätte längst gekündigt, ich wäre vor den Chef hin getreten und hätte ihm meine Meinung von Grund des Herzens aus gesagt. Vom Pult hätte er fallen müssen! Es ist auch eine sonderbare Art, sich auf das Pult zu setzen und von der Höhe herab mit dem Angestellten zu reden, der überdies wegen der Schwerhörigkeit des Chefs ganz nahe herantreten muß. Nun, die Hoffnung ist noch nicht gänzlich aufgegeben; habe ich einmal das Geld beisammen, um die Schuld der Eltern an ihn abzuzahlen - es dürfte noch fünf bis sechs Jahre dauern - , mache ich die Sache unbedingt. Dann wird der große Schnitt gemacht. Vorläufig allerdings muß ich aufstehen, denn mein Zug fährt um fünf.«\r
+\r
+Und er sah zur Weckuhr hinüber, die auf dem Kasten tickte. »Himmlischer Vater!«, dachte er. Es war halb sieben Uhr, und die Zeiger gingen ruhig vorwärts, es war sogar halb vorüber, es näherte sich schon dreiviertel. Sollte der Wecker nicht geläutet haben? Man sah vom Bett aus, daß er auf vier Uhr richtig eingestellt war; gewiß hatte er auch geläutet. Ja, aber war es möglich, dieses möbelerschütternde Läuten ruhig zu verschlafen? Nun, ruhig hatte er ja nicht geschlafen, aber wahrscheinlich desto fester. Was aber sollte er jetzt tun? Der nächste Zug ging um sieben Uhr; um den einzuholen, hätte er sich unsinnig beeilen müssen, und die Kollektion war noch nicht eingepackt, und er selbst fühlte sich durchaus nicht besonders frisch und beweglich. Und selbst wenn er den Zug einholte, ein Donnerwetter des Chefs war nicht zu vermeiden, denn der Geschäftsdiener hatte beim Fünfuhrzug gewartet und die Meldung von seiner Versäumnis längst erstattet. Es war eine Kreatur des Chefs, ohne Rückgrat und Verstand. Wie nun, wenn er sich krank meldete? Das wäre aber äußerst peinlich und verdächtig, denn Gregor war während seines fünfjährigen Dienstes noch nicht einmal krank gewesen. Gewiß würde der Chef mit dem Krankenkassenarzt kommen, würde den Eltern wegen des faulen Sohnes Vorwürfe machen und alle Einwände durch den Hinweis auf den Krankenkassenarzt abschneiden, für den es ja überhaupt nur ganz gesunde, aber arbeitsscheue Menschen gibt. Und hätte er übrigens in diesem Falle so ganz unrecht? Gregor fühlte sich tatsächlich, abgesehen von einer nach dem langen Schlaf wirklich überflüssigen Schläfrigkeit, ganz wohl und hatte sogar einen besonders kräftigen Hunger. \r
--- /dev/null
+Als Gregor Samsa eines Morgens aus unruhigen Träumen erwachte, fand er sich in seinem Bett zu einem ungeheueren Ungeziefer verwandelt. Er lag auf seinem panzerartig harten Rücken und sah, wenn er den Kopf ein wenig hob, seinen gewölbten, braunen, von bogenförmigen Versteifungen geteilten Bauch, auf dessen Höhe sich die Bettdecke, zum gänzlichen Niedergleiten bereit, kaum noch erhalten konnte. Seine vielen, im Vergleich zu seinem sonstigen Umfang kläglich dünnen Beine flimmerten ihm hilflos vor den Augen.
+
+»Was ist mit mir geschehen?«, dachte er. Es war kein Traum. Sein Zimmer, ein richtiges, nur etwas zu kleines Menschenzimmer, lag ruhig zwischen den vier wohlbekannten Wänden. Über dem Tisch, auf dem eine auseinandergepackte Musterkollektion von Tuchwaren ausgebreitet war - Samsa war Reisender - hing das Bild, das er vor kurzem aus einer illustrierten Zeitschrift ausgeschnitten und in einem hübschen, vergoldeten Rahmen untergebracht hatte. Es stellte eine Dame dar, die mit einem Pelzhut und einer Pelzboa versehen, aufrecht dasaß und einen schweren Pelzmuff, in dem ihr ganzer Unterarm verschwunden war, dem Beschauer entgegenhob.
+
+Gregors Blick richtete sich dann zum Fenster, und das trübe Wetter - man hörte Regentropfen auf das Fensterblech aufschlagen - machte ihn ganz melancholisch. »Wie wäre es, wenn ich noch ein wenig weiterschliefe und alle Narrheiten vergäße«, dachte er, aber das war gänzlich undurchführbar, denn er war gewöhnt, auf der rechten Seite zu schlafen, konnte sich aber in seinem gegenwärtigen Zustand nicht in diese Lage bringen. Mit welcher Kraft er sich auch auf die rechte Seite warf, immer wieder schaukelte er in die Rückenlage zurück. Er versuchte es wohl hundertmal, schloß die Augen, um die zappelnden Beine nicht sehen zu müssen, und ließ erst ab, als er in der Seite einen noch nie gefühlten, leichten, dumpfen Schmerz zu fühlen begann.
+
+»Ach Gott«, dachte er, »was für einen anstrengenden Beruf habe ich gewählt! Tag aus, Tag ein auf der Reise. Die geschäftlichen Aufregungen sind viel größer, als im eigentlichen Geschäft zu Hause, und außerdem ist mir noch diese Plage des Reisens auferlegt, die Sorgen um die Zuganschlüsse, das unregelmäßige, schlechte Essen, ein immer wechselnder, nie andauernder, nie herzlich werdender menschlicher Verkehr. Der Teufel soll das alles holen!« Er fühlte ein leichtes Jucken oben auf dem Bauch; schob sich auf dem Rücken langsam näher zum Bettpfosten, um den Kopf besser heben zu können; fand die juckende Stelle, die mit lauter kleinen weißen Pünktchen besetzt war, die er nicht zu beurteilen verstand; und wollte mit einem Bein die Stelle betasten, zog es aber gleich zurück, denn bei der Berührung umwehten ihn Kälteschauer.
+
+Er glitt wieder in seine frühere Lage zurück. »Dies frühzeitige Aufstehen«, dachte er, »macht einen ganz blödsinnig. Der Mensch muß seinen Schlaf haben. Andere Reisende leben wie Haremsfrauen. Wenn ich zum Beispiel im Laufe des Vormittags ins Gasthaus zurückgehe, um die erlangten Aufträge zu überschreiben, sitzen diese Herren erst beim Frühstück. Das sollte ich bei meinem Chef versuchen; ich würde auf der Stelle hinausfliegen. Wer weiß übrigens, ob das nicht sehr gut für mich wäre. Wenn ich mich nicht wegen meiner Eltern zurückhielte, ich hätte längst gekündigt, ich wäre vor den Chef hin getreten und hätte ihm meine Meinung von Grund des Herzens aus gesagt. Vom Pult hätte er fallen müssen! Es ist auch eine sonderbare Art, sich auf das Pult zu setzen und von der Höhe herab mit dem Angestellten zu reden, der überdies wegen der Schwerhörigkeit des Chefs ganz nahe herantreten muß. Nun, die Hoffnung ist noch nicht gänzlich aufgegeben; habe ich einmal das Geld beisammen, um die Schuld der Eltern an ihn abzuzahlen - es dürfte noch fünf bis sechs Jahre dauern - , mache ich die Sache unbedingt. Dann wird der große Schnitt gemacht. Vorläufig allerdings muß ich aufstehen, denn mein Zug fährt um fünf.«
+
+Und er sah zur Weckuhr hinüber, die auf dem Kasten tickte. »Himmlischer Vater!«, dachte er. Es war halb sieben Uhr, und die Zeiger gingen ruhig vorwärts, es war sogar halb vorüber, es näherte sich schon dreiviertel. Sollte der Wecker nicht geläutet haben? Man sah vom Bett aus, daß er auf vier Uhr richtig eingestellt war; gewiß hatte er auch geläutet. Ja, aber war es möglich, dieses möbelerschütternde Läuten ruhig zu verschlafen? Nun, ruhig hatte er ja nicht geschlafen, aber wahrscheinlich desto fester. Was aber sollte er jetzt tun? Der nächste Zug ging um sieben Uhr; um den einzuholen, hätte er sich unsinnig beeilen müssen, und die Kollektion war noch nicht eingepackt, und er selbst fühlte sich durchaus nicht besonders frisch und beweglich. Und selbst wenn er den Zug einholte, ein Donnerwetter des Chefs war nicht zu vermeiden, denn der Geschäftsdiener hatte beim Fünfuhrzug gewartet und die Meldung von seiner Versäumnis längst erstattet. Es war eine Kreatur des Chefs, ohne Rückgrat und Verstand. Wie nun, wenn er sich krank meldete? Das wäre aber äußerst peinlich und verdächtig, denn Gregor war während seines fünfjährigen Dienstes noch nicht einmal krank gewesen. Gewiß würde der Chef mit dem Krankenkassenarzt kommen, würde den Eltern wegen des faulen Sohnes Vorwürfe machen und alle Einwände durch den Hinweis auf den Krankenkassenarzt abschneiden, für den es ja überhaupt nur ganz gesunde, aber arbeitsscheue Menschen gibt. Und hätte er übrigens in diesem Falle so ganz unrecht? Gregor fühlte sich tatsächlich, abgesehen von einer nach dem langen Schlaf wirklich überflüssigen Schläfrigkeit, ganz wohl und hatte sogar einen besonders kräftigen Hunger.
--- /dev/null
+Als Gregor Samsa eines Morgens aus unruhigen Träumen erwachte, fand er sich in seinem Bett zu einem ungeheueren Ungeziefer verwandelt. Er lag auf seinem panzerartig harten Rücken und sah, wenn er den Kopf ein wenig hob, seinen gewölbten, braunen, von bogenförmigen Versteifungen geteilten Bauch, auf dessen Höhe sich die Bettdecke, zum gänzlichen Niedergleiten bereit, kaum noch erhalten konnte. Seine vielen, im Vergleich zu seinem sonstigen Umfang kläglich dünnen Beine flimmerten ihm hilflos vor den Augen.\r\r»Was ist mit mir geschehen?«, dachte er. Es war kein Traum. Sein Zimmer, ein richtiges, nur etwas zu kleines Menschenzimmer, lag ruhig zwischen den vier wohlbekannten Wänden. Über dem Tisch, auf dem eine auseinandergepackte Musterkollektion von Tuchwaren ausgebreitet war - Samsa war Reisender - hing das Bild, das er vor kurzem aus einer illustrierten Zeitschrift ausgeschnitten und in einem hübschen, vergoldeten Rahmen untergebracht hatte. Es stellte eine Dame dar, die mit einem Pelzhut und einer Pelzboa versehen, aufrecht dasaß und einen schweren Pelzmuff, in dem ihr ganzer Unterarm verschwunden war, dem Beschauer entgegenhob.\r\rGregors Blick richtete sich dann zum Fenster, und das trübe Wetter - man hörte Regentropfen auf das Fensterblech aufschlagen - machte ihn ganz melancholisch. »Wie wäre es, wenn ich noch ein wenig weiterschliefe und alle Narrheiten vergäße«, dachte er, aber das war gänzlich undurchführbar, denn er war gewöhnt, auf der rechten Seite zu schlafen, konnte sich aber in seinem gegenwärtigen Zustand nicht in diese Lage bringen. Mit welcher Kraft er sich auch auf die rechte Seite warf, immer wieder schaukelte er in die Rückenlage zurück. Er versuchte es wohl hundertmal, schloß die Augen, um die zappelnden Beine nicht sehen zu müssen, und ließ erst ab, als er in der Seite einen noch nie gefühlten, leichten, dumpfen Schmerz zu fühlen begann.\r\r»Ach Gott«, dachte er, »was für einen anstrengenden Beruf habe ich gewählt! Tag aus, Tag ein auf der Reise. Die geschäftlichen Aufregungen sind viel größer, als im eigentlichen Geschäft zu Hause, und außerdem ist mir noch diese Plage des Reisens auferlegt, die Sorgen um die Zuganschlüsse, das unregelmäßige, schlechte Essen, ein immer wechselnder, nie andauernder, nie herzlich werdender menschlicher Verkehr. Der Teufel soll das alles holen!« Er fühlte ein leichtes Jucken oben auf dem Bauch; schob sich auf dem Rücken langsam näher zum Bettpfosten, um den Kopf besser heben zu können; fand die juckende Stelle, die mit lauter kleinen weißen Pünktchen besetzt war, die er nicht zu beurteilen verstand; und wollte mit einem Bein die Stelle betasten, zog es aber gleich zurück, denn bei der Berührung umwehten ihn Kälteschauer.\r\rEr glitt wieder in seine frühere Lage zurück. »Dies frühzeitige Aufstehen«, dachte er, »macht einen ganz blödsinnig. Der Mensch muß seinen Schlaf haben. Andere Reisende leben wie Haremsfrauen. Wenn ich zum Beispiel im Laufe des Vormittags ins Gasthaus zurückgehe, um die erlangten Aufträge zu überschreiben, sitzen diese Herren erst beim Frühstück. Das sollte ich bei meinem Chef versuchen; ich würde auf der Stelle hinausfliegen. Wer weiß übrigens, ob das nicht sehr gut für mich wäre. Wenn ich mich nicht wegen meiner Eltern zurückhielte, ich hätte längst gekündigt, ich wäre vor den Chef hin getreten und hätte ihm meine Meinung von Grund des Herzens aus gesagt. Vom Pult hätte er fallen müssen! Es ist auch eine sonderbare Art, sich auf das Pult zu setzen und von der Höhe herab mit dem Angestellten zu reden, der überdies wegen der Schwerhörigkeit des Chefs ganz nahe herantreten muß. Nun, die Hoffnung ist noch nicht gänzlich aufgegeben; habe ich einmal das Geld beisammen, um die Schuld der Eltern an ihn abzuzahlen - es dürfte noch fünf bis sechs Jahre dauern - , mache ich die Sache unbedingt. Dann wird der große Schnitt gemacht. Vorläufig allerdings muß ich aufstehen, denn mein Zug fährt um fünf.«\r\rUnd er sah zur Weckuhr hinüber, die auf dem Kasten tickte. »Himmlischer Vater!«, dachte er. Es war halb sieben Uhr, und die Zeiger gingen ruhig vorwärts, es war sogar halb vorüber, es näherte sich schon dreiviertel. Sollte der Wecker nicht geläutet haben? Man sah vom Bett aus, daß er auf vier Uhr richtig eingestellt war; gewiß hatte er auch geläutet. Ja, aber war es möglich, dieses möbelerschütternde Läuten ruhig zu verschlafen? Nun, ruhig hatte er ja nicht geschlafen, aber wahrscheinlich desto fester. Was aber sollte er jetzt tun? Der nächste Zug ging um sieben Uhr; um den einzuholen, hätte er sich unsinnig beeilen müssen, und die Kollektion war noch nicht eingepackt, und er selbst fühlte sich durchaus nicht besonders frisch und beweglich. Und selbst wenn er den Zug einholte, ein Donnerwetter des Chefs war nicht zu vermeiden, denn der Geschäftsdiener hatte beim Fünfuhrzug gewartet und die Meldung von seiner Versäumnis längst erstattet. Es war eine Kreatur des Chefs, ohne Rückgrat und Verstand. Wie nun, wenn er sich krank meldete? Das wäre aber äußerst peinlich und verdächtig, denn Gregor war während seines fünfjährigen Dienstes noch nicht einmal krank gewesen. Gewiß würde der Chef mit dem Krankenkassenarzt kommen, würde den Eltern wegen des faulen Sohnes Vorwürfe machen und alle Einwände durch den Hinweis auf den Krankenkassenarzt abschneiden, für den es ja überhaupt nur ganz gesunde, aber arbeitsscheue Menschen gibt. Und hätte er übrigens in diesem Falle so ganz unrecht? Gregor fühlte sich tatsächlich, abgesehen von einer nach dem langen Schlaf wirklich überflüssigen Schläfrigkeit, ganz wohl und hatte sogar einen besonders kräftigen Hunger. \r
\ No newline at end of file
--- /dev/null
+Als Gregor Samsa eines Morgens aus unruhigen Träumen erwachte, fand er sich in seinem Bett zu einem ungeheueren Ungeziefer verwandelt. Er lag auf seinem panzerartig harten Rücken und sah, wenn er den Kopf ein wenig hob, seinen gewölbten, braunen, von bogenförmigen Versteifungen geteilten Bauch, auf dessen Höhe sich die Bettdecke, zum gänzlichen Niedergleiten bereit, kaum noch erhalten konnte. Seine vielen, im Vergleich zu seinem sonstigen Umfang kläglich dünnen Beine flimmerten ihm hilflos vor den Augen.\r
+\r
+»Was ist mit mir geschehen?«, dachte er. Es war kein Traum. Sein Zimmer, ein richtiges, nur etwas zu kleines Menschenzimmer, lag ruhig zwischen den vier wohlbekannten Wänden. Über dem Tisch, auf dem eine auseinandergepackte Musterkollektion von Tuchwaren ausgebreitet war - Samsa war Reisender - hing das Bild, das er vor kurzem aus einer illustrierten Zeitschrift ausgeschnitten und in einem hübschen, vergoldeten Rahmen untergebracht hatte. Es stellte eine Dame dar, die mit einem Pelzhut und einer Pelzboa versehen, aufrecht dasaß und einen schweren Pelzmuff, in dem ihr ganzer Unterarm verschwunden war, dem Beschauer entgegenhob.\r
+\r
+Gregors Blick richtete sich dann zum Fenster, und das trübe Wetter - man hörte Regentropfen auf das Fensterblech aufschlagen - machte ihn ganz melancholisch. »Wie wäre es, wenn ich noch ein wenig weiterschliefe und alle Narrheiten vergäße«, dachte er, aber das war gänzlich undurchführbar, denn er war gewöhnt, auf der rechten Seite zu schlafen, konnte sich aber in seinem gegenwärtigen Zustand nicht in diese Lage bringen. Mit welcher Kraft er sich auch auf die rechte Seite warf, immer wieder schaukelte er in die Rückenlage zurück. Er versuchte es wohl hundertmal, schloß die Augen, um die zappelnden Beine nicht sehen zu müssen, und ließ erst ab, als er in der Seite einen noch nie gefühlten, leichten, dumpfen Schmerz zu fühlen begann.\r
+\r
+»Ach Gott«, dachte er, »was für einen anstrengenden Beruf habe ich gewählt! Tag aus, Tag ein auf der Reise. Die geschäftlichen Aufregungen sind viel größer, als im eigentlichen Geschäft zu Hause, und außerdem ist mir noch diese Plage des Reisens auferlegt, die Sorgen um die Zuganschlüsse, das unregelmäßige, schlechte Essen, ein immer wechselnder, nie andauernder, nie herzlich werdender menschlicher Verkehr. Der Teufel soll das alles holen!« Er fühlte ein leichtes Jucken oben auf dem Bauch; schob sich auf dem Rücken langsam näher zum Bettpfosten, um den Kopf besser heben zu können; fand die juckende Stelle, die mit lauter kleinen weißen Pünktchen besetzt war, die er nicht zu beurteilen verstand; und wollte mit einem Bein die Stelle betasten, zog es aber gleich zurück, denn bei der Berührung umwehten ihn Kälteschauer.\r
+\r
+Er glitt wieder in seine frühere Lage zurück. »Dies frühzeitige Aufstehen«, dachte er, »macht einen ganz blödsinnig. Der Mensch muß seinen Schlaf haben. Andere Reisende leben wie Haremsfrauen. Wenn ich zum Beispiel im Laufe des Vormittags ins Gasthaus zurückgehe, um die erlangten Aufträge zu überschreiben, sitzen diese Herren erst beim Frühstück. Das sollte ich bei meinem Chef versuchen; ich würde auf der Stelle hinausfliegen. Wer weiß übrigens, ob das nicht sehr gut für mich wäre. Wenn ich mich nicht wegen meiner Eltern zurückhielte, ich hätte längst gekündigt, ich wäre vor den Chef hin getreten und hätte ihm meine Meinung von Grund des Herzens aus gesagt. Vom Pult hätte er fallen müssen! Es ist auch eine sonderbare Art, sich auf das Pult zu setzen und von der Höhe herab mit dem Angestellten zu reden, der überdies wegen der Schwerhörigkeit des Chefs ganz nahe herantreten muß. Nun, die Hoffnung ist noch nicht gänzlich aufgegeben; habe ich einmal das Geld beisammen, um die Schuld der Eltern an ihn abzuzahlen - es dürfte noch fünf bis sechs Jahre dauern - , mache ich die Sache unbedingt. Dann wird der große Schnitt gemacht. Vorläufig allerdings muß ich aufstehen, denn mein Zug fährt um fünf.«\r
+\r
+Und er sah zur Weckuhr hinüber, die auf dem Kasten tickte. »Himmlischer Vater!«, dachte er. Es war halb sieben Uhr, und die Zeiger gingen ruhig vorwärts, es war sogar halb vorüber, es näherte sich schon dreiviertel. Sollte der Wecker nicht geläutet haben? Man sah vom Bett aus, daß er auf vier Uhr richtig eingestellt war; gewiß hatte er auch geläutet. Ja, aber war es möglich, dieses möbelerschütternde Läuten ruhig zu verschlafen? Nun, ruhig hatte er ja nicht geschlafen, aber wahrscheinlich desto fester. Was aber sollte er jetzt tun? Der nächste Zug ging um sieben Uhr; um den einzuholen, hätte er sich unsinnig beeilen müssen, und die Kollektion war noch nicht eingepackt, und er selbst fühlte sich durchaus nicht besonders frisch und beweglich. Und selbst wenn er den Zug einholte, ein Donnerwetter des Chefs war nicht zu vermeiden, denn der Geschäftsdiener hatte beim Fünfuhrzug gewartet und die Meldung von seiner Versäumnis längst erstattet. Es war eine Kreatur des Chefs, ohne Rückgrat und Verstand. Wie nun, wenn er sich krank meldete? Das wäre aber äußerst peinlich und verdächtig, denn Gregor war während seines fünfjährigen Dienstes noch nicht einmal krank gewesen. Gewiß würde der Chef mit dem Krankenkassenarzt kommen, würde den Eltern wegen des faulen Sohnes Vorwürfe machen und alle Einwände durch den Hinweis auf den Krankenkassenarzt abschneiden, für den es ja überhaupt nur ganz gesunde, aber arbeitsscheue Menschen gibt. Und hätte er übrigens in diesem Falle so ganz unrecht? Gregor fühlte sich tatsächlich, abgesehen von einer nach dem langen Schlaf wirklich überflüssigen Schläfrigkeit, ganz wohl und hatte sogar einen besonders kräftigen Hunger. \r
--- /dev/null
+Als Gregor Samsa eines Morgens aus unruhigen Träumen erwachte, fand er sich in seinem Bett zu einem ungeheueren Ungeziefer verwandelt. Er lag auf seinem panzerartig harten Rücken und sah, wenn er den Kopf ein wenig hob, seinen gewölbten, braunen, von bogenförmigen Versteifungen geteilten Bauch, auf dessen Höhe sich die Bettdecke, zum gänzlichen Niedergleiten bereit, kaum noch erhalten konnte. Seine vielen, im Vergleich zu seinem sonstigen Umfang kläglich dünnen Beine flimmerten ihm hilflos vor den Augen.
+
+»Was ist mit mir geschehen?«, dachte er. Es war kein Traum. Sein Zimmer, ein richtiges, nur etwas zu kleines Menschenzimmer, lag ruhig zwischen den vier wohlbekannten Wänden. Über dem Tisch, auf dem eine auseinandergepackte Musterkollektion von Tuchwaren ausgebreitet war - Samsa war Reisender - hing das Bild, das er vor kurzem aus einer illustrierten Zeitschrift ausgeschnitten und in einem hübschen, vergoldeten Rahmen untergebracht hatte. Es stellte eine Dame dar, die mit einem Pelzhut und einer Pelzboa versehen, aufrecht dasaß und einen schweren Pelzmuff, in dem ihr ganzer Unterarm verschwunden war, dem Beschauer entgegenhob.
+
+Gregors Blick richtete sich dann zum Fenster, und das trübe Wetter - man hörte Regentropfen auf das Fensterblech aufschlagen - machte ihn ganz melancholisch. »Wie wäre es, wenn ich noch ein wenig weiterschliefe und alle Narrheiten vergäße«, dachte er, aber das war gänzlich undurchführbar, denn er war gewöhnt, auf der rechten Seite zu schlafen, konnte sich aber in seinem gegenwärtigen Zustand nicht in diese Lage bringen. Mit welcher Kraft er sich auch auf die rechte Seite warf, immer wieder schaukelte er in die Rückenlage zurück. Er versuchte es wohl hundertmal, schloß die Augen, um die zappelnden Beine nicht sehen zu müssen, und ließ erst ab, als er in der Seite einen noch nie gefühlten, leichten, dumpfen Schmerz zu fühlen begann.
+
+»Ach Gott«, dachte er, »was für einen anstrengenden Beruf habe ich gewählt! Tag aus, Tag ein auf der Reise. Die geschäftlichen Aufregungen sind viel größer, als im eigentlichen Geschäft zu Hause, und außerdem ist mir noch diese Plage des Reisens auferlegt, die Sorgen um die Zuganschlüsse, das unregelmäßige, schlechte Essen, ein immer wechselnder, nie andauernder, nie herzlich werdender menschlicher Verkehr. Der Teufel soll das alles holen!« Er fühlte ein leichtes Jucken oben auf dem Bauch; schob sich auf dem Rücken langsam näher zum Bettpfosten, um den Kopf besser heben zu können; fand die juckende Stelle, die mit lauter kleinen weißen Pünktchen besetzt war, die er nicht zu beurteilen verstand; und wollte mit einem Bein die Stelle betasten, zog es aber gleich zurück, denn bei der Berührung umwehten ihn Kälteschauer.
+
+Er glitt wieder in seine frühere Lage zurück. »Dies frühzeitige Aufstehen«, dachte er, »macht einen ganz blödsinnig. Der Mensch muß seinen Schlaf haben. Andere Reisende leben wie Haremsfrauen. Wenn ich zum Beispiel im Laufe des Vormittags ins Gasthaus zurückgehe, um die erlangten Aufträge zu überschreiben, sitzen diese Herren erst beim Frühstück. Das sollte ich bei meinem Chef versuchen; ich würde auf der Stelle hinausfliegen. Wer weiß übrigens, ob das nicht sehr gut für mich wäre. Wenn ich mich nicht wegen meiner Eltern zurückhielte, ich hätte längst gekündigt, ich wäre vor den Chef hin getreten und hätte ihm meine Meinung von Grund des Herzens aus gesagt. Vom Pult hätte er fallen müssen! Es ist auch eine sonderbare Art, sich auf das Pult zu setzen und von der Höhe herab mit dem Angestellten zu reden, der überdies wegen der Schwerhörigkeit des Chefs ganz nahe herantreten muß. Nun, die Hoffnung ist noch nicht gänzlich aufgegeben; habe ich einmal das Geld beisammen, um die Schuld der Eltern an ihn abzuzahlen - es dürfte noch fünf bis sechs Jahre dauern - , mache ich die Sache unbedingt. Dann wird der große Schnitt gemacht. Vorläufig allerdings muß ich aufstehen, denn mein Zug fährt um fünf.«
+
+Und er sah zur Weckuhr hinüber, die auf dem Kasten tickte. »Himmlischer Vater!«, dachte er. Es war halb sieben Uhr, und die Zeiger gingen ruhig vorwärts, es war sogar halb vorüber, es näherte sich schon dreiviertel. Sollte der Wecker nicht geläutet haben? Man sah vom Bett aus, daß er auf vier Uhr richtig eingestellt war; gewiß hatte er auch geläutet. Ja, aber war es möglich, dieses möbelerschütternde Läuten ruhig zu verschlafen? Nun, ruhig hatte er ja nicht geschlafen, aber wahrscheinlich desto fester. Was aber sollte er jetzt tun? Der nächste Zug ging um sieben Uhr; um den einzuholen, hätte er sich unsinnig beeilen müssen, und die Kollektion war noch nicht eingepackt, und er selbst fühlte sich durchaus nicht besonders frisch und beweglich. Und selbst wenn er den Zug einholte, ein Donnerwetter des Chefs war nicht zu vermeiden, denn der Geschäftsdiener hatte beim Fünfuhrzug gewartet und die Meldung von seiner Versäumnis längst erstattet. Es war eine Kreatur des Chefs, ohne Rückgrat und Verstand. Wie nun, wenn er sich krank meldete? Das wäre aber äußerst peinlich und verdächtig, denn Gregor war während seines fünfjährigen Dienstes noch nicht einmal krank gewesen. Gewiß würde der Chef mit dem Krankenkassenarzt kommen, würde den Eltern wegen des faulen Sohnes Vorwürfe machen und alle Einwände durch den Hinweis auf den Krankenkassenarzt abschneiden, für den es ja überhaupt nur ganz gesunde, aber arbeitsscheue Menschen gibt. Und hätte er übrigens in diesem Falle so ganz unrecht? Gregor fühlte sich tatsächlich, abgesehen von einer nach dem langen Schlaf wirklich überflüssigen Schläfrigkeit, ganz wohl und hatte sogar einen besonders kräftigen Hunger.
--- /dev/null
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/flexi-streams/test/packages.lisp,v 1.8 2008/08/01 10:12:43 edi Exp $
+
+;;; Copyright (c) 2006-2008, Dr. Edmund Weitz. All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;; * Redistributions of source code must retain the above copyright
+;;; notice, this list of conditions and the following disclaimer.
+
+;;; * 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 BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; 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 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.
+
+(in-package :cl-user)
+
+(defpackage :flexi-streams-test
+ (:use :cl :flexi-streams)
+ (:import-from :flexi-streams
+ :with-unique-names
+ :with-rebinding
+ :char*
+ :normalize-external-format
+ :+name-map+
+ :+shortcut-map+)
+ (:export :run-all-tests))
--- /dev/null
+úÁÒÅÇÉÓÔÒÉÒÕÊÔÅÓØ ÓÅÊÞÁÓ ÎÁ äÅÓÑÔÕÀ íÅÖÄÕÎÁÒÏÄÎÕÀ ëÏÎÆÅÒÅÎÃÉÀ ÐÏ\rUnicode, ËÏÔÏÒÁÑ ÓÏÓÔÏÉÔÓÑ 10-12 ÍÁÒÔÁ 1997 ÇÏÄÁ × íÁÊÎÃÅ × çÅÒÍÁÎÉÉ.\rëÏÎÆÅÒÅÎÃÉÑ ÓÏÂÅÒÅÔ ÛÉÒÏËÉÊ ËÒÕÇ ÜËÓÐÅÒÔÏ× ÐÏ ×ÏÐÒÏÓÁÍ ÇÌÏÂÁÌØÎÏÇÏ\réÎÔÅÒÎÅÔÁ É Unicode, ÌÏËÁÌÉÚÁÃÉÉ É ÉÎÔÅÒÎÁÃÉÏÎÁÌÉÚÁÃÉÉ, ×ÏÐÌÏÝÅÎÉÀ É\rÐÒÉÍÅÎÅÎÉÀ Unicode × ÒÁÚÌÉÞÎÙÈ ÏÐÅÒÁÃÉÏÎÎÙÈ ÓÉÓÔÅÍÁÈ É ÐÒÏÇÒÁÍÍÎÙÈ\rÐÒÉÌÏÖÅÎÉÑÈ, ÛÒÉÆÔÁÈ, ×ÅÒÓÔËÅ É ÍÎÏÇÏÑÚÙÞÎÙÈ ËÏÍÐØÀÔÅÒÎÙÈ ÓÉÓÔÅÍÁÈ.\r
\ No newline at end of file
--- /dev/null
+úÁÒÅÇÉÓÔÒÉÒÕÊÔÅÓØ ÓÅÊÞÁÓ ÎÁ äÅÓÑÔÕÀ íÅÖÄÕÎÁÒÏÄÎÕÀ ëÏÎÆÅÒÅÎÃÉÀ ÐÏ\r
+Unicode, ËÏÔÏÒÁÑ ÓÏÓÔÏÉÔÓÑ 10-12 ÍÁÒÔÁ 1997 ÇÏÄÁ × íÁÊÎÃÅ × çÅÒÍÁÎÉÉ.\r
+ëÏÎÆÅÒÅÎÃÉÑ ÓÏÂÅÒÅÔ ÛÉÒÏËÉÊ ËÒÕÇ ÜËÓÐÅÒÔÏ× ÐÏ ×ÏÐÒÏÓÁÍ ÇÌÏÂÁÌØÎÏÇÏ\r
+éÎÔÅÒÎÅÔÁ É Unicode, ÌÏËÁÌÉÚÁÃÉÉ É ÉÎÔÅÒÎÁÃÉÏÎÁÌÉÚÁÃÉÉ, ×ÏÐÌÏÝÅÎÉÀ É\r
+ÐÒÉÍÅÎÅÎÉÀ Unicode × ÒÁÚÌÉÞÎÙÈ ÏÐÅÒÁÃÉÏÎÎÙÈ ÓÉÓÔÅÍÁÈ É ÐÒÏÇÒÁÍÍÎÙÈ\r
+ÐÒÉÌÏÖÅÎÉÑÈ, ÛÒÉÆÔÁÈ, ×ÅÒÓÔËÅ É ÍÎÏÇÏÑÚÙÞÎÙÈ ËÏÍÐØÀÔÅÒÎÙÈ ÓÉÓÔÅÍÁÈ.\r
--- /dev/null
+úÁÒÅÇÉÓÔÒÉÒÕÊÔÅÓØ ÓÅÊÞÁÓ ÎÁ äÅÓÑÔÕÀ íÅÖÄÕÎÁÒÏÄÎÕÀ ëÏÎÆÅÒÅÎÃÉÀ ÐÏ
+Unicode, ËÏÔÏÒÁÑ ÓÏÓÔÏÉÔÓÑ 10-12 ÍÁÒÔÁ 1997 ÇÏÄÁ × íÁÊÎÃÅ × çÅÒÍÁÎÉÉ.
+ëÏÎÆÅÒÅÎÃÉÑ ÓÏÂÅÒÅÔ ÛÉÒÏËÉÊ ËÒÕÇ ÜËÓÐÅÒÔÏ× ÐÏ ×ÏÐÒÏÓÁÍ ÇÌÏÂÁÌØÎÏÇÏ
+éÎÔÅÒÎÅÔÁ É Unicode, ÌÏËÁÌÉÚÁÃÉÉ É ÉÎÔÅÒÎÁÃÉÏÎÁÌÉÚÁÃÉÉ, ×ÏÐÌÏÝÅÎÉÀ É
+ÐÒÉÍÅÎÅÎÉÀ Unicode × ÒÁÚÌÉÞÎÙÈ ÏÐÅÒÁÃÉÏÎÎÙÈ ÓÉÓÔÅÍÁÈ É ÐÒÏÇÒÁÍÍÎÙÈ
+ÐÒÉÌÏÖÅÎÉÑÈ, ÛÒÉÆÔÁÈ, ×ÅÒÓÔËÅ É ÍÎÏÇÏÑÚÙÞÎÙÈ ËÏÍÐØÀÔÅÒÎÙÈ ÓÉÓÔÅÍÁÈ.
--- /dev/null
+Зарегистрируйтесь сейчас на Десятую Международную Конференцию по\rUnicode, которая состоится 10-12 марта 1997 года в Майнце в Германии.\rКонференция соберет широкий круг экспертов по вопросам глобального\rИнтернета и Unicode, локализации и интернационализации, воплощению и\rприменению Unicode в различных операционных системах и программных\rприложениях, шрифтах, верстке и многоязычных компьютерных системах.\r
\ No newline at end of file
--- /dev/null
+Зарегистрируйтесь сейчас на Десятую Международную Конференцию по\r
+Unicode, которая состоится 10-12 марта 1997 года в Майнце в Германии.\r
+Конференция соберет широкий круг экспертов по вопросам глобального\r
+Интернета и Unicode, локализации и интернационализации, воплощению и\r
+применению Unicode в различных операционных системах и программных\r
+приложениях, шрифтах, верстке и многоязычных компьютерных системах.\r
--- /dev/null
+Зарегистрируйтесь сейчас на Десятую Международную Конференцию по
+Unicode, которая состоится 10-12 марта 1997 года в Майнце в Германии.
+Конференция соберет широкий круг экспертов по вопросам глобального
+Интернета и Unicode, локализации и интернационализации, воплощению и
+применению Unicode в различных операционных системах и программных
+приложениях, шрифтах, верстке и многоязычных компьютерных системах.
--- /dev/null
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: FLEXI-STREAMS-TEST; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/flexi-streams/test/test.lisp,v 1.39 2008/05/30 09:10:55 edi Exp $
+
+;;; Copyright (c) 2006-2008, Dr. Edmund Weitz. All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;; * Redistributions of source code must retain the above copyright
+;;; notice, this list of conditions and the following disclaimer.
+
+;;; * 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 BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; 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 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.
+
+(in-package :flexi-streams-test)
+
+(defmacro with-test-suite ((test-description &key show-progress-p) &body body)
+ "Defines a test suite. Three utilities are available inside of the
+body of the macro: The function FAIL, and the macros CHECK and
+WITH-EXPECTED-ERROR. FAIL, the lowest level utility, marks the test
+defined by WITH-TEST-SUITE as failed. CHECK checks whether its argument is
+true, otherwise it calls FAIL. If during evaluation of the specified
+expression any condition is signalled, this is also considered a
+failure. WITH-EXPECTED-ERROR executes its body and considers the test
+a success if the specified error was signalled, otherwise it calls
+FAIL.
+
+WITH-TEST-SUITE prints a simple progress report if SHOW-PROGRESS-P is true."
+ (with-unique-names (successp testcount)
+ (with-rebinding (show-progress-p)
+ `(let ((,successp t)
+ (,testcount 1))
+ (when (and ,show-progress-p (not (numberp ,show-progress-p)))
+ (setq ,show-progress-p 1))
+ (flet ((fail (format-str &rest format-args)
+ (apply #'format t format-str format-args)
+ (setq ,successp nil))
+ (maybe-show-progress ()
+ (when (and ,show-progress-p (zerop (mod ,testcount ,show-progress-p)))
+ (format t ".")
+ (when (zerop (mod ,testcount (* 10 ,show-progress-p)))
+ (terpri))
+ (force-output))
+ (incf ,testcount)))
+ (macrolet ((check (expression)
+ `(progn
+ (maybe-show-progress)
+ (handler-case
+ (unless ,expression
+ (fail "~&Test ~S failed.~%" ',expression))
+ (error (c)
+ (fail "~&Test ~S failed signalling error of type ~A: ~A.~%"
+ ',expression (type-of c) c)))))
+ (with-expected-error ((condition-type) &body body)
+ `(progn
+ (maybe-show-progress)
+ (handler-case (progn ,@body)
+ (,condition-type () t)
+ (:no-error (&rest args)
+ (declare (ignore args))
+ (fail "~&Expected condition ~S not signalled.~%"
+ ',condition-type))))))
+ (format t "~&Test suite: ~S~%" ,test-description)
+ ,@body))
+ ,successp))))
+
+;; LW can't indent this correctly because it's in a MACROLET
+#+:lispworks
+(editor:setup-indent "with-expected-error" 1 2 4)
+
+(defconstant +buffer-size+ 8192
+ "Size of buffers for COPY-STREAM* below.")
+
+(defvar *copy-function* nil
+ "Which function to use when copying from one stream to the other -
+see for example COPY-FILE below.")
+
+(defvar *this-file* (load-time-value
+ (or #.*compile-file-pathname* *load-pathname*))
+ "The pathname of the file \(`test.lisp') where this variable was
+defined.")
+
+#+:lispworks
+(defun get-env-variable-as-directory (name)
+ (lw:when-let (string (lw:environment-variable name))
+ (when (plusp (length string))
+ (cond ((find (char string (1- (length string))) "\\/" :test #'char=) string)
+ (t (lw:string-append string "/"))))))
+
+(defvar *tmp-dir*
+ (load-time-value
+ (merge-pathnames "odd-streams-test/"
+ #+:allegro (system:temporary-directory)
+ #+:lispworks (pathname (or (get-env-variable-as-directory "TEMP")
+ (get-env-variable-as-directory "TMP")
+ #+:win32 "C:/"
+ #-:win32 "/tmp/"))
+ #-(or :allegro :lispworks) #p"/tmp/"))
+ "The pathname of a temporary directory used for testing.")
+
+(defvar *test-files*
+ '(("kafka" (:utf8 :latin1 :cp1252))
+ ("tilton" (:utf8 :ascii))
+ ("hebrew" (:utf8 :latin8))
+ ("russian" (:utf8 :koi8r))
+ ("unicode_demo" (:utf8 :ucs2 :ucs4)))
+ "A list of test files where each entry consists of the name
+prefix and a list of encodings.")
+
+(defun create-file-variants (file-name symbol)
+ "For a name suffix FILE-NAME and a symbol SYMBOL denoting an
+encoding returns a list of pairs where the car is a full file
+name and the cdr is the corresponding external format. This list
+contains all possible variants w.r.t. to line-end conversion and
+endianness."
+ (let ((args (ecase symbol
+ (:ascii '(:ascii))
+ (:latin1 '(:latin-1))
+ (:latin8 '(:hebrew))
+ (:cp1252 '(:code-page :id 1252))
+ (:koi8r '(:koi8-r))
+ (:utf8 '(:utf-8))
+ (:ucs2 '(:utf-16))
+ (:ucs4 '(:utf-32))))
+ (endianp (member symbol '(:ucs2 :ucs4))))
+ (loop for little-endian in (if endianp '(t nil) '(t))
+ for endian-suffix in (if endianp '("_le" "_be") '(""))
+ nconc (loop for eol-style in '(:lf :cr :crlf)
+ collect (cons (format nil "~A_~(~A~)_~(~A~)~A.txt"
+ file-name symbol eol-style endian-suffix)
+ (apply #'make-external-format
+ (append args `(:eol-style ,eol-style
+ :little-endian ,little-endian))))))))
+
+(defun create-test-combinations (file-name symbols &optional simplep)
+ "For a name suffix FILE-NAME and a list of symbols SYMBOLS denoting
+different encodings of the corresponding file returns a list of lists
+which can be used as arglists by COMPARE-FILES. If SIMPLEP is true, a
+list which can be used for the string and sequence tests below is
+returned."
+ (let ((file-variants (loop for symbol in symbols
+ nconc (create-file-variants file-name symbol))))
+ (loop for (name-in . external-format-in) in file-variants
+ when simplep
+ collect (list name-in external-format-in)
+ else
+ nconc (loop for (name-out . external-format-out) in file-variants
+ collect (list name-in external-format-in name-out external-format-out)))))
+
+(defun file-equal (file1 file2)
+ "Returns a true value iff FILE1 and FILE2 have the same
+contents \(viewed as binary files)."
+ (with-open-file (stream1 file1 :element-type 'octet)
+ (with-open-file (stream2 file2 :element-type 'octet)
+ (and (= (file-length stream1) (file-length stream2))
+ (loop for byte1 = (read-byte stream1 nil nil)
+ for byte2 = (read-byte stream2 nil nil)
+ while (and byte1 byte2)
+ always (= byte1 byte2))))))
+
+(defun copy-stream (stream-in external-format-in stream-out external-format-out)
+ "Copies the contents of the binary stream STREAM-IN to the
+binary stream STREAM-OUT using flexi streams - STREAM-IN is read
+with the external format EXTERNAL-FORMAT-IN and STREAM-OUT is
+written with EXTERNAL-FORMAT-OUT."
+ (let ((in (make-flexi-stream stream-in :external-format external-format-in))
+ (out (make-flexi-stream stream-out :external-format external-format-out)))
+ (loop for line = (read-line in nil nil)
+ while line
+ do (write-line line out))))
+
+(defun copy-stream* (stream-in external-format-in stream-out external-format-out)
+ "Like COPY-STREAM, but uses READ-SEQUENCE and WRITE-SEQUENCE instead
+of READ-LINE and WRITE-LINE."
+ (let ((in (make-flexi-stream stream-in :external-format external-format-in))
+ (out (make-flexi-stream stream-out :external-format external-format-out))
+ (buffer (make-array +buffer-size+ :element-type 'char*)))
+ (loop
+ (let ((position (read-sequence buffer in)))
+ (when (zerop position) (return))
+ (write-sequence buffer out :end position)))))
+
+(defun copy-file (path-in external-format-in path-out external-format-out direction-out direction-in)
+ "Copies the contents of the file denoted by the pathname
+PATH-IN to the file denoted by the pathname PATH-OUT using flexi
+streams - STREAM-IN is read with the external format
+EXTERNAL-FORMAT-IN and STREAM-OUT is written with
+EXTERNAL-FORMAT-OUT. The input file is opened with
+the :DIRECTION keyword argument DIRECTION-IN, the output file is
+opened with the :DIRECTION keyword argument DIRECTION-OUT."
+ (with-open-file (in path-in
+ :element-type 'octet
+ :direction direction-in
+ :if-does-not-exist :error
+ :if-exists :overwrite)
+ (with-open-file (out path-out
+ :element-type 'octet
+ :direction direction-out
+ :if-does-not-exist :create
+ :if-exists :supersede)
+ (funcall *copy-function* in external-format-in out external-format-out))))
+
+#+:lispworks
+(defun copy-file-lw (path-in external-format-in path-out external-format-out direction-out direction-in)
+ "Same as COPY-FILE, but uses character streams instead of
+binary streams. Only used to test LispWorks-specific behaviour."
+ (with-open-file (in path-in
+ :external-format '(:latin-1 :eol-style :lf)
+ :element-type 'base-char
+ :direction direction-in
+ :if-does-not-exist :error
+ :if-exists :overwrite)
+ (with-open-file (out path-out
+ :external-format '(:latin-1 :eol-style :lf)
+ :element-type 'base-char
+ :direction direction-out
+ :direction :output
+ :if-does-not-exist :create
+ :if-exists :supersede)
+ (funcall *copy-function* in external-format-in out external-format-out))))
+
+(defun compare-files (&key verbose)
+ "Each test in this suite copies the contents of one file \(in the
+`test' directory) to another file \(in a temporary directory) using
+flexi streams with different external formats. The resulting file is
+compared with an existing file in the `test' directory to check if the
+outcome is as expected. Uses various variants of the :DIRECTION
+keyword when opening the files.
+
+Returns a true value iff all tests succeeded. Prints information
+about each individual comparison if VERBOSE is true."
+ (with-test-suite ("Reading/writing files" :show-progress-p (not verbose))
+ (flet ((one-comparison (path-in external-format-in path-out external-format-out verbose)
+ (when verbose
+ (format t "~&File ~S, using copy function ~S" (file-namestring path-in) *copy-function*)
+ (format t "~& and external formats ~S --> ~S"
+ (normalize-external-format external-format-in)
+ (normalize-external-format external-format-out)))
+ (let ((full-path-in (merge-pathnames path-in *this-file*))
+ (full-path-out (ensure-directories-exist
+ (merge-pathnames path-out *tmp-dir*)))
+ (full-path-orig (merge-pathnames path-out *this-file*)))
+ (dolist (direction-out '(:output :io))
+ (dolist (direction-in '(:input :io))
+ (when verbose
+ (format t "~&...directions ~S --> ~S" direction-in direction-out))
+ (copy-file full-path-in external-format-in
+ full-path-out external-format-out
+ direction-out direction-in)
+ (check (file-equal full-path-out full-path-orig))
+ #+:lispworks
+ (progn
+ (when verbose
+ (format t "~&...directions ~S --> ~S \(LispWorks)" direction-in direction-out))
+ (copy-file-lw full-path-in external-format-in
+ full-path-out external-format-out
+ direction-out direction-in)
+ (check (file-equal full-path-out full-path-orig))))))))
+ (loop with compare-files-args-list = (loop for (file-name symbols) in *test-files*
+ nconc (create-test-combinations file-name symbols))
+ for *copy-function* in '(copy-stream copy-stream*)
+ do (loop for (path-in external-format-in path-out external-format-out) in compare-files-args-list
+ do (one-comparison path-in external-format-in path-out external-format-out verbose))))))
+
+(defun file-as-octet-vector (pathspec)
+ "Returns the contents of the file denoted by PATHSPEC as a vector of
+octets."
+ (with-open-file (in pathspec :element-type 'octet)
+ (let ((vector (make-array (file-length in) :element-type 'octet)))
+ (read-sequence vector in)
+ vector)))
+
+(defun file-as-string (pathspec external-format)
+ "Reads the contents of the file denoted by PATHSPEC using the
+external format EXTERNAL-FORMAT and returns the result as a string."
+ (with-open-file (in pathspec :element-type 'octet)
+ (let* ((number-of-octets (file-length in))
+ (in (make-flexi-stream in :external-format external-format))
+ (string (make-array number-of-octets
+ :element-type #+:lispworks 'lw:simple-char
+ #-:lispworks 'character
+ :fill-pointer t)))
+ (setf (fill-pointer string) (read-sequence string in))
+ string)))
+
+(defun old-string-to-octets (string &key
+ (external-format (make-external-format :latin1))
+ (start 0) end)
+ "The old version of STRING-TO-OCTETS. We can use it to test
+in-memory streams."
+ (declare (optimize speed))
+ (with-output-to-sequence (out)
+ (let ((flexi (make-flexi-stream out :external-format external-format)))
+ (write-string string flexi :start start :end end))))
+
+(defun old-octets-to-string (vector &key
+ (external-format (make-external-format :latin1))
+ (start 0) (end (length vector)))
+ "The old version of OCTETS-TO-STRING. We can use it to test
+in-memory streams."
+ (declare (optimize speed))
+ (with-input-from-sequence (in vector :start start :end end)
+ (let ((flexi (make-flexi-stream in :external-format external-format))
+ (result (make-array (- end start)
+ :element-type #+:lispworks 'lw:simple-char
+ #-:lispworks 'character
+ :fill-pointer t)))
+ (setf (fill-pointer result)
+ (read-sequence result flexi))
+ result)))
+
+(defun string-tests (&key verbose)
+ "Tests whether conversion from strings to octets and vice versa
+works as expected. Also tests with the old versions of the conversion
+functions in order to test in-memory streams."
+ (with-test-suite ("String tests" :show-progress-p (and (not verbose) 10))
+ (flet ((one-string-test (pathspec external-format verbose)
+ (when verbose
+ (format t "~&With external format ~S:" (normalize-external-format external-format)))
+ (let* ((full-path (merge-pathnames pathspec *this-file*))
+ (octets-vector (file-as-octet-vector full-path))
+ (octets-list (coerce octets-vector 'list))
+ (string (file-as-string full-path external-format)))
+ (when verbose
+ (format t "~&...testing OCTETS-TO-STRING"))
+ (check (string= (octets-to-string octets-vector :external-format external-format) string))
+ (check (string= (octets-to-string octets-list :external-format external-format) string))
+ (when verbose
+ (format t "~&...testing STRING-TO-OCTETS"))
+ (check (equalp (string-to-octets string :external-format external-format) octets-vector))
+ (when verbose
+ (format t "~&...testing in-memory streams"))
+ (check (string= (old-octets-to-string octets-vector :external-format external-format) string))
+ (check (string= (old-octets-to-string octets-list :external-format external-format) string))
+ (check (equalp (old-string-to-octets string :external-format external-format) octets-vector)))))
+ (loop with simple-test-args-list = (loop for (file-name symbols) in *test-files*
+ nconc (create-test-combinations file-name symbols t))
+ for (pathspec external-format) in simple-test-args-list
+ do (one-string-test pathspec external-format verbose)))))
+
+
+(defun sequence-equal (seq1 seq2)
+ "Whether the two sequences have the same elements."
+ (and (= (length seq1) (length seq2))
+ (loop for i below (length seq1)
+ always (eql (elt seq1 i) (elt seq2 i)))))
+
+(defun sequence-tests (&key verbose)
+ "Several tests to confirm that READ-SEQUENCE and WRITE-SEQUENCE
+behave as expected."
+ (with-test-suite ("Sequence tests" :show-progress-p (and (not verbose) 10))
+ (flet ((one-sequence-test (pathspec external-format verbose)
+ (when verbose
+ (format t "~&With external format ~S:" (normalize-external-format external-format)))
+ (let* ((full-path (merge-pathnames pathspec *this-file*))
+ (file-string (file-as-string full-path external-format))
+ (string-length (length file-string))
+ (octets (file-as-octet-vector full-path))
+ (octet-length (length octets)))
+ (when (external-format-equal external-format (make-external-format :utf8))
+ (when verbose
+ (format t "~&...reading octets"))
+ #-:openmcl
+ ;; FLEXI-STREAMS puts integers into the list, but OpenMCL
+ ;; thinks they are characters...
+ (with-open-file (in full-path :element-type 'octet)
+ (let* ((in (make-flexi-stream in :external-format external-format))
+ (list (make-list octet-length)))
+ (setf (flexi-stream-element-type in) 'octet)
+ #-:clisp
+ (read-sequence list in)
+ #+:clisp
+ (ext:read-byte-sequence list in)
+ (check (sequence-equal list octets))))
+ (with-open-file (in full-path :element-type 'octet)
+ (let* ((in (make-flexi-stream in :external-format external-format))
+ (third (floor octet-length 3))
+ (half (floor octet-length 2))
+ (vector (make-array half :element-type 'octet)))
+ (check (sequence-equal (loop repeat third
+ collect (read-byte in))
+ (subseq octets 0 third)))
+ (read-sequence vector in)
+ (check (sequence-equal vector (subseq octets third (+ third half)))))))
+ (when verbose
+ (format t "~&...reading characters"))
+ (with-open-file (in full-path :element-type 'octet)
+ (let* ((in (make-flexi-stream in :external-format external-format))
+ (string (make-string (- string-length 10) :element-type 'char*)))
+ (setf (flexi-stream-element-type in) 'octet)
+ (check (sequence-equal (loop repeat 10
+ collect (read-char in))
+ (subseq file-string 0 10)))
+ (read-sequence string in)
+ (check (sequence-equal string (subseq file-string 10)))))
+ (with-open-file (in full-path :element-type 'octet)
+ (let* ((in (make-flexi-stream in :external-format external-format))
+ (list (make-list (- string-length 100))))
+ (check (sequence-equal (loop repeat 50
+ collect (read-char in))
+ (subseq file-string 0 50)))
+ #-:clisp
+ (read-sequence list in)
+ #+:clisp
+ (ext:read-char-sequence list in)
+ (check (sequence-equal list (subseq file-string 50 (- string-length 50))))
+ (check (sequence-equal (loop repeat 50
+ collect (read-char in))
+ (subseq file-string (- string-length 50))))))
+ (with-open-file (in full-path :element-type 'octet)
+ (let* ((in (make-flexi-stream in :external-format external-format))
+ (array (make-array (- string-length 50))))
+ (check (sequence-equal (loop repeat 25
+ collect (read-char in))
+ (subseq file-string 0 25)))
+ #-:clisp
+ (read-sequence array in)
+ #+:clisp
+ (ext:read-char-sequence array in)
+ (check (sequence-equal array (subseq file-string 25 (- string-length 25))))
+ (check (sequence-equal (loop repeat 25
+ collect (read-char in))
+ (subseq file-string (- string-length 25))))))
+ (let ((path-out (ensure-directories-exist (merge-pathnames pathspec *tmp-dir*))))
+ (when verbose
+ (format t "~&...writing sequences"))
+ (with-open-file (out path-out
+ :direction :output
+ :if-exists :supersede
+ :element-type 'octet)
+ (let ((out (make-flexi-stream out :external-format external-format)))
+ (write-sequence octets out)))
+ (check (file-equal full-path path-out))
+ (with-open-file (out path-out
+ :direction :output
+ :if-exists :supersede
+ :element-type 'octet)
+ (let ((out (make-flexi-stream out :external-format external-format)))
+ (write-sequence file-string out)))
+ (check (file-equal full-path path-out))
+ (with-open-file (out path-out
+ :direction :output
+ :if-exists :supersede
+ :element-type 'octet)
+ (let ((out (make-flexi-stream out :external-format external-format)))
+ (write-sequence file-string out :end 100)
+ (write-sequence octets out
+ :start (length (string-to-octets file-string
+ :external-format external-format
+ :end 100)))))
+ (check (file-equal full-path path-out))))))
+
+ (loop with simple-test-args-list = (loop for (file-name symbols) in *test-files*
+ nconc (create-test-combinations file-name symbols t))
+ for (pathspec external-format) in simple-test-args-list
+ do (one-sequence-test pathspec external-format verbose)))))
+
+(defmacro using-values ((&rest values) &body body)
+ "Executes BODY and feeds an element from VALUES to the USE-VALUE
+restart each time a EXTERNAL-FORMAT-ENCODING-ERROR is signalled.
+Signals an error when there are more or less
+EXTERNAL-FORMAT-ENCODING-ERRORs than there are elements in VALUES."
+ (with-unique-names (value-stack condition-counter)
+ `(let ((,value-stack ',values)
+ (,condition-counter 0))
+ (handler-bind ((external-format-encoding-error
+ #'(lambda (c)
+ (declare (ignore c))
+ (unless ,value-stack
+ (error "Too many encoding errors signalled, expected only ~A."
+ ,(length values)))
+ (incf ,condition-counter)
+ (use-value (pop ,value-stack)))))
+ (prog1 (progn ,@body)
+ (when ,value-stack
+ (error "~A encoding errors signalled, but ~A were expected."
+ ,condition-counter ,(length values))))))))
+
+(defun accept-overlong (octets code-point)
+ "Converts the `overlong' UTF-8 sequence OCTETS to using
+OCTETS-TO-STRINGS, accepts the expected error with the corresponding
+restart and checks that the result is CODE-POINT."
+ (handler-bind ((external-format-encoding-error
+ (lambda (c)
+ (declare (ignore c))
+ (invoke-restart 'accept-overlong-sequence))))
+ (string= (octets-to-string octets :external-format :utf-8)
+ (string (code-char code-point)))))
+
+(defun read-flexi-line (sequence external-format)
+ "Creates and returns a string from the octet sequence SEQUENCE using
+the external format EXTERNAL-FORMAT."
+ (with-input-from-sequence (in sequence)
+ (setq in (make-flexi-stream in :external-format external-format))
+ (read-line in)))
+
+(defun read-flexi-line* (sequence external-format)
+ "Like READ-FLEXI-LINE but uses OCTETS-TO-STRING internally."
+ (octets-to-string sequence :external-format external-format))
+
+(defun error-handling-tests (&key verbose)
+ "Tests several possible errors and how they are handled."
+ (with-test-suite ("Testing error handling" :show-progress-p (not verbose))
+ (macrolet ((want-encoding-error (input format)
+ `(with-expected-error (external-format-encoding-error)
+ (read-flexi-line* ,input ,format))))
+ (when verbose
+ (format t "~&\"Overlong\" UTF-8 sequences"))
+ (want-encoding-error #(#b11000000 #b10000000) :utf-8)
+ (want-encoding-error #(#b11000001 #b10000000) :utf-8)
+ (want-encoding-error #(#b11100000 #b10011111 #b10000000) :utf-8)
+ (want-encoding-error #(#b11110000 #b10001111 #b10000000 #b10000000) :utf-8)
+ (check (accept-overlong #(#b11000000 #b10000000) #b00000000))
+ (check (accept-overlong #(#b11000001 #b10000000) #b01000000))
+ (check (accept-overlong #(#b11100000 #b10011111 #b10000000) #b011111000000))
+ (check (accept-overlong #(#b11110000 #b10001111 #b10000000 #b10000000)
+ #b1111000000000000))
+ (when verbose
+ (format t "~&Invalid lead octets in UTF-8"))
+ (want-encoding-error #(#b11111000) :utf-8)
+ (want-encoding-error #(#b11111001) :utf-8)
+ (want-encoding-error #(#b11111100) :utf-8)
+ (want-encoding-error #(#b11111101) :utf-8)
+ (want-encoding-error #(#b11111110) :utf-8)
+ (want-encoding-error #(#b11111111) :utf-8)
+ (when verbose
+ (format t "~&Illegal code points"))
+ (want-encoding-error #(#x00 #x00 #x11 #x00) :utf-32le)
+ (want-encoding-error #(#x00 #xd8) :utf-16le)
+ (want-encoding-error #(#xff #xdf) :utf-16le))
+ (macrolet ((want-encoding-error (input format)
+ `(with-expected-error (external-format-encoding-error)
+ (read-flexi-line* ,input ,format))))
+ (when verbose
+ (format t "~&UTF-8 sequences which are too short"))
+ (want-encoding-error #(#xe4 #xf6 #xfc) :utf8)
+ (want-encoding-error #(#xc0) :utf8)
+ (want-encoding-error #(#xe0 #xff) :utf8)
+ (want-encoding-error #(#xf0 #xff #xff) :utf8)
+ (when verbose
+ (format t "~&UTF-16 sequences with an odd number of octets"))
+ (want-encoding-error #(#x01) :utf-16le)
+ (want-encoding-error #(#x01 #x01 #x01) :utf-16le)
+ (want-encoding-error #(#x01) :utf-16be)
+ (want-encoding-error #(#x01 #x01 #x01) :utf-16be)
+ (when verbose
+ (format t "~&Missing words in UTF-16"))
+ (want-encoding-error #(#x01 #xd8) :utf-16le)
+ (want-encoding-error #(#xd8 #x01) :utf-16be)
+ (when verbose
+ (format t "~&Missing octets in UTF-32"))
+ (want-encoding-error #(#x01) :utf-32le)
+ (want-encoding-error #(#x01 #x01) :utf-32le)
+ (want-encoding-error #(#x01 #x01 #x01) :utf-32le)
+ (want-encoding-error #(#x01 #x01 #x01 #x01 #x01) :utf-32le)
+ (want-encoding-error #(#x01) :utf-32be)
+ (want-encoding-error #(#x01 #x01) :utf-32be)
+ (want-encoding-error #(#x01 #x01 #x01) :utf-32be)
+ (want-encoding-error #(#x01 #x01 #x01 #x01 #x01) :utf-32be))
+ (when verbose
+ (format t "~&Handling of EOF in the middle of CRLF"))
+ (check (string= #.(string #\Return)
+ (read-flexi-line `(,(char-code #\Return)) '(:ascii :eol-style :crlf))))
+ (let ((*substitution-char* #\?))
+ (when verbose
+ (format t "~&Fixed substitution character #\?")
+ (format t "~&:ASCII doesn't have characters with char codes > 127"))
+ (check (string= "a??" (read-flexi-line `(,(char-code #\a) 128 200) :ascii)))
+ (check (string= "a??" (read-flexi-line* `#(,(char-code #\a) 128 200) :ascii)))
+ (when verbose
+ (format t "~&:WINDOWS-1253 doesn't have a characters with codes 170 and 210"))
+ (check (string= "a??" (read-flexi-line `(,(char-code #\a) 170 210) :windows-1253)))
+ (check (string= "a??" (read-flexi-line* `#(,(char-code #\a) 170 210) :windows-1253)))
+ (when verbose
+ (format t "~&Not a valid UTF-8 sequence"))
+ (check (string= "??" (read-flexi-line '(#xe4 #xf6 #xfc) :utf8))))
+ (let ((*substitution-char* nil))
+ (when verbose
+ (format t "~&Variable substitution using USE-VALUE restart")
+ (format t "~&:ASCII doesn't have characters with char codes > 127"))
+ (check (string= "abc" (using-values (#\b #\c)
+ (read-flexi-line `(,(char-code #\a) 128 200) :ascii))))
+ (check (string= "abc" (using-values (#\b #\c)
+ (read-flexi-line* `#(,(char-code #\a) 128 200) :ascii))))
+ (when verbose
+ (format t "~&:WINDOWS-1253 doesn't have a characters with codes 170 and 210"))
+ (check (string= "axy" (using-values (#\x #\y)
+ (read-flexi-line `(,(char-code #\a) 170 210) :windows-1253))))
+ (check (string= "axy" (using-values (#\x #\y)
+ (read-flexi-line* `#(,(char-code #\a) 170 210) :windows-1253))))
+ (when verbose
+ (format t "~&Not a valid UTF-8 sequence"))
+ (check (string= "QW" (using-values (#\Q #\W) (read-flexi-line '(#xe4 #xf6 #xfc) :utf8))))
+ (when verbose
+ (format t "~&UTF-8 can't start neither with #b11111110 nor with #b11111111"))
+ (check (string= "QW" (using-values (#\Q #\W) (read-flexi-line '(#b11111110 #b11111111) :utf8))))
+ (when verbose
+ (format t "~&Only one octet in UTF-16 sequence"))
+ (check (string= "E" (using-values (#\E) (read-flexi-line '(#x01) :utf-16le))))
+ (when verbose
+ (format t "~&Two octets in UTF-16, but value of resulting word suggests that another word follows"))
+ (check (string= "R" (using-values (#\R) (read-flexi-line '(#x01 #xd8) :utf-16le))))
+ (when verbose
+ (format t "~&The second word must fit into the [#xdc00; #xdfff] interval, but it is #xdbff"))
+ (check (string= "T" (using-values (#\T) (read-flexi-line '(#x01 #xd8 #xff #xdb) :utf-16le))))
+ (check (string= "T" (using-values (#\T) (read-flexi-line* #(#x01 #xd8 #xff #xdb) :utf-16le))))
+ (when verbose
+ (format t "~&The same as for little endian above, but using inverse order of bytes in words"))
+ (check (string= "E" (using-values (#\E) (read-flexi-line '(#x01) :utf-16be))))
+ (check (string= "R" (using-values (#\R) (read-flexi-line '(#xd8 #x01) :utf-16be))))
+ (check (string= "T" (using-values (#\T) (read-flexi-line '(#xd8 #x01 #xdb #xff) :utf-16be))))
+ (check (string= "T" (using-values (#\T) (read-flexi-line* #(#xd8 #x01 #xdb #xff) :utf-16be))))
+ (when verbose
+ (format t "~&EOF in the middle of a 4-octet sequence in UTF-32"))
+ (check (string= "Y" (using-values (#\Y) (read-flexi-line '(#x01) :utf-32le))))
+ (check (string= "Y" (using-values (#\Y) (read-flexi-line '(#x01 #x01) :utf-32le))))
+ (check (string= "Y" (using-values (#\Y) (read-flexi-line '(#x01 #x01 #x01) :utf-32le))))
+ (check (string= "aY" (using-values (#\Y)
+ (read-flexi-line `(,(char-code #\a) #x00 #x00 #x00 #x01) :utf-32le))))
+ (check (string= "Y" (using-values (#\Y) (read-flexi-line '(#x01) :utf-32be))))
+ (check (string= "Y" (using-values (#\Y) (read-flexi-line '(#x01 #x01) :utf-32be))))
+ (check (string= "Y" (using-values (#\Y) (read-flexi-line '(#x01 #x01 #x01) :utf-32be))))
+ (check (string= "aY" (using-values (#\Y)
+ (read-flexi-line `(#x00 #x00 #x00 ,(char-code #\a) #x01) :utf-32be)))))))
+
+(defun unread-char-tests (&key verbose)
+ "Tests whether UNREAD-CHAR behaves as expected."
+ (with-test-suite ("UNREAD-CHAR behaviour." :show-progress-p (and (not verbose) 100))
+ (flet ((test-one-file (file-name external-format)
+ (when verbose
+ (format t "~& ...and external format ~A" (normalize-external-format external-format)))
+ (with-open-file (in (merge-pathnames file-name *this-file*)
+ :element-type 'flex:octet)
+ (let ((in (make-flexi-stream in :external-format external-format)))
+ (loop repeat 300
+ for char = (read-char in)
+ do (unread-char char in)
+ (check (char= (read-char in) char)))))))
+ (loop for (file-name symbols) in *test-files*
+ when verbose
+ do (format t "~&With file ~S" file-name)
+ do (loop for symbol in symbols
+ do (loop for (file-name . external-format) in (create-file-variants file-name symbol)
+ do (test-one-file file-name external-format)))))))
+
+(defun column-tests (&key verbose)
+ (with-test-suite ("STREAM-LINE-COLUMN tests" :show-progress-p (not verbose))
+ (let* ((binary-stream (flexi-streams:make-in-memory-output-stream))
+ (stream (flexi-streams:make-flexi-stream binary-stream :external-format :iso-8859-1)))
+ (write-sequence "hello" stream)
+ (format stream "~12Tworld")
+ (finish-output stream)
+ (check (string= "hello world"
+ (flexi-streams:octets-to-string
+ (flexi-streams::vector-stream-vector binary-stream)
+ :external-format :iso-8859-1)))
+ (terpri stream)
+ (check (= 0 (flexi-stream-column stream)))
+ (write-sequence "abc" stream)
+ (check (= 3 (flexi-stream-column stream)))
+ (terpri stream)
+ (check (= 0 (flexi-stream-column stream))))))
+
+(defun make-external-format-tests (&key verbose)
+ (with-test-suite ("MAKE-EXTERNAL-FORMAT tests" :show-progress-p (not verbose))
+ (flet ((make-case (real-name &key id name)
+ (list real-name
+ :id id
+ :input-names (list name (string-upcase name) (string-downcase name)))))
+ (let ((cases (append '((:utf-8 :id nil
+ :input-names (:utf8 :utf-8 "utf8" "utf-8" "UTF8" "UTF-8")))
+ (loop for (name . real-name) in +name-map+
+ unless (member :code-page (list name real-name))
+ append (list (make-case real-name :name name)
+ (make-case real-name :name real-name)))
+ (loop for (name . definition) in +shortcut-map+
+ for key = (car definition)
+ for id = (getf (cdr definition) :id)
+ for expected = (or (cdr (assoc key +name-map+)) key)
+ collect (make-case expected :id id :name name)))))
+
+ (loop for (expected-name . kwargs) in cases
+ for id = (getf kwargs :id)
+ for input-names = (getf kwargs :input-names)
+ do (loop for name in input-names
+ for ext-format = (make-external-format name)
+ do (check (eq (flex:external-format-name ext-format) expected-name))
+ when id
+ do (check (= (flex:external-format-id ext-format) id))))))
+
+ (let ((error-cases '("utf-8 " " utf-8" "utf8 " " utf8" "utf89" :utf89 utf89 :code-page nil)))
+ (loop for input-name in error-cases
+ do (with-expected-error (external-format-error)
+ (make-external-format input-name))))))
+
+(defun run-all-tests (&key verbose)
+ "Runs all tests for FLEXI-STREAMS and returns a true value iff all
+tests succeeded. VERBOSE is interpreted by the individual test suites
+above."
+ (let ((successp t))
+ (macrolet ((run-test-suite (&body body)
+ `(unless (progn ,@body)
+ (setq successp nil))))
+ (run-test-suite (compare-files :verbose verbose))
+ (run-test-suite (string-tests :verbose verbose))
+ (run-test-suite (sequence-tests :verbose verbose))
+ (run-test-suite (error-handling-tests :verbose verbose))
+ (run-test-suite (unread-char-tests :verbose verbose))
+ (run-test-suite (column-tests :verbose verbose))
+ (run-test-suite (make-external-format-tests :verbose verbose))
+ (format t "~2&~:[Some tests failed~;All tests passed~]." successp)
+ successp)))
+
--- /dev/null
+Programmers who lock onto a design decision and cling to it in the face of\rcontradictory new information -- well, that's almost everyone in my\rexperience, so I better not say what I think of them or people will start\rsaying bad things about me on c.l.l.\r -- Ken Tilton\r%\rThis reminds me of the NYC cabby who accepted a fare to Chicago. When\rthey got there and could not find the friend who was supposed to pay the\rfare he just laughed and said he should have known.\r -- Ken Tilton\r%\r>> Actually, I believe that Aikido, Jazz and Lisp are different appearances\r>> of the same thing.\rYes, the Tao. /Everything/ is a different appearance of the tao.\r -- Ken Tilton\r\r"Ken, I went to the library and read up on Buddhism, and believe me, you\rare no Buddhist."\r -- Kenny's mom\r%\rThat absolutely terrifies the herd-following, lockstep-marching,\rmainstream-saluting cowards that obediently dash out or online to\rscoop up books on The Latest Thing. They learn and use atrocities like\rJava, C++, XML, and even Python for the security it gives them and\rthen sit there slaving away miserably, tediously, joylously paying off\rmortgages and supporting ungrateful teenagers who despise them, only\rto look out the double-sealed thermo-pane windows of their\rcentral-heated, sound-proofed, dead-bolted, suffocating little nests\rinto the howling gale thinking "what do they know that I do not know?"\rwhen they see us under a lean-to hunched over our laptops to shield\rthem from the rain laughing our asses off as we write great code\rbetween bong hits.... what was the question?\r -- Ken Tilton\r%\rShut up! (That last phrase has four or more syllables if pronounced as\rintended.)\r -- Ken Tilton\r%\rNonsense. You'll be using it for the GUI, not protein-folding.\r -- Ken Tilton\r (responding to a comment that LTK was slow because it\r was based on TK)\r%\rContinuations certainly are clever, but if we learned anything from the\rrejection of the cover art for "Smell the Glove", it is that "there is a\rfine line between stupid... and clever".\r -- Ken Tilton\r%\rAh, there's no place like academia for dispassionate, intellectually\rhonest discussion of new ideas on their merits. Thank god for tenure\rgiving your bold antagonist the protection they needed to shout down\ryour iconoclastic..... hang on...\r -- Ken Tilton\r%\rWhoever objected must be in my killfile, ...\r -- Ken Tilton\r%\rFrom memory (but I think I have it right):\r\r"But Jesus said, Suffer captured variables, and forbid them not, to come\runto thine macro bodies: for of such is are DSLs made."\r -- Ken Tilton\r\rCan I get an Amen?\r%\rAwareness of defect is the first step to recovery.\r -- Ken Tilton\r%\rYou made a bad analogy (there are no good ones, but you found a new\rlow) ...\r -- Ken Tilton\r%\rYes, it is true that Kent Pitman was raised by a closet full of Lisp\rMachines, but the exception only proves the rule.\r -- Ken Tilton\r (in a postscript after positing that computer\r languages are not learned in infancy)\r%\rI suggest you try bartender's school to support yourself, start\rprogramming for fun again.\r -- Ken Tilton\r (responding to a comment that 98% of anything to do\r with computers was not interesting code)\r%\rYou could add four lanes to my carpal tunnel and I still could not\rwrite all the code I am dying to write.\r -- Ken Tilton\r%\rNeutrality? I want to bury other languages, not have a gateway to them.\r -- Ken Tilton\r%\rKen: "Cute puppy. Did you get it for companionship or to pick up chicks?"\rSimon: "Hunh? My puppy /always/ gives me companionship."\r -- Ken Tilton\r (on how he was understood by a native english speaker)\r%\r
\ No newline at end of file
--- /dev/null
+Programmers who lock onto a design decision and cling to it in the face of\r
+contradictory new information -- well, that's almost everyone in my\r
+experience, so I better not say what I think of them or people will start\r
+saying bad things about me on c.l.l.\r
+ -- Ken Tilton\r
+%\r
+This reminds me of the NYC cabby who accepted a fare to Chicago. When\r
+they got there and could not find the friend who was supposed to pay the\r
+fare he just laughed and said he should have known.\r
+ -- Ken Tilton\r
+%\r
+>> Actually, I believe that Aikido, Jazz and Lisp are different appearances\r
+>> of the same thing.\r
+Yes, the Tao. /Everything/ is a different appearance of the tao.\r
+ -- Ken Tilton\r
+\r
+"Ken, I went to the library and read up on Buddhism, and believe me, you\r
+are no Buddhist."\r
+ -- Kenny's mom\r
+%\r
+That absolutely terrifies the herd-following, lockstep-marching,\r
+mainstream-saluting cowards that obediently dash out or online to\r
+scoop up books on The Latest Thing. They learn and use atrocities like\r
+Java, C++, XML, and even Python for the security it gives them and\r
+then sit there slaving away miserably, tediously, joylously paying off\r
+mortgages and supporting ungrateful teenagers who despise them, only\r
+to look out the double-sealed thermo-pane windows of their\r
+central-heated, sound-proofed, dead-bolted, suffocating little nests\r
+into the howling gale thinking "what do they know that I do not know?"\r
+when they see us under a lean-to hunched over our laptops to shield\r
+them from the rain laughing our asses off as we write great code\r
+between bong hits.... what was the question?\r
+ -- Ken Tilton\r
+%\r
+Shut up! (That last phrase has four or more syllables if pronounced as\r
+intended.)\r
+ -- Ken Tilton\r
+%\r
+Nonsense. You'll be using it for the GUI, not protein-folding.\r
+ -- Ken Tilton\r
+ (responding to a comment that LTK was slow because it\r
+ was based on TK)\r
+%\r
+Continuations certainly are clever, but if we learned anything from the\r
+rejection of the cover art for "Smell the Glove", it is that "there is a\r
+fine line between stupid... and clever".\r
+ -- Ken Tilton\r
+%\r
+Ah, there's no place like academia for dispassionate, intellectually\r
+honest discussion of new ideas on their merits. Thank god for tenure\r
+giving your bold antagonist the protection they needed to shout down\r
+your iconoclastic..... hang on...\r
+ -- Ken Tilton\r
+%\r
+Whoever objected must be in my killfile, ...\r
+ -- Ken Tilton\r
+%\r
+From memory (but I think I have it right):\r
+\r
+"But Jesus said, Suffer captured variables, and forbid them not, to come\r
+unto thine macro bodies: for of such is are DSLs made."\r
+ -- Ken Tilton\r
+\r
+Can I get an Amen?\r
+%\r
+Awareness of defect is the first step to recovery.\r
+ -- Ken Tilton\r
+%\r
+You made a bad analogy (there are no good ones, but you found a new\r
+low) ...\r
+ -- Ken Tilton\r
+%\r
+Yes, it is true that Kent Pitman was raised by a closet full of Lisp\r
+Machines, but the exception only proves the rule.\r
+ -- Ken Tilton\r
+ (in a postscript after positing that computer\r
+ languages are not learned in infancy)\r
+%\r
+I suggest you try bartender's school to support yourself, start\r
+programming for fun again.\r
+ -- Ken Tilton\r
+ (responding to a comment that 98% of anything to do\r
+ with computers was not interesting code)\r
+%\r
+You could add four lanes to my carpal tunnel and I still could not\r
+write all the code I am dying to write.\r
+ -- Ken Tilton\r
+%\r
+Neutrality? I want to bury other languages, not have a gateway to them.\r
+ -- Ken Tilton\r
+%\r
+Ken: "Cute puppy. Did you get it for companionship or to pick up chicks?"\r
+Simon: "Hunh? My puppy /always/ gives me companionship."\r
+ -- Ken Tilton\r
+ (on how he was understood by a native english speaker)\r
+%\r
--- /dev/null
+Programmers who lock onto a design decision and cling to it in the face of
+contradictory new information -- well, that's almost everyone in my
+experience, so I better not say what I think of them or people will start
+saying bad things about me on c.l.l.
+ -- Ken Tilton
+%
+This reminds me of the NYC cabby who accepted a fare to Chicago. When
+they got there and could not find the friend who was supposed to pay the
+fare he just laughed and said he should have known.
+ -- Ken Tilton
+%
+>> Actually, I believe that Aikido, Jazz and Lisp are different appearances
+>> of the same thing.
+Yes, the Tao. /Everything/ is a different appearance of the tao.
+ -- Ken Tilton
+
+"Ken, I went to the library and read up on Buddhism, and believe me, you
+are no Buddhist."
+ -- Kenny's mom
+%
+That absolutely terrifies the herd-following, lockstep-marching,
+mainstream-saluting cowards that obediently dash out or online to
+scoop up books on The Latest Thing. They learn and use atrocities like
+Java, C++, XML, and even Python for the security it gives them and
+then sit there slaving away miserably, tediously, joylously paying off
+mortgages and supporting ungrateful teenagers who despise them, only
+to look out the double-sealed thermo-pane windows of their
+central-heated, sound-proofed, dead-bolted, suffocating little nests
+into the howling gale thinking "what do they know that I do not know?"
+when they see us under a lean-to hunched over our laptops to shield
+them from the rain laughing our asses off as we write great code
+between bong hits.... what was the question?
+ -- Ken Tilton
+%
+Shut up! (That last phrase has four or more syllables if pronounced as
+intended.)
+ -- Ken Tilton
+%
+Nonsense. You'll be using it for the GUI, not protein-folding.
+ -- Ken Tilton
+ (responding to a comment that LTK was slow because it
+ was based on TK)
+%
+Continuations certainly are clever, but if we learned anything from the
+rejection of the cover art for "Smell the Glove", it is that "there is a
+fine line between stupid... and clever".
+ -- Ken Tilton
+%
+Ah, there's no place like academia for dispassionate, intellectually
+honest discussion of new ideas on their merits. Thank god for tenure
+giving your bold antagonist the protection they needed to shout down
+your iconoclastic..... hang on...
+ -- Ken Tilton
+%
+Whoever objected must be in my killfile, ...
+ -- Ken Tilton
+%
+From memory (but I think I have it right):
+
+"But Jesus said, Suffer captured variables, and forbid them not, to come
+unto thine macro bodies: for of such is are DSLs made."
+ -- Ken Tilton
+
+Can I get an Amen?
+%
+Awareness of defect is the first step to recovery.
+ -- Ken Tilton
+%
+You made a bad analogy (there are no good ones, but you found a new
+low) ...
+ -- Ken Tilton
+%
+Yes, it is true that Kent Pitman was raised by a closet full of Lisp
+Machines, but the exception only proves the rule.
+ -- Ken Tilton
+ (in a postscript after positing that computer
+ languages are not learned in infancy)
+%
+I suggest you try bartender's school to support yourself, start
+programming for fun again.
+ -- Ken Tilton
+ (responding to a comment that 98% of anything to do
+ with computers was not interesting code)
+%
+You could add four lanes to my carpal tunnel and I still could not
+write all the code I am dying to write.
+ -- Ken Tilton
+%
+Neutrality? I want to bury other languages, not have a gateway to them.
+ -- Ken Tilton
+%
+Ken: "Cute puppy. Did you get it for companionship or to pick up chicks?"
+Simon: "Hunh? My puppy /always/ gives me companionship."
+ -- Ken Tilton
+ (on how he was understood by a native english speaker)
+%
--- /dev/null
+Programmers who lock onto a design decision and cling to it in the face of\rcontradictory new information -- well, that's almost everyone in my\rexperience, so I better not say what I think of them or people will start\rsaying bad things about me on c.l.l.\r -- Ken Tilton\r%\rThis reminds me of the NYC cabby who accepted a fare to Chicago. When\rthey got there and could not find the friend who was supposed to pay the\rfare he just laughed and said he should have known.\r -- Ken Tilton\r%\r>> Actually, I believe that Aikido, Jazz and Lisp are different appearances\r>> of the same thing.\rYes, the Tao. /Everything/ is a different appearance of the tao.\r -- Ken Tilton\r\r"Ken, I went to the library and read up on Buddhism, and believe me, you\rare no Buddhist."\r -- Kenny's mom\r%\rThat absolutely terrifies the herd-following, lockstep-marching,\rmainstream-saluting cowards that obediently dash out or online to\rscoop up books on The Latest Thing. They learn and use atrocities like\rJava, C++, XML, and even Python for the security it gives them and\rthen sit there slaving away miserably, tediously, joylously paying off\rmortgages and supporting ungrateful teenagers who despise them, only\rto look out the double-sealed thermo-pane windows of their\rcentral-heated, sound-proofed, dead-bolted, suffocating little nests\rinto the howling gale thinking "what do they know that I do not know?"\rwhen they see us under a lean-to hunched over our laptops to shield\rthem from the rain laughing our asses off as we write great code\rbetween bong hits.... what was the question?\r -- Ken Tilton\r%\rShut up! (That last phrase has four or more syllables if pronounced as\rintended.)\r -- Ken Tilton\r%\rNonsense. You'll be using it for the GUI, not protein-folding.\r -- Ken Tilton\r (responding to a comment that LTK was slow because it\r was based on TK)\r%\rContinuations certainly are clever, but if we learned anything from the\rrejection of the cover art for "Smell the Glove", it is that "there is a\rfine line between stupid... and clever".\r -- Ken Tilton\r%\rAh, there's no place like academia for dispassionate, intellectually\rhonest discussion of new ideas on their merits. Thank god for tenure\rgiving your bold antagonist the protection they needed to shout down\ryour iconoclastic..... hang on...\r -- Ken Tilton\r%\rWhoever objected must be in my killfile, ...\r -- Ken Tilton\r%\rFrom memory (but I think I have it right):\r\r"But Jesus said, Suffer captured variables, and forbid them not, to come\runto thine macro bodies: for of such is are DSLs made."\r -- Ken Tilton\r\rCan I get an Amen?\r%\rAwareness of defect is the first step to recovery.\r -- Ken Tilton\r%\rYou made a bad analogy (there are no good ones, but you found a new\rlow) ...\r -- Ken Tilton\r%\rYes, it is true that Kent Pitman was raised by a closet full of Lisp\rMachines, but the exception only proves the rule.\r -- Ken Tilton\r (in a postscript after positing that computer\r languages are not learned in infancy)\r%\rI suggest you try bartender's school to support yourself, start\rprogramming for fun again.\r -- Ken Tilton\r (responding to a comment that 98% of anything to do\r with computers was not interesting code)\r%\rYou could add four lanes to my carpal tunnel and I still could not\rwrite all the code I am dying to write.\r -- Ken Tilton\r%\rNeutrality? I want to bury other languages, not have a gateway to them.\r -- Ken Tilton\r%\rKen: "Cute puppy. Did you get it for companionship or to pick up chicks?"\rSimon: "Hunh? My puppy /always/ gives me companionship."\r -- Ken Tilton\r (on how he was understood by a native english speaker)\r%\r
\ No newline at end of file
--- /dev/null
+Programmers who lock onto a design decision and cling to it in the face of\r
+contradictory new information -- well, that's almost everyone in my\r
+experience, so I better not say what I think of them or people will start\r
+saying bad things about me on c.l.l.\r
+ -- Ken Tilton\r
+%\r
+This reminds me of the NYC cabby who accepted a fare to Chicago. When\r
+they got there and could not find the friend who was supposed to pay the\r
+fare he just laughed and said he should have known.\r
+ -- Ken Tilton\r
+%\r
+>> Actually, I believe that Aikido, Jazz and Lisp are different appearances\r
+>> of the same thing.\r
+Yes, the Tao. /Everything/ is a different appearance of the tao.\r
+ -- Ken Tilton\r
+\r
+"Ken, I went to the library and read up on Buddhism, and believe me, you\r
+are no Buddhist."\r
+ -- Kenny's mom\r
+%\r
+That absolutely terrifies the herd-following, lockstep-marching,\r
+mainstream-saluting cowards that obediently dash out or online to\r
+scoop up books on The Latest Thing. They learn and use atrocities like\r
+Java, C++, XML, and even Python for the security it gives them and\r
+then sit there slaving away miserably, tediously, joylously paying off\r
+mortgages and supporting ungrateful teenagers who despise them, only\r
+to look out the double-sealed thermo-pane windows of their\r
+central-heated, sound-proofed, dead-bolted, suffocating little nests\r
+into the howling gale thinking "what do they know that I do not know?"\r
+when they see us under a lean-to hunched over our laptops to shield\r
+them from the rain laughing our asses off as we write great code\r
+between bong hits.... what was the question?\r
+ -- Ken Tilton\r
+%\r
+Shut up! (That last phrase has four or more syllables if pronounced as\r
+intended.)\r
+ -- Ken Tilton\r
+%\r
+Nonsense. You'll be using it for the GUI, not protein-folding.\r
+ -- Ken Tilton\r
+ (responding to a comment that LTK was slow because it\r
+ was based on TK)\r
+%\r
+Continuations certainly are clever, but if we learned anything from the\r
+rejection of the cover art for "Smell the Glove", it is that "there is a\r
+fine line between stupid... and clever".\r
+ -- Ken Tilton\r
+%\r
+Ah, there's no place like academia for dispassionate, intellectually\r
+honest discussion of new ideas on their merits. Thank god for tenure\r
+giving your bold antagonist the protection they needed to shout down\r
+your iconoclastic..... hang on...\r
+ -- Ken Tilton\r
+%\r
+Whoever objected must be in my killfile, ...\r
+ -- Ken Tilton\r
+%\r
+From memory (but I think I have it right):\r
+\r
+"But Jesus said, Suffer captured variables, and forbid them not, to come\r
+unto thine macro bodies: for of such is are DSLs made."\r
+ -- Ken Tilton\r
+\r
+Can I get an Amen?\r
+%\r
+Awareness of defect is the first step to recovery.\r
+ -- Ken Tilton\r
+%\r
+You made a bad analogy (there are no good ones, but you found a new\r
+low) ...\r
+ -- Ken Tilton\r
+%\r
+Yes, it is true that Kent Pitman was raised by a closet full of Lisp\r
+Machines, but the exception only proves the rule.\r
+ -- Ken Tilton\r
+ (in a postscript after positing that computer\r
+ languages are not learned in infancy)\r
+%\r
+I suggest you try bartender's school to support yourself, start\r
+programming for fun again.\r
+ -- Ken Tilton\r
+ (responding to a comment that 98% of anything to do\r
+ with computers was not interesting code)\r
+%\r
+You could add four lanes to my carpal tunnel and I still could not\r
+write all the code I am dying to write.\r
+ -- Ken Tilton\r
+%\r
+Neutrality? I want to bury other languages, not have a gateway to them.\r
+ -- Ken Tilton\r
+%\r
+Ken: "Cute puppy. Did you get it for companionship or to pick up chicks?"\r
+Simon: "Hunh? My puppy /always/ gives me companionship."\r
+ -- Ken Tilton\r
+ (on how he was understood by a native english speaker)\r
+%\r
--- /dev/null
+Programmers who lock onto a design decision and cling to it in the face of
+contradictory new information -- well, that's almost everyone in my
+experience, so I better not say what I think of them or people will start
+saying bad things about me on c.l.l.
+ -- Ken Tilton
+%
+This reminds me of the NYC cabby who accepted a fare to Chicago. When
+they got there and could not find the friend who was supposed to pay the
+fare he just laughed and said he should have known.
+ -- Ken Tilton
+%
+>> Actually, I believe that Aikido, Jazz and Lisp are different appearances
+>> of the same thing.
+Yes, the Tao. /Everything/ is a different appearance of the tao.
+ -- Ken Tilton
+
+"Ken, I went to the library and read up on Buddhism, and believe me, you
+are no Buddhist."
+ -- Kenny's mom
+%
+That absolutely terrifies the herd-following, lockstep-marching,
+mainstream-saluting cowards that obediently dash out or online to
+scoop up books on The Latest Thing. They learn and use atrocities like
+Java, C++, XML, and even Python for the security it gives them and
+then sit there slaving away miserably, tediously, joylously paying off
+mortgages and supporting ungrateful teenagers who despise them, only
+to look out the double-sealed thermo-pane windows of their
+central-heated, sound-proofed, dead-bolted, suffocating little nests
+into the howling gale thinking "what do they know that I do not know?"
+when they see us under a lean-to hunched over our laptops to shield
+them from the rain laughing our asses off as we write great code
+between bong hits.... what was the question?
+ -- Ken Tilton
+%
+Shut up! (That last phrase has four or more syllables if pronounced as
+intended.)
+ -- Ken Tilton
+%
+Nonsense. You'll be using it for the GUI, not protein-folding.
+ -- Ken Tilton
+ (responding to a comment that LTK was slow because it
+ was based on TK)
+%
+Continuations certainly are clever, but if we learned anything from the
+rejection of the cover art for "Smell the Glove", it is that "there is a
+fine line between stupid... and clever".
+ -- Ken Tilton
+%
+Ah, there's no place like academia for dispassionate, intellectually
+honest discussion of new ideas on their merits. Thank god for tenure
+giving your bold antagonist the protection they needed to shout down
+your iconoclastic..... hang on...
+ -- Ken Tilton
+%
+Whoever objected must be in my killfile, ...
+ -- Ken Tilton
+%
+From memory (but I think I have it right):
+
+"But Jesus said, Suffer captured variables, and forbid them not, to come
+unto thine macro bodies: for of such is are DSLs made."
+ -- Ken Tilton
+
+Can I get an Amen?
+%
+Awareness of defect is the first step to recovery.
+ -- Ken Tilton
+%
+You made a bad analogy (there are no good ones, but you found a new
+low) ...
+ -- Ken Tilton
+%
+Yes, it is true that Kent Pitman was raised by a closet full of Lisp
+Machines, but the exception only proves the rule.
+ -- Ken Tilton
+ (in a postscript after positing that computer
+ languages are not learned in infancy)
+%
+I suggest you try bartender's school to support yourself, start
+programming for fun again.
+ -- Ken Tilton
+ (responding to a comment that 98% of anything to do
+ with computers was not interesting code)
+%
+You could add four lanes to my carpal tunnel and I still could not
+write all the code I am dying to write.
+ -- Ken Tilton
+%
+Neutrality? I want to bury other languages, not have a gateway to them.
+ -- Ken Tilton
+%
+Ken: "Cute puppy. Did you get it for companionship or to pick up chicks?"
+Simon: "Hunh? My puppy /always/ gives me companionship."
+ -- Ken Tilton
+ (on how he was understood by a native english speaker)
+%
--- /dev/null
+\rUTF-8 encoded sample plain-text file\r‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾\r\rMarkus Kuhn [ˈmaʳkʊs kuːn] <http://www.cl.cam.ac.uk/~mgk25/> — 2002-07-25\r\r\rThe ASCII compatible UTF-8 encoding used in this plain-text file\ris defined in Unicode, ISO 10646-1, and RFC 2279.\r\r\rUsing Unicode/UTF-8, you can write in emails and source code things such as\r\rMathematics and sciences:\r\r ∮ E⋅da = Q, n → ∞, ∑ f(i) = ∏ g(i), ⎧⎡⎛┌─────┐⎞⎤⎫\r ⎪⎢⎜│a²+b³ ⎟⎥⎪\r ∀x∈ℝ: ⌈x⌉ = −⌊−x⌋, α ∧ ¬β = ¬(¬α ∨ β), ⎪⎢⎜│───── ⎟⎥⎪\r ⎪⎢⎜⎷ c₈ ⎟⎥⎪\r ℕ ⊆ ℕ₀ ⊂ ℤ ⊂ ℚ ⊂ ℝ ⊂ ℂ, ⎨⎢⎜ ⎟⎥⎬\r ⎪⎢⎜ ∞ ⎟⎥⎪\r ⊥ < a ≠ b ≡ c ≤ d ≪ ⊤ ⇒ (⟦A⟧ ⇔ ⟪B⟫), ⎪⎢⎜ ⎲ ⎟⎥⎪\r ⎪⎢⎜ ⎳aⁱ-bⁱ⎟⎥⎪\r 2H₂ + O₂ ⇌ 2H₂O, R = 4.7 kΩ, ⌀ 200 mm ⎩⎣⎝i=1 ⎠⎦⎭\r\rLinguistics and dictionaries:\r\r ði ıntəˈnæʃənəl fəˈnɛtık əsoʊsiˈeıʃn\r Y [ˈʏpsilɔn], Yen [jɛn], Yoga [ˈjoːgɑ]\r\rAPL:\r\r ((V⍳V)=⍳⍴V)/V←,V ⌷←⍳→⍴∆∇⊃‾⍎⍕⌈\r\rNicer typography in plain text files:\r\r ╔══════════════════════════════════════════╗\r ║ ║\r ║ • ‘single’ and “double” quotes ║\r ║ ║\r ║ • Curly apostrophes: “We’ve been here” ║\r ║ ║\r ║ • Latin-1 apostrophe and accents: '´` ║\r ║ ║\r ║ • ‚deutsche‘ „Anführungszeichen“ ║\r ║ ║\r ║ • †, ‡, ‰, •, 3–4, —, −5/+5, ™, … ║\r ║ ║\r ║ • ASCII safety test: 1lI|, 0OD, 8B ║\r ║ ╭─────────╮ ║\r ║ • the euro symbol: │ 14.95 € │ ║\r ║ ╰─────────╯ ║\r ╚══════════════════════════════════════════╝\r\rCombining characters:\r\r STARGΛ̊TE SG-1, a = v̇ = r̈, a⃑ ⊥ b⃑\r\rGreek (in Polytonic):\r\r The Greek anthem:\r\r Σὲ γνωρίζω ἀπὸ τὴν κόψη\r τοῦ σπαθιοῦ τὴν τρομερή,\r σὲ γνωρίζω ἀπὸ τὴν ὄψη\r ποὺ μὲ βία μετράει τὴ γῆ.\r\r ᾿Απ᾿ τὰ κόκκαλα βγαλμένη\r τῶν ῾Ελλήνων τὰ ἱερά\r καὶ σὰν πρῶτα ἀνδρειωμένη\r χαῖρε, ὦ χαῖρε, ᾿Ελευθεριά!\r\r From a speech of Demosthenes in the 4th century BC:\r\r Οὐχὶ ταὐτὰ παρίσταταί μοι γιγνώσκειν, ὦ ἄνδρες ᾿Αθηναῖοι,\r ὅταν τ᾿ εἰς τὰ πράγματα ἀποβλέψω καὶ ὅταν πρὸς τοὺς\r λόγους οὓς ἀκούω· τοὺς μὲν γὰρ λόγους περὶ τοῦ\r τιμωρήσασθαι Φίλιππον ὁρῶ γιγνομένους, τὰ δὲ πράγματ᾿\r εἰς τοῦτο προήκοντα, ὥσθ᾿ ὅπως μὴ πεισόμεθ᾿ αὐτοὶ\r πρότερον κακῶς σκέψασθαι δέον. οὐδέν οὖν ἄλλο μοι δοκοῦσιν\r οἱ τὰ τοιαῦτα λέγοντες ἢ τὴν ὑπόθεσιν, περὶ ἧς βουλεύεσθαι,\r οὐχὶ τὴν οὖσαν παριστάντες ὑμῖν ἁμαρτάνειν. ἐγὼ δέ, ὅτι μέν\r ποτ᾿ ἐξῆν τῇ πόλει καὶ τὰ αὑτῆς ἔχειν ἀσφαλῶς καὶ Φίλιππον\r τιμωρήσασθαι, καὶ μάλ᾿ ἀκριβῶς οἶδα· ἐπ᾿ ἐμοῦ γάρ, οὐ πάλαι\r γέγονεν ταῦτ᾿ ἀμφότερα· νῦν μέντοι πέπεισμαι τοῦθ᾿ ἱκανὸν\r προλαβεῖν ἡμῖν εἶναι τὴν πρώτην, ὅπως τοὺς συμμάχους\r σώσομεν. ἐὰν γὰρ τοῦτο βεβαίως ὑπάρξῃ, τότε καὶ περὶ τοῦ\r τίνα τιμωρήσεταί τις καὶ ὃν τρόπον ἐξέσται σκοπεῖν· πρὶν δὲ\r τὴν ἀρχὴν ὀρθῶς ὑποθέσθαι, μάταιον ἡγοῦμαι περὶ τῆς\r τελευτῆς ὁντινοῦν ποιεῖσθαι λόγον.\r\r Δημοσθένους, Γ´ ᾿Ολυνθιακὸς\r\rGeorgian:\r\r From a Unicode conference invitation:\r\r გთხოვთ ახლავე გაიაროთ რეგისტრაცია Unicode-ის მეათე საერთაშორისო\r კონფერენციაზე დასასწრებად, რომელიც გაიმართება 10-12 მარტს,\r ქ. მაინცში, გერმანიაში. კონფერენცია შეჰკრებს ერთად მსოფლიოს\r ექსპერტებს ისეთ დარგებში როგორიცაა ინტერნეტი და Unicode-ი,\r ინტერნაციონალიზაცია და ლოკალიზაცია, Unicode-ის გამოყენება\r ოპერაციულ სისტემებსა, და გამოყენებით პროგრამებში, შრიფტებში,\r ტექსტების დამუშავებასა და მრავალენოვან კომპიუტერულ სისტემებში.\r\rRussian:\r\r From a Unicode conference invitation:\r\r Зарегистрируйтесь сейчас на Десятую Международную Конференцию по\r Unicode, которая состоится 10-12 марта 1997 года в Майнце в Германии.\r Конференция соберет широкий круг экспертов по вопросам глобального\r Интернета и Unicode, локализации и интернационализации, воплощению и\r применению Unicode в различных операционных системах и программных\r приложениях, шрифтах, верстке и многоязычных компьютерных системах.\r\rThai (UCS Level 2):\r\r Excerpt from a poetry on The Romance of The Three Kingdoms (a Chinese\r classic 'San Gua'):\r\r [----------------------------|------------------------]\r ๏ แผ่นดินฮั่นเสื่อมโทรมแสนสังเวช พระปกเกศกองบู๊กู้ขึ้นใหม่\r สิบสองกษัตริย์ก่อนหน้าแลถัดไป สององค์ไซร้โง่เขลาเบาปัญญา\r ทรงนับถือขันทีเป็นที่พึ่ง บ้านเมืองจึงวิปริตเป็นนักหนา\r โฮจิ๋นเรียกทัพทั่วหัวเมืองมา หมายจะฆ่ามดชั่วตัวสำคัญ\r เหมือนขับไสไล่เสือจากเคหา รับหมาป่าเข้ามาเลยอาสัญ\r ฝ่ายอ้องอุ้นยุแยกให้แตกกัน ใช้สาวนั้นเป็นชนวนชื่นชวนใจ\r พลันลิฉุยกุยกีกลับก่อเหตุ ช่างอาเพศจริงหนาฟ้าร้องไห้\r ต้องรบราฆ่าฟันจนบรรลัย ฤๅหาใครค้ำชูกู้บรรลังก์ ฯ\r\r (The above is a two-column text. If combining characters are handled\r correctly, the lines of the second column should be aligned with the\r | character above.)\r\rEthiopian:\r\r Proverbs in the Amharic language:\r\r ሰማይ አይታረስ ንጉሥ አይከሰስ።\r ብላ ካለኝ እንደአባቴ በቆመጠኝ።\r ጌጥ ያለቤቱ ቁምጥና ነው።\r ደሀ በሕልሙ ቅቤ ባይጠጣ ንጣት በገደለው።\r የአፍ ወለምታ በቅቤ አይታሽም።\r አይጥ በበላ ዳዋ ተመታ።\r ሲተረጉሙ ይደረግሙ።\r ቀስ በቀስ፥ ዕንቁላል በእግሩ ይሄዳል።\r ድር ቢያብር አንበሳ ያስር።\r ሰው እንደቤቱ እንጅ እንደ ጉረቤቱ አይተዳደርም።\r እግዜር የከፈተውን ጉሮሮ ሳይዘጋው አይድርም።\r የጎረቤት ሌባ፥ ቢያዩት ይስቅ ባያዩት ያጠልቅ።\r ሥራ ከመፍታት ልጄን ላፋታት።\r ዓባይ ማደሪያ የለው፥ ግንድ ይዞ ይዞራል።\r የእስላም አገሩ መካ የአሞራ አገሩ ዋርካ።\r ተንጋሎ ቢተፉ ተመልሶ ባፉ።\r ወዳጅህ ማር ቢሆን ጨርስህ አትላሰው።\r እግርህን በፍራሽህ ልክ ዘርጋ።\r\rRunes:\r\r ᚻᛖ ᚳᚹᚫᚦ ᚦᚫᛏ ᚻᛖ ᛒᚢᛞᛖ ᚩᚾ ᚦᚫᛗ ᛚᚪᚾᛞᛖ ᚾᚩᚱᚦᚹᛖᚪᚱᛞᚢᛗ ᚹᛁᚦ ᚦᚪ ᚹᛖᛥᚫ\r\r (Old English, which transcribed into Latin reads 'He cwaeth that he\r bude thaem lande northweardum with tha Westsae.' and means 'He said\r that he lived in the northern land near the Western Sea.')\r\rBraille:\r\r ⡌⠁⠧⠑ ⠼⠁⠒ ⡍⠜⠇⠑⠹⠰⠎ ⡣⠕⠌\r\r ⡍⠜⠇⠑⠹ ⠺⠁⠎ ⠙⠑⠁⠙⠒ ⠞⠕ ⠃⠑⠛⠔ ⠺⠊⠹⠲ ⡹⠻⠑ ⠊⠎ ⠝⠕ ⠙⠳⠃⠞\r ⠱⠁⠞⠑⠧⠻ ⠁⠃⠳⠞ ⠹⠁⠞⠲ ⡹⠑ ⠗⠑⠛⠊⠌⠻ ⠕⠋ ⠙⠊⠎ ⠃⠥⠗⠊⠁⠇ ⠺⠁⠎\r ⠎⠊⠛⠝⠫ ⠃⠹ ⠹⠑ ⠊⠇⠻⠛⠹⠍⠁⠝⠂ ⠹⠑ ⠊⠇⠻⠅⠂ ⠹⠑ ⠥⠝⠙⠻⠞⠁⠅⠻⠂\r ⠁⠝⠙ ⠹⠑ ⠡⠊⠑⠋ ⠍⠳⠗⠝⠻⠲ ⡎⠊⠗⠕⠕⠛⠑ ⠎⠊⠛⠝⠫ ⠊⠞⠲ ⡁⠝⠙\r ⡎⠊⠗⠕⠕⠛⠑⠰⠎ ⠝⠁⠍⠑ ⠺⠁⠎ ⠛⠕⠕⠙ ⠥⠏⠕⠝ ⠰⡡⠁⠝⠛⠑⠂ ⠋⠕⠗ ⠁⠝⠹⠹⠔⠛ ⠙⠑\r ⠡⠕⠎⠑ ⠞⠕ ⠏⠥⠞ ⠙⠊⠎ ⠙⠁⠝⠙ ⠞⠕⠲\r\r ⡕⠇⠙ ⡍⠜⠇⠑⠹ ⠺⠁⠎ ⠁⠎ ⠙⠑⠁⠙ ⠁⠎ ⠁ ⠙⠕⠕⠗⠤⠝⠁⠊⠇⠲\r\r ⡍⠔⠙⠖ ⡊ ⠙⠕⠝⠰⠞ ⠍⠑⠁⠝ ⠞⠕ ⠎⠁⠹ ⠹⠁⠞ ⡊ ⠅⠝⠪⠂ ⠕⠋ ⠍⠹\r ⠪⠝ ⠅⠝⠪⠇⠫⠛⠑⠂ ⠱⠁⠞ ⠹⠻⠑ ⠊⠎ ⠏⠜⠞⠊⠊⠥⠇⠜⠇⠹ ⠙⠑⠁⠙ ⠁⠃⠳⠞\r ⠁ ⠙⠕⠕⠗⠤⠝⠁⠊⠇⠲ ⡊ ⠍⠊⠣⠞ ⠙⠁⠧⠑ ⠃⠑⠲ ⠔⠊⠇⠔⠫⠂ ⠍⠹⠎⠑⠇⠋⠂ ⠞⠕\r ⠗⠑⠛⠜⠙ ⠁ ⠊⠕⠋⠋⠔⠤⠝⠁⠊⠇ ⠁⠎ ⠹⠑ ⠙⠑⠁⠙⠑⠌ ⠏⠊⠑⠊⠑ ⠕⠋ ⠊⠗⠕⠝⠍⠕⠝⠛⠻⠹\r ⠔ ⠹⠑ ⠞⠗⠁⠙⠑⠲ ⡃⠥⠞ ⠹⠑ ⠺⠊⠎⠙⠕⠍ ⠕⠋ ⠳⠗ ⠁⠝⠊⠑⠌⠕⠗⠎\r ⠊⠎ ⠔ ⠹⠑ ⠎⠊⠍⠊⠇⠑⠆ ⠁⠝⠙ ⠍⠹ ⠥⠝⠙⠁⠇⠇⠪⠫ ⠙⠁⠝⠙⠎\r ⠩⠁⠇⠇ ⠝⠕⠞ ⠙⠊⠌⠥⠗⠃ ⠊⠞⠂ ⠕⠗ ⠹⠑ ⡊⠳⠝⠞⠗⠹⠰⠎ ⠙⠕⠝⠑ ⠋⠕⠗⠲ ⡹⠳\r ⠺⠊⠇⠇ ⠹⠻⠑⠋⠕⠗⠑ ⠏⠻⠍⠊⠞ ⠍⠑ ⠞⠕ ⠗⠑⠏⠑⠁⠞⠂ ⠑⠍⠏⠙⠁⠞⠊⠊⠁⠇⠇⠹⠂ ⠹⠁⠞\r ⡍⠜⠇⠑⠹ ⠺⠁⠎ ⠁⠎ ⠙⠑⠁⠙ ⠁⠎ ⠁ ⠙⠕⠕⠗⠤⠝⠁⠊⠇⠲\r\r (The first couple of paragraphs of "A Christmas Carol" by Dickens)\r\rCompact font selection example text:\r\r ABCDEFGHIJKLMNOPQRSTUVWXYZ /0123456789\r abcdefghijklmnopqrstuvwxyz £©µÀÆÖÞßéöÿ\r –—‘“”„†•…‰™œŠŸž€ ΑΒΓΔΩαβγδω АБВГДабвгд\r ∀∂∈ℝ∧∪≡∞ ↑↗↨↻⇣ ┐┼╔╘░►☺♀ fi�⑀₂ἠḂӥẄɐː⍎אԱა\r\rGreetings in various languages:\r\r Hello world, Καλημέρα κόσμε, コンニチハ\r\rBox drawing alignment tests: █\r ▉\r ╔══╦══╗ ┌──┬──┐ ╭──┬──╮ ╭──┬──╮ ┏━━┳━━┓ ┎┒┏┑ ╷ ╻ ┏┯┓ ┌┰┐ ▊ ╱╲╱╲╳╳╳\r ║┌─╨─┐║ │╔═╧═╗│ │╒═╪═╕│ │╓─╁─╖│ ┃┌─╂─┐┃ ┗╃╄┙ ╶┼╴╺╋╸┠┼┨ ┝╋┥ ▋ ╲╱╲╱╳╳╳\r ║│╲ ╱│║ │║ ║│ ││ │ ││ │║ ┃ ║│ ┃│ ╿ │┃ ┍╅╆┓ ╵ ╹ ┗┷┛ └┸┘ ▌ ╱╲╱╲╳╳╳\r ╠╡ ╳ ╞╣ ├╢ ╟┤ ├┼─┼─┼┤ ├╫─╂─╫┤ ┣┿╾┼╼┿┫ ┕┛┖┚ ┌┄┄┐ ╎ ┏┅┅┓ ┋ ▍ ╲╱╲╱╳╳╳\r ║│╱ ╲│║ │║ ║│ ││ │ ││ │║ ┃ ║│ ┃│ ╽ │┃ ░░▒▒▓▓██ ┊ ┆ ╎ ╏ ┇ ┋ ▎\r ║└─╥─┘║ │╚═╤═╝│ │╘═╪═╛│ │╙─╀─╜│ ┃└─╂─┘┃ ░░▒▒▓▓██ ┊ ┆ ╎ ╏ ┇ ┋ ▏\r ╚══╩══╝ └──┴──┘ ╰──┴──╯ ╰──┴──╯ ┗━━┻━━┛ ▗▄▖▛▀▜ └╌╌┘ ╎ ┗╍╍┛ ┋ ▁▂▃▄▅▆▇█\r ▝▀▘▙▄▟\r
\ No newline at end of file
--- /dev/null
+\r
+UTF-8 encoded sample plain-text file\r
+‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾\r
+\r
+Markus Kuhn [ˈmaʳkʊs kuːn] <http://www.cl.cam.ac.uk/~mgk25/> — 2002-07-25\r
+\r
+\r
+The ASCII compatible UTF-8 encoding used in this plain-text file\r
+is defined in Unicode, ISO 10646-1, and RFC 2279.\r
+\r
+\r
+Using Unicode/UTF-8, you can write in emails and source code things such as\r
+\r
+Mathematics and sciences:\r
+\r
+ ∮ E⋅da = Q, n → ∞, ∑ f(i) = ∏ g(i), ⎧⎡⎛┌─────┐⎞⎤⎫\r
+ ⎪⎢⎜│a²+b³ ⎟⎥⎪\r
+ ∀x∈ℝ: ⌈x⌉ = −⌊−x⌋, α ∧ ¬β = ¬(¬α ∨ β), ⎪⎢⎜│───── ⎟⎥⎪\r
+ ⎪⎢⎜⎷ c₈ ⎟⎥⎪\r
+ ℕ ⊆ ℕ₀ ⊂ ℤ ⊂ ℚ ⊂ ℝ ⊂ ℂ, ⎨⎢⎜ ⎟⎥⎬\r
+ ⎪⎢⎜ ∞ ⎟⎥⎪\r
+ ⊥ < a ≠ b ≡ c ≤ d ≪ ⊤ ⇒ (⟦A⟧ ⇔ ⟪B⟫), ⎪⎢⎜ ⎲ ⎟⎥⎪\r
+ ⎪⎢⎜ ⎳aⁱ-bⁱ⎟⎥⎪\r
+ 2H₂ + O₂ ⇌ 2H₂O, R = 4.7 kΩ, ⌀ 200 mm ⎩⎣⎝i=1 ⎠⎦⎭\r
+\r
+Linguistics and dictionaries:\r
+\r
+ ði ıntəˈnæʃənəl fəˈnɛtık əsoʊsiˈeıʃn\r
+ Y [ˈʏpsilɔn], Yen [jɛn], Yoga [ˈjoːgɑ]\r
+\r
+APL:\r
+\r
+ ((V⍳V)=⍳⍴V)/V←,V ⌷←⍳→⍴∆∇⊃‾⍎⍕⌈\r
+\r
+Nicer typography in plain text files:\r
+\r
+ ╔══════════════════════════════════════════╗\r
+ ║ ║\r
+ ║ • ‘single’ and “double” quotes ║\r
+ ║ ║\r
+ ║ • Curly apostrophes: “We’ve been here” ║\r
+ ║ ║\r
+ ║ • Latin-1 apostrophe and accents: '´` ║\r
+ ║ ║\r
+ ║ • ‚deutsche‘ „Anführungszeichen“ ║\r
+ ║ ║\r
+ ║ • †, ‡, ‰, •, 3–4, —, −5/+5, ™, … ║\r
+ ║ ║\r
+ ║ • ASCII safety test: 1lI|, 0OD, 8B ║\r
+ ║ ╭─────────╮ ║\r
+ ║ • the euro symbol: │ 14.95 € │ ║\r
+ ║ ╰─────────╯ ║\r
+ ╚══════════════════════════════════════════╝\r
+\r
+Combining characters:\r
+\r
+ STARGΛ̊TE SG-1, a = v̇ = r̈, a⃑ ⊥ b⃑\r
+\r
+Greek (in Polytonic):\r
+\r
+ The Greek anthem:\r
+\r
+ Σὲ γνωρίζω ἀπὸ τὴν κόψη\r
+ τοῦ σπαθιοῦ τὴν τρομερή,\r
+ σὲ γνωρίζω ἀπὸ τὴν ὄψη\r
+ ποὺ μὲ βία μετράει τὴ γῆ.\r
+\r
+ ᾿Απ᾿ τὰ κόκκαλα βγαλμένη\r
+ τῶν ῾Ελλήνων τὰ ἱερά\r
+ καὶ σὰν πρῶτα ἀνδρειωμένη\r
+ χαῖρε, ὦ χαῖρε, ᾿Ελευθεριά!\r
+\r
+ From a speech of Demosthenes in the 4th century BC:\r
+\r
+ Οὐχὶ ταὐτὰ παρίσταταί μοι γιγνώσκειν, ὦ ἄνδρες ᾿Αθηναῖοι,\r
+ ὅταν τ᾿ εἰς τὰ πράγματα ἀποβλέψω καὶ ὅταν πρὸς τοὺς\r
+ λόγους οὓς ἀκούω· τοὺς μὲν γὰρ λόγους περὶ τοῦ\r
+ τιμωρήσασθαι Φίλιππον ὁρῶ γιγνομένους, τὰ δὲ πράγματ᾿\r
+ εἰς τοῦτο προήκοντα, ὥσθ᾿ ὅπως μὴ πεισόμεθ᾿ αὐτοὶ\r
+ πρότερον κακῶς σκέψασθαι δέον. οὐδέν οὖν ἄλλο μοι δοκοῦσιν\r
+ οἱ τὰ τοιαῦτα λέγοντες ἢ τὴν ὑπόθεσιν, περὶ ἧς βουλεύεσθαι,\r
+ οὐχὶ τὴν οὖσαν παριστάντες ὑμῖν ἁμαρτάνειν. ἐγὼ δέ, ὅτι μέν\r
+ ποτ᾿ ἐξῆν τῇ πόλει καὶ τὰ αὑτῆς ἔχειν ἀσφαλῶς καὶ Φίλιππον\r
+ τιμωρήσασθαι, καὶ μάλ᾿ ἀκριβῶς οἶδα· ἐπ᾿ ἐμοῦ γάρ, οὐ πάλαι\r
+ γέγονεν ταῦτ᾿ ἀμφότερα· νῦν μέντοι πέπεισμαι τοῦθ᾿ ἱκανὸν\r
+ προλαβεῖν ἡμῖν εἶναι τὴν πρώτην, ὅπως τοὺς συμμάχους\r
+ σώσομεν. ἐὰν γὰρ τοῦτο βεβαίως ὑπάρξῃ, τότε καὶ περὶ τοῦ\r
+ τίνα τιμωρήσεταί τις καὶ ὃν τρόπον ἐξέσται σκοπεῖν· πρὶν δὲ\r
+ τὴν ἀρχὴν ὀρθῶς ὑποθέσθαι, μάταιον ἡγοῦμαι περὶ τῆς\r
+ τελευτῆς ὁντινοῦν ποιεῖσθαι λόγον.\r
+\r
+ Δημοσθένους, Γ´ ᾿Ολυνθιακὸς\r
+\r
+Georgian:\r
+\r
+ From a Unicode conference invitation:\r
+\r
+ გთხოვთ ახლავე გაიაროთ რეგისტრაცია Unicode-ის მეათე საერთაშორისო\r
+ კონფერენციაზე დასასწრებად, რომელიც გაიმართება 10-12 მარტს,\r
+ ქ. მაინცში, გერმანიაში. კონფერენცია შეჰკრებს ერთად მსოფლიოს\r
+ ექსპერტებს ისეთ დარგებში როგორიცაა ინტერნეტი და Unicode-ი,\r
+ ინტერნაციონალიზაცია და ლოკალიზაცია, Unicode-ის გამოყენება\r
+ ოპერაციულ სისტემებსა, და გამოყენებით პროგრამებში, შრიფტებში,\r
+ ტექსტების დამუშავებასა და მრავალენოვან კომპიუტერულ სისტემებში.\r
+\r
+Russian:\r
+\r
+ From a Unicode conference invitation:\r
+\r
+ Зарегистрируйтесь сейчас на Десятую Международную Конференцию по\r
+ Unicode, которая состоится 10-12 марта 1997 года в Майнце в Германии.\r
+ Конференция соберет широкий круг экспертов по вопросам глобального\r
+ Интернета и Unicode, локализации и интернационализации, воплощению и\r
+ применению Unicode в различных операционных системах и программных\r
+ приложениях, шрифтах, верстке и многоязычных компьютерных системах.\r
+\r
+Thai (UCS Level 2):\r
+\r
+ Excerpt from a poetry on The Romance of The Three Kingdoms (a Chinese\r
+ classic 'San Gua'):\r
+\r
+ [----------------------------|------------------------]\r
+ ๏ แผ่นดินฮั่นเสื่อมโทรมแสนสังเวช พระปกเกศกองบู๊กู้ขึ้นใหม่\r
+ สิบสองกษัตริย์ก่อนหน้าแลถัดไป สององค์ไซร้โง่เขลาเบาปัญญา\r
+ ทรงนับถือขันทีเป็นที่พึ่ง บ้านเมืองจึงวิปริตเป็นนักหนา\r
+ โฮจิ๋นเรียกทัพทั่วหัวเมืองมา หมายจะฆ่ามดชั่วตัวสำคัญ\r
+ เหมือนขับไสไล่เสือจากเคหา รับหมาป่าเข้ามาเลยอาสัญ\r
+ ฝ่ายอ้องอุ้นยุแยกให้แตกกัน ใช้สาวนั้นเป็นชนวนชื่นชวนใจ\r
+ พลันลิฉุยกุยกีกลับก่อเหตุ ช่างอาเพศจริงหนาฟ้าร้องไห้\r
+ ต้องรบราฆ่าฟันจนบรรลัย ฤๅหาใครค้ำชูกู้บรรลังก์ ฯ\r
+\r
+ (The above is a two-column text. If combining characters are handled\r
+ correctly, the lines of the second column should be aligned with the\r
+ | character above.)\r
+\r
+Ethiopian:\r
+\r
+ Proverbs in the Amharic language:\r
+\r
+ ሰማይ አይታረስ ንጉሥ አይከሰስ።\r
+ ብላ ካለኝ እንደአባቴ በቆመጠኝ።\r
+ ጌጥ ያለቤቱ ቁምጥና ነው።\r
+ ደሀ በሕልሙ ቅቤ ባይጠጣ ንጣት በገደለው።\r
+ የአፍ ወለምታ በቅቤ አይታሽም።\r
+ አይጥ በበላ ዳዋ ተመታ።\r
+ ሲተረጉሙ ይደረግሙ።\r
+ ቀስ በቀስ፥ ዕንቁላል በእግሩ ይሄዳል።\r
+ ድር ቢያብር አንበሳ ያስር።\r
+ ሰው እንደቤቱ እንጅ እንደ ጉረቤቱ አይተዳደርም።\r
+ እግዜር የከፈተውን ጉሮሮ ሳይዘጋው አይድርም።\r
+ የጎረቤት ሌባ፥ ቢያዩት ይስቅ ባያዩት ያጠልቅ።\r
+ ሥራ ከመፍታት ልጄን ላፋታት።\r
+ ዓባይ ማደሪያ የለው፥ ግንድ ይዞ ይዞራል።\r
+ የእስላም አገሩ መካ የአሞራ አገሩ ዋርካ።\r
+ ተንጋሎ ቢተፉ ተመልሶ ባፉ።\r
+ ወዳጅህ ማር ቢሆን ጨርስህ አትላሰው።\r
+ እግርህን በፍራሽህ ልክ ዘርጋ።\r
+\r
+Runes:\r
+\r
+ ᚻᛖ ᚳᚹᚫᚦ ᚦᚫᛏ ᚻᛖ ᛒᚢᛞᛖ ᚩᚾ ᚦᚫᛗ ᛚᚪᚾᛞᛖ ᚾᚩᚱᚦᚹᛖᚪᚱᛞᚢᛗ ᚹᛁᚦ ᚦᚪ ᚹᛖᛥᚫ\r
+\r
+ (Old English, which transcribed into Latin reads 'He cwaeth that he\r
+ bude thaem lande northweardum with tha Westsae.' and means 'He said\r
+ that he lived in the northern land near the Western Sea.')\r
+\r
+Braille:\r
+\r
+ ⡌⠁⠧⠑ ⠼⠁⠒ ⡍⠜⠇⠑⠹⠰⠎ ⡣⠕⠌\r
+\r
+ ⡍⠜⠇⠑⠹ ⠺⠁⠎ ⠙⠑⠁⠙⠒ ⠞⠕ ⠃⠑⠛⠔ ⠺⠊⠹⠲ ⡹⠻⠑ ⠊⠎ ⠝⠕ ⠙⠳⠃⠞\r
+ ⠱⠁⠞⠑⠧⠻ ⠁⠃⠳⠞ ⠹⠁⠞⠲ ⡹⠑ ⠗⠑⠛⠊⠌⠻ ⠕⠋ ⠙⠊⠎ ⠃⠥⠗⠊⠁⠇ ⠺⠁⠎\r
+ ⠎⠊⠛⠝⠫ ⠃⠹ ⠹⠑ ⠊⠇⠻⠛⠹⠍⠁⠝⠂ ⠹⠑ ⠊⠇⠻⠅⠂ ⠹⠑ ⠥⠝⠙⠻⠞⠁⠅⠻⠂\r
+ ⠁⠝⠙ ⠹⠑ ⠡⠊⠑⠋ ⠍⠳⠗⠝⠻⠲ ⡎⠊⠗⠕⠕⠛⠑ ⠎⠊⠛⠝⠫ ⠊⠞⠲ ⡁⠝⠙\r
+ ⡎⠊⠗⠕⠕⠛⠑⠰⠎ ⠝⠁⠍⠑ ⠺⠁⠎ ⠛⠕⠕⠙ ⠥⠏⠕⠝ ⠰⡡⠁⠝⠛⠑⠂ ⠋⠕⠗ ⠁⠝⠹⠹⠔⠛ ⠙⠑\r
+ ⠡⠕⠎⠑ ⠞⠕ ⠏⠥⠞ ⠙⠊⠎ ⠙⠁⠝⠙ ⠞⠕⠲\r
+\r
+ ⡕⠇⠙ ⡍⠜⠇⠑⠹ ⠺⠁⠎ ⠁⠎ ⠙⠑⠁⠙ ⠁⠎ ⠁ ⠙⠕⠕⠗⠤⠝⠁⠊⠇⠲\r
+\r
+ ⡍⠔⠙⠖ ⡊ ⠙⠕⠝⠰⠞ ⠍⠑⠁⠝ ⠞⠕ ⠎⠁⠹ ⠹⠁⠞ ⡊ ⠅⠝⠪⠂ ⠕⠋ ⠍⠹\r
+ ⠪⠝ ⠅⠝⠪⠇⠫⠛⠑⠂ ⠱⠁⠞ ⠹⠻⠑ ⠊⠎ ⠏⠜⠞⠊⠊⠥⠇⠜⠇⠹ ⠙⠑⠁⠙ ⠁⠃⠳⠞\r
+ ⠁ ⠙⠕⠕⠗⠤⠝⠁⠊⠇⠲ ⡊ ⠍⠊⠣⠞ ⠙⠁⠧⠑ ⠃⠑⠲ ⠔⠊⠇⠔⠫⠂ ⠍⠹⠎⠑⠇⠋⠂ ⠞⠕\r
+ ⠗⠑⠛⠜⠙ ⠁ ⠊⠕⠋⠋⠔⠤⠝⠁⠊⠇ ⠁⠎ ⠹⠑ ⠙⠑⠁⠙⠑⠌ ⠏⠊⠑⠊⠑ ⠕⠋ ⠊⠗⠕⠝⠍⠕⠝⠛⠻⠹\r
+ ⠔ ⠹⠑ ⠞⠗⠁⠙⠑⠲ ⡃⠥⠞ ⠹⠑ ⠺⠊⠎⠙⠕⠍ ⠕⠋ ⠳⠗ ⠁⠝⠊⠑⠌⠕⠗⠎\r
+ ⠊⠎ ⠔ ⠹⠑ ⠎⠊⠍⠊⠇⠑⠆ ⠁⠝⠙ ⠍⠹ ⠥⠝⠙⠁⠇⠇⠪⠫ ⠙⠁⠝⠙⠎\r
+ ⠩⠁⠇⠇ ⠝⠕⠞ ⠙⠊⠌⠥⠗⠃ ⠊⠞⠂ ⠕⠗ ⠹⠑ ⡊⠳⠝⠞⠗⠹⠰⠎ ⠙⠕⠝⠑ ⠋⠕⠗⠲ ⡹⠳\r
+ ⠺⠊⠇⠇ ⠹⠻⠑⠋⠕⠗⠑ ⠏⠻⠍⠊⠞ ⠍⠑ ⠞⠕ ⠗⠑⠏⠑⠁⠞⠂ ⠑⠍⠏⠙⠁⠞⠊⠊⠁⠇⠇⠹⠂ ⠹⠁⠞\r
+ ⡍⠜⠇⠑⠹ ⠺⠁⠎ ⠁⠎ ⠙⠑⠁⠙ ⠁⠎ ⠁ ⠙⠕⠕⠗⠤⠝⠁⠊⠇⠲\r
+\r
+ (The first couple of paragraphs of "A Christmas Carol" by Dickens)\r
+\r
+Compact font selection example text:\r
+\r
+ ABCDEFGHIJKLMNOPQRSTUVWXYZ /0123456789\r
+ abcdefghijklmnopqrstuvwxyz £©µÀÆÖÞßéöÿ\r
+ –—‘“”„†•…‰™œŠŸž€ ΑΒΓΔΩαβγδω АБВГДабвгд\r
+ ∀∂∈ℝ∧∪≡∞ ↑↗↨↻⇣ ┐┼╔╘░►☺♀ fi�⑀₂ἠḂӥẄɐː⍎אԱა\r
+\r
+Greetings in various languages:\r
+\r
+ Hello world, Καλημέρα κόσμε, コンニチハ\r
+\r
+Box drawing alignment tests: █\r
+ ▉\r
+ ╔══╦══╗ ┌──┬──┐ ╭──┬──╮ ╭──┬──╮ ┏━━┳━━┓ ┎┒┏┑ ╷ ╻ ┏┯┓ ┌┰┐ ▊ ╱╲╱╲╳╳╳\r
+ ║┌─╨─┐║ │╔═╧═╗│ │╒═╪═╕│ │╓─╁─╖│ ┃┌─╂─┐┃ ┗╃╄┙ ╶┼╴╺╋╸┠┼┨ ┝╋┥ ▋ ╲╱╲╱╳╳╳\r
+ ║│╲ ╱│║ │║ ║│ ││ │ ││ │║ ┃ ║│ ┃│ ╿ │┃ ┍╅╆┓ ╵ ╹ ┗┷┛ └┸┘ ▌ ╱╲╱╲╳╳╳\r
+ ╠╡ ╳ ╞╣ ├╢ ╟┤ ├┼─┼─┼┤ ├╫─╂─╫┤ ┣┿╾┼╼┿┫ ┕┛┖┚ ┌┄┄┐ ╎ ┏┅┅┓ ┋ ▍ ╲╱╲╱╳╳╳\r
+ ║│╱ ╲│║ │║ ║│ ││ │ ││ │║ ┃ ║│ ┃│ ╽ │┃ ░░▒▒▓▓██ ┊ ┆ ╎ ╏ ┇ ┋ ▎\r
+ ║└─╥─┘║ │╚═╤═╝│ │╘═╪═╛│ │╙─╀─╜│ ┃└─╂─┘┃ ░░▒▒▓▓██ ┊ ┆ ╎ ╏ ┇ ┋ ▏\r
+ ╚══╩══╝ └──┴──┘ ╰──┴──╯ ╰──┴──╯ ┗━━┻━━┛ ▗▄▖▛▀▜ └╌╌┘ ╎ ┗╍╍┛ ┋ ▁▂▃▄▅▆▇█\r
+ ▝▀▘▙▄▟\r
--- /dev/null
+
+UTF-8 encoded sample plain-text file
+‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾
+
+Markus Kuhn [ˈmaʳkʊs kuːn] <http://www.cl.cam.ac.uk/~mgk25/> — 2002-07-25
+
+
+The ASCII compatible UTF-8 encoding used in this plain-text file
+is defined in Unicode, ISO 10646-1, and RFC 2279.
+
+
+Using Unicode/UTF-8, you can write in emails and source code things such as
+
+Mathematics and sciences:
+
+ ∮ E⋅da = Q, n → ∞, ∑ f(i) = ∏ g(i), ⎧⎡⎛┌─────┐⎞⎤⎫
+ ⎪⎢⎜│a²+b³ ⎟⎥⎪
+ ∀x∈ℝ: ⌈x⌉ = −⌊−x⌋, α ∧ ¬β = ¬(¬α ∨ β), ⎪⎢⎜│───── ⎟⎥⎪
+ ⎪⎢⎜⎷ c₈ ⎟⎥⎪
+ ℕ ⊆ ℕ₀ ⊂ ℤ ⊂ ℚ ⊂ ℝ ⊂ ℂ, ⎨⎢⎜ ⎟⎥⎬
+ ⎪⎢⎜ ∞ ⎟⎥⎪
+ ⊥ < a ≠ b ≡ c ≤ d ≪ ⊤ ⇒ (⟦A⟧ ⇔ ⟪B⟫), ⎪⎢⎜ ⎲ ⎟⎥⎪
+ ⎪⎢⎜ ⎳aⁱ-bⁱ⎟⎥⎪
+ 2H₂ + O₂ ⇌ 2H₂O, R = 4.7 kΩ, ⌀ 200 mm ⎩⎣⎝i=1 ⎠⎦⎭
+
+Linguistics and dictionaries:
+
+ ði ıntəˈnæʃənəl fəˈnɛtık əsoʊsiˈeıʃn
+ Y [ˈʏpsilɔn], Yen [jɛn], Yoga [ˈjoːgɑ]
+
+APL:
+
+ ((V⍳V)=⍳⍴V)/V←,V ⌷←⍳→⍴∆∇⊃‾⍎⍕⌈
+
+Nicer typography in plain text files:
+
+ ╔══════════════════════════════════════════╗
+ ║ ║
+ ║ • ‘single’ and “double” quotes ║
+ ║ ║
+ ║ • Curly apostrophes: “We’ve been here” ║
+ ║ ║
+ ║ • Latin-1 apostrophe and accents: '´` ║
+ ║ ║
+ ║ • ‚deutsche‘ „Anführungszeichen“ ║
+ ║ ║
+ ║ • †, ‡, ‰, •, 3–4, —, −5/+5, ™, … ║
+ ║ ║
+ ║ • ASCII safety test: 1lI|, 0OD, 8B ║
+ ║ ╭─────────╮ ║
+ ║ • the euro symbol: │ 14.95 € │ ║
+ ║ ╰─────────╯ ║
+ ╚══════════════════════════════════════════╝
+
+Combining characters:
+
+ STARGΛ̊TE SG-1, a = v̇ = r̈, a⃑ ⊥ b⃑
+
+Greek (in Polytonic):
+
+ The Greek anthem:
+
+ Σὲ γνωρίζω ἀπὸ τὴν κόψη
+ τοῦ σπαθιοῦ τὴν τρομερή,
+ σὲ γνωρίζω ἀπὸ τὴν ὄψη
+ ποὺ μὲ βία μετράει τὴ γῆ.
+
+ ᾿Απ᾿ τὰ κόκκαλα βγαλμένη
+ τῶν ῾Ελλήνων τὰ ἱερά
+ καὶ σὰν πρῶτα ἀνδρειωμένη
+ χαῖρε, ὦ χαῖρε, ᾿Ελευθεριά!
+
+ From a speech of Demosthenes in the 4th century BC:
+
+ Οὐχὶ ταὐτὰ παρίσταταί μοι γιγνώσκειν, ὦ ἄνδρες ᾿Αθηναῖοι,
+ ὅταν τ᾿ εἰς τὰ πράγματα ἀποβλέψω καὶ ὅταν πρὸς τοὺς
+ λόγους οὓς ἀκούω· τοὺς μὲν γὰρ λόγους περὶ τοῦ
+ τιμωρήσασθαι Φίλιππον ὁρῶ γιγνομένους, τὰ δὲ πράγματ᾿
+ εἰς τοῦτο προήκοντα, ὥσθ᾿ ὅπως μὴ πεισόμεθ᾿ αὐτοὶ
+ πρότερον κακῶς σκέψασθαι δέον. οὐδέν οὖν ἄλλο μοι δοκοῦσιν
+ οἱ τὰ τοιαῦτα λέγοντες ἢ τὴν ὑπόθεσιν, περὶ ἧς βουλεύεσθαι,
+ οὐχὶ τὴν οὖσαν παριστάντες ὑμῖν ἁμαρτάνειν. ἐγὼ δέ, ὅτι μέν
+ ποτ᾿ ἐξῆν τῇ πόλει καὶ τὰ αὑτῆς ἔχειν ἀσφαλῶς καὶ Φίλιππον
+ τιμωρήσασθαι, καὶ μάλ᾿ ἀκριβῶς οἶδα· ἐπ᾿ ἐμοῦ γάρ, οὐ πάλαι
+ γέγονεν ταῦτ᾿ ἀμφότερα· νῦν μέντοι πέπεισμαι τοῦθ᾿ ἱκανὸν
+ προλαβεῖν ἡμῖν εἶναι τὴν πρώτην, ὅπως τοὺς συμμάχους
+ σώσομεν. ἐὰν γὰρ τοῦτο βεβαίως ὑπάρξῃ, τότε καὶ περὶ τοῦ
+ τίνα τιμωρήσεταί τις καὶ ὃν τρόπον ἐξέσται σκοπεῖν· πρὶν δὲ
+ τὴν ἀρχὴν ὀρθῶς ὑποθέσθαι, μάταιον ἡγοῦμαι περὶ τῆς
+ τελευτῆς ὁντινοῦν ποιεῖσθαι λόγον.
+
+ Δημοσθένους, Γ´ ᾿Ολυνθιακὸς
+
+Georgian:
+
+ From a Unicode conference invitation:
+
+ გთხოვთ ახლავე გაიაროთ რეგისტრაცია Unicode-ის მეათე საერთაშორისო
+ კონფერენციაზე დასასწრებად, რომელიც გაიმართება 10-12 მარტს,
+ ქ. მაინცში, გერმანიაში. კონფერენცია შეჰკრებს ერთად მსოფლიოს
+ ექსპერტებს ისეთ დარგებში როგორიცაა ინტერნეტი და Unicode-ი,
+ ინტერნაციონალიზაცია და ლოკალიზაცია, Unicode-ის გამოყენება
+ ოპერაციულ სისტემებსა, და გამოყენებით პროგრამებში, შრიფტებში,
+ ტექსტების დამუშავებასა და მრავალენოვან კომპიუტერულ სისტემებში.
+
+Russian:
+
+ From a Unicode conference invitation:
+
+ Зарегистрируйтесь сейчас на Десятую Международную Конференцию по
+ Unicode, которая состоится 10-12 марта 1997 года в Майнце в Германии.
+ Конференция соберет широкий круг экспертов по вопросам глобального
+ Интернета и Unicode, локализации и интернационализации, воплощению и
+ применению Unicode в различных операционных системах и программных
+ приложениях, шрифтах, верстке и многоязычных компьютерных системах.
+
+Thai (UCS Level 2):
+
+ Excerpt from a poetry on The Romance of The Three Kingdoms (a Chinese
+ classic 'San Gua'):
+
+ [----------------------------|------------------------]
+ ๏ แผ่นดินฮั่นเสื่อมโทรมแสนสังเวช พระปกเกศกองบู๊กู้ขึ้นใหม่
+ สิบสองกษัตริย์ก่อนหน้าแลถัดไป สององค์ไซร้โง่เขลาเบาปัญญา
+ ทรงนับถือขันทีเป็นที่พึ่ง บ้านเมืองจึงวิปริตเป็นนักหนา
+ โฮจิ๋นเรียกทัพทั่วหัวเมืองมา หมายจะฆ่ามดชั่วตัวสำคัญ
+ เหมือนขับไสไล่เสือจากเคหา รับหมาป่าเข้ามาเลยอาสัญ
+ ฝ่ายอ้องอุ้นยุแยกให้แตกกัน ใช้สาวนั้นเป็นชนวนชื่นชวนใจ
+ พลันลิฉุยกุยกีกลับก่อเหตุ ช่างอาเพศจริงหนาฟ้าร้องไห้
+ ต้องรบราฆ่าฟันจนบรรลัย ฤๅหาใครค้ำชูกู้บรรลังก์ ฯ
+
+ (The above is a two-column text. If combining characters are handled
+ correctly, the lines of the second column should be aligned with the
+ | character above.)
+
+Ethiopian:
+
+ Proverbs in the Amharic language:
+
+ ሰማይ አይታረስ ንጉሥ አይከሰስ።
+ ብላ ካለኝ እንደአባቴ በቆመጠኝ።
+ ጌጥ ያለቤቱ ቁምጥና ነው።
+ ደሀ በሕልሙ ቅቤ ባይጠጣ ንጣት በገደለው።
+ የአፍ ወለምታ በቅቤ አይታሽም።
+ አይጥ በበላ ዳዋ ተመታ።
+ ሲተረጉሙ ይደረግሙ።
+ ቀስ በቀስ፥ ዕንቁላል በእግሩ ይሄዳል።
+ ድር ቢያብር አንበሳ ያስር።
+ ሰው እንደቤቱ እንጅ እንደ ጉረቤቱ አይተዳደርም።
+ እግዜር የከፈተውን ጉሮሮ ሳይዘጋው አይድርም።
+ የጎረቤት ሌባ፥ ቢያዩት ይስቅ ባያዩት ያጠልቅ።
+ ሥራ ከመፍታት ልጄን ላፋታት።
+ ዓባይ ማደሪያ የለው፥ ግንድ ይዞ ይዞራል።
+ የእስላም አገሩ መካ የአሞራ አገሩ ዋርካ።
+ ተንጋሎ ቢተፉ ተመልሶ ባፉ።
+ ወዳጅህ ማር ቢሆን ጨርስህ አትላሰው።
+ እግርህን በፍራሽህ ልክ ዘርጋ።
+
+Runes:
+
+ ᚻᛖ ᚳᚹᚫᚦ ᚦᚫᛏ ᚻᛖ ᛒᚢᛞᛖ ᚩᚾ ᚦᚫᛗ ᛚᚪᚾᛞᛖ ᚾᚩᚱᚦᚹᛖᚪᚱᛞᚢᛗ ᚹᛁᚦ ᚦᚪ ᚹᛖᛥᚫ
+
+ (Old English, which transcribed into Latin reads 'He cwaeth that he
+ bude thaem lande northweardum with tha Westsae.' and means 'He said
+ that he lived in the northern land near the Western Sea.')
+
+Braille:
+
+ ⡌⠁⠧⠑ ⠼⠁⠒ ⡍⠜⠇⠑⠹⠰⠎ ⡣⠕⠌
+
+ ⡍⠜⠇⠑⠹ ⠺⠁⠎ ⠙⠑⠁⠙⠒ ⠞⠕ ⠃⠑⠛⠔ ⠺⠊⠹⠲ ⡹⠻⠑ ⠊⠎ ⠝⠕ ⠙⠳⠃⠞
+ ⠱⠁⠞⠑⠧⠻ ⠁⠃⠳⠞ ⠹⠁⠞⠲ ⡹⠑ ⠗⠑⠛⠊⠌⠻ ⠕⠋ ⠙⠊⠎ ⠃⠥⠗⠊⠁⠇ ⠺⠁⠎
+ ⠎⠊⠛⠝⠫ ⠃⠹ ⠹⠑ ⠊⠇⠻⠛⠹⠍⠁⠝⠂ ⠹⠑ ⠊⠇⠻⠅⠂ ⠹⠑ ⠥⠝⠙⠻⠞⠁⠅⠻⠂
+ ⠁⠝⠙ ⠹⠑ ⠡⠊⠑⠋ ⠍⠳⠗⠝⠻⠲ ⡎⠊⠗⠕⠕⠛⠑ ⠎⠊⠛⠝⠫ ⠊⠞⠲ ⡁⠝⠙
+ ⡎⠊⠗⠕⠕⠛⠑⠰⠎ ⠝⠁⠍⠑ ⠺⠁⠎ ⠛⠕⠕⠙ ⠥⠏⠕⠝ ⠰⡡⠁⠝⠛⠑⠂ ⠋⠕⠗ ⠁⠝⠹⠹⠔⠛ ⠙⠑
+ ⠡⠕⠎⠑ ⠞⠕ ⠏⠥⠞ ⠙⠊⠎ ⠙⠁⠝⠙ ⠞⠕⠲
+
+ ⡕⠇⠙ ⡍⠜⠇⠑⠹ ⠺⠁⠎ ⠁⠎ ⠙⠑⠁⠙ ⠁⠎ ⠁ ⠙⠕⠕⠗⠤⠝⠁⠊⠇⠲
+
+ ⡍⠔⠙⠖ ⡊ ⠙⠕⠝⠰⠞ ⠍⠑⠁⠝ ⠞⠕ ⠎⠁⠹ ⠹⠁⠞ ⡊ ⠅⠝⠪⠂ ⠕⠋ ⠍⠹
+ ⠪⠝ ⠅⠝⠪⠇⠫⠛⠑⠂ ⠱⠁⠞ ⠹⠻⠑ ⠊⠎ ⠏⠜⠞⠊⠊⠥⠇⠜⠇⠹ ⠙⠑⠁⠙ ⠁⠃⠳⠞
+ ⠁ ⠙⠕⠕⠗⠤⠝⠁⠊⠇⠲ ⡊ ⠍⠊⠣⠞ ⠙⠁⠧⠑ ⠃⠑⠲ ⠔⠊⠇⠔⠫⠂ ⠍⠹⠎⠑⠇⠋⠂ ⠞⠕
+ ⠗⠑⠛⠜⠙ ⠁ ⠊⠕⠋⠋⠔⠤⠝⠁⠊⠇ ⠁⠎ ⠹⠑ ⠙⠑⠁⠙⠑⠌ ⠏⠊⠑⠊⠑ ⠕⠋ ⠊⠗⠕⠝⠍⠕⠝⠛⠻⠹
+ ⠔ ⠹⠑ ⠞⠗⠁⠙⠑⠲ ⡃⠥⠞ ⠹⠑ ⠺⠊⠎⠙⠕⠍ ⠕⠋ ⠳⠗ ⠁⠝⠊⠑⠌⠕⠗⠎
+ ⠊⠎ ⠔ ⠹⠑ ⠎⠊⠍⠊⠇⠑⠆ ⠁⠝⠙ ⠍⠹ ⠥⠝⠙⠁⠇⠇⠪⠫ ⠙⠁⠝⠙⠎
+ ⠩⠁⠇⠇ ⠝⠕⠞ ⠙⠊⠌⠥⠗⠃ ⠊⠞⠂ ⠕⠗ ⠹⠑ ⡊⠳⠝⠞⠗⠹⠰⠎ ⠙⠕⠝⠑ ⠋⠕⠗⠲ ⡹⠳
+ ⠺⠊⠇⠇ ⠹⠻⠑⠋⠕⠗⠑ ⠏⠻⠍⠊⠞ ⠍⠑ ⠞⠕ ⠗⠑⠏⠑⠁⠞⠂ ⠑⠍⠏⠙⠁⠞⠊⠊⠁⠇⠇⠹⠂ ⠹⠁⠞
+ ⡍⠜⠇⠑⠹ ⠺⠁⠎ ⠁⠎ ⠙⠑⠁⠙ ⠁⠎ ⠁ ⠙⠕⠕⠗⠤⠝⠁⠊⠇⠲
+
+ (The first couple of paragraphs of "A Christmas Carol" by Dickens)
+
+Compact font selection example text:
+
+ ABCDEFGHIJKLMNOPQRSTUVWXYZ /0123456789
+ abcdefghijklmnopqrstuvwxyz £©µÀÆÖÞßéöÿ
+ –—‘“”„†•…‰™œŠŸž€ ΑΒΓΔΩαβγδω АБВГДабвгд
+ ∀∂∈ℝ∧∪≡∞ ↑↗↨↻⇣ ┐┼╔╘░►☺♀ fi�⑀₂ἠḂӥẄɐː⍎אԱა
+
+Greetings in various languages:
+
+ Hello world, Καλημέρα κόσμε, コンニチハ
+
+Box drawing alignment tests: █
+ ▉
+ ╔══╦══╗ ┌──┬──┐ ╭──┬──╮ ╭──┬──╮ ┏━━┳━━┓ ┎┒┏┑ ╷ ╻ ┏┯┓ ┌┰┐ ▊ ╱╲╱╲╳╳╳
+ ║┌─╨─┐║ │╔═╧═╗│ │╒═╪═╕│ │╓─╁─╖│ ┃┌─╂─┐┃ ┗╃╄┙ ╶┼╴╺╋╸┠┼┨ ┝╋┥ ▋ ╲╱╲╱╳╳╳
+ ║│╲ ╱│║ │║ ║│ ││ │ ││ │║ ┃ ║│ ┃│ ╿ │┃ ┍╅╆┓ ╵ ╹ ┗┷┛ └┸┘ ▌ ╱╲╱╲╳╳╳
+ ╠╡ ╳ ╞╣ ├╢ ╟┤ ├┼─┼─┼┤ ├╫─╂─╫┤ ┣┿╾┼╼┿┫ ┕┛┖┚ ┌┄┄┐ ╎ ┏┅┅┓ ┋ ▍ ╲╱╲╱╳╳╳
+ ║│╱ ╲│║ │║ ║│ ││ │ ││ │║ ┃ ║│ ┃│ ╽ │┃ ░░▒▒▓▓██ ┊ ┆ ╎ ╏ ┇ ┋ ▎
+ ║└─╥─┘║ │╚═╤═╝│ │╘═╪═╛│ │╙─╀─╜│ ┃└─╂─┘┃ ░░▒▒▓▓██ ┊ ┆ ╎ ╏ ┇ ┋ ▏
+ ╚══╩══╝ └──┴──┘ ╰──┴──╯ ╰──┴──╯ ┗━━┻━━┛ ▗▄▖▛▀▜ └╌╌┘ ╎ ┗╍╍┛ ┋ ▁▂▃▄▅▆▇█
+ ▝▀▘▙▄▟
--- /dev/null
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: FLEXI-STREAMS; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/flexi-streams/util.lisp,v 1.24 2008/05/25 21:26:12 edi Exp $
+
+;;; Copyright (c) 2005-2008, Dr. Edmund Weitz. All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;; * Redistributions of source code must retain the above copyright
+;;; notice, this list of conditions and the following disclaimer.
+
+;;; * 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 BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; 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 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.
+
+(in-package :flexi-streams)
+
+#+:lispworks
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (import '(lw:with-unique-names lw:when-let)))
+
+#-:lispworks
+(defmacro when-let ((var form) &body body)
+ "Evaluates FORM and binds VAR to the result, then executes BODY
+if VAR has a true value."
+ `(let ((,var ,form))
+ (when ,var ,@body)))
+
+#-:lispworks
+(defmacro with-unique-names ((&rest bindings) &body body)
+ "Syntax: WITH-UNIQUE-NAMES ( { var | (var x) }* ) declaration* form*
+
+Executes a series of forms with each VAR bound to a fresh,
+uninterned symbol. The uninterned symbol is as if returned by a call
+to GENSYM with the string denoted by X - or, if X is not supplied, the
+string denoted by VAR - as argument.
+
+The variable bindings created are lexical unless special declarations
+are specified. The scopes of the name bindings and declarations do not
+include the Xs.
+
+The forms are evaluated in order, and the values of all but the last
+are discarded \(that is, the body is an implicit PROGN)."
+ ;; reference implementation posted to comp.lang.lisp as
+ ;; <cy3bshuf30f.fsf@ljosa.com> by Vebjorn Ljosa - see also
+ ;; <http://www.cliki.net/Common%20Lisp%20Utilities>
+ `(let ,(mapcar #'(lambda (binding)
+ (check-type binding (or cons symbol))
+ (if (consp binding)
+ (destructuring-bind (var x) binding
+ (check-type var symbol)
+ `(,var (gensym ,(etypecase x
+ (symbol (symbol-name x))
+ (character (string x))
+ (string x)))))
+ `(,binding (gensym ,(symbol-name binding)))))
+ bindings)
+ ,@body))
+
+#+:lispworks
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (setf (macro-function 'with-rebinding)
+ (macro-function 'lw:rebinding)))
+
+#-:lispworks
+(defmacro with-rebinding (bindings &body body)
+ "WITH-REBINDING ( { var | (var prefix) }* ) form*
+
+Evaluates a series of forms in the lexical environment that is
+formed by adding the binding of each VAR to a fresh, uninterned
+symbol, and the binding of that fresh, uninterned symbol to VAR's
+original value, i.e., its value in the current lexical environment.
+
+The uninterned symbol is created as if by a call to GENSYM with the
+string denoted by PREFIX - or, if PREFIX is not supplied, the string
+denoted by VAR - as argument.
+
+The forms are evaluated in order, and the values of all but the last
+are discarded \(that is, the body is an implicit PROGN)."
+ ;; reference implementation posted to comp.lang.lisp as
+ ;; <cy3wv0fya0p.fsf@ljosa.com> by Vebjorn Ljosa - see also
+ ;; <http://www.cliki.net/Common%20Lisp%20Utilities>
+ (loop for binding in bindings
+ for var = (if (consp binding) (car binding) binding)
+ for name = (gensym)
+ collect `(,name ,var) into renames
+ collect ``(,,var ,,name) into temps
+ finally (return `(let ,renames
+ (with-unique-names ,bindings
+ `(let (,,@temps)
+ ,,@body))))))
+
+(defun normalize-external-format-name (name)
+ "Converts NAME \(a symbol) to a `canonical' name for an
+external format, e.g. :LATIN1 will be converted to :ISO-8859-1.
+Also checks if there is an external format with that name and
+signals an error otherwise."
+ (let ((real-name (cdr (find name flex::+name-map+
+ :test (lambda (item pair)
+ (or (string-equal item (cdr pair))
+ (string-equal item (car pair))))))))
+ (unless real-name
+ (error 'external-format-error
+ :format-control "~S is not known to be a name for an external format."
+ :format-arguments (list name)))
+ real-name))
+
+(defun ascii-name-p (name)
+ "Checks whether NAME is the keyword :ASCII."
+ (eq name :us-ascii))
+
+(defun koi8-r-name-p (name)
+ "Checks whether NAME is the keyword :KOI8-R."
+ (eq name :koi8-r))
+
+(defun code-page-name-p (name)
+ "Checks whether NAME is the keyword :CODE-PAGE."
+ (eq name :code-page))
+
+(defun iso-8859-name-p (name)
+ "Checks whether NAME \(a keyword) names one of the known
+ISO-8859 encodings."
+ (find name +iso-8859-tables+ :key #'car))
+
+(defun known-code-page-id-p (id)
+ "Checks whether ID \(a number) denotes one of the known Windows
+code pages."
+ (and (find id +code-page-tables+ :key #'car)
+ id))
+
+#+:lispworks
+(defun sans (plist &rest keys)
+ "Returns PLIST with keyword arguments from KEYS removed."
+ (sys::remove-properties plist keys))
+
+#-:lispworks
+(defun sans (plist &rest keys)
+ "Returns PLIST with keyword arguments from KEYS removed."
+ ;; stolen from Usenet posting <3247672165664225@naggum.no> by Erik
+ ;; Naggum
+ (let ((sans ()))
+ (loop
+ (let ((tail (nth-value 2 (get-properties plist keys))))
+ ;; this is how it ends
+ (unless tail
+ (return (nreconc sans plist)))
+ ;; copy all the unmatched keys
+ (loop until (eq plist tail) do
+ (push (pop plist) sans)
+ (push (pop plist) sans))
+ ;; skip the matched key
+ (setq plist (cddr plist))))))
+
+#+:lispworks
+(defmacro with-accessors (slot-entries instance &body body)
+ "For LispWorks, we prefer SLOT-VALUE over accessors for better
+performance."
+ ;; note that we assume that the variables have the same names as the
+ ;; slots
+ `(with-slots ,(mapcar #'car slot-entries)
+ ,instance
+ ,@body))
+
+(defun make-octet-buffer (&optional (size +buffer-size+))
+ "Creates and returns a fresh buffer \(a specialized array) of size
++BUFFER-SIZE+ to hold octets."
+ (declare #.*standard-optimize-settings*)
+ (make-array size :element-type 'octet))
+
+(defun type-equal (type1 type2)
+ "Whether TYPE1 and TYPE2 denote the same type."
+ (declare #.*standard-optimize-settings*)
+ (and (subtypep type1 type2)
+ (subtypep type2 type1)))
+
+(defun maybe-rewind (stream octets)
+ "Tries to `rewind' the \(binary) stream STREAM by OCTETS octets.
+Returns T if it succeeds, otherwise NIL."
+ (when-let (position (file-position stream))
+ (if (file-position stream (- position octets)) t nil)))
+
+(defmacro logand* (x y)
+ "Solely for optimization purposes. Some Lisps need it, some don't."
+ `(the fixnum (logand ,x ,y)))
+
+(defmacro logior* (x y)
+ "Solely for optimization purposes. Some Lisps need it, some don't."
+ `(the fixnum (logior ,x ,y)))
+
+(defmacro ash* (integer count)
+ "Solely for optimization purposes. Some Lisps need it, some don't."
+ `(the fixnum (ash ,integer ,count)))
--- /dev/null
+*.fasl
+*~
+.#*
+*#
--- /dev/null
+Version 0.0.5
+2009-07-17
+Supported allegro
+
+Version 0.0.4
+2009-05-18
+Added run-hooks, run-hook-with-args, add-hook and rem-hook functions
+
+Version 0.0.3
+2009-05-11
+Added asdf-version, asdf-version= and asdf-version<=
+
+Version 0.0.2
+2009-04-15
+Added with-gensyms
+Added hash->alist
+
+Version 0.0.1
+2009-04-06
+Initial public release
--- /dev/null
+(in-package :cl-user)
+
+(defpackage :my-util-tests-asd (:use :cl :asdf))
+
+(in-package :my-util-tests-asd)
+
+(defsystem :my-util-tests
+ :name "my-util-tests"
+ :author "Tomoyuki Matsumoto <tomoyuki28jp@gmail.com>"
+ :licence "BSD"
+ :description "tests for my-util"
+ :depends-on (:my-util :fiveam)
+ :components ((:module "tests"
+ :components
+ ((:file "my-util")))))
--- /dev/null
+(in-package :cl-user)
+
+(defpackage :my-util-asd (:use :cl :asdf))
+
+(in-package :my-util-asd)
+
+(defsystem :my-util
+ :version "0.0.5"
+ :name "my-util"
+ :author "Tomoyuki Matsumoto <tomoyuki28jp@gmail.com>"
+ :licence "BSD"
+ :description "My Common Lisp Utilities"
+ :depends-on (:anaphora :cl-ppcre)
+ :components ((:module "src"
+ :serial t
+ :components
+ ((:file "package")
+ (:file "my-util")))))
--- /dev/null
+(in-package :my-util)
+
+; --- Debugging -------------------------------------------------
+
+(defmacro pm (expr) `(pprint (macroexpand ',expr)))
+(defmacro pm1 (expr) `(pprint (macroexpand-1 ',expr)))
+
+; --- ASDF versions ---------------------------------------------
+
+(defun asdf-version (name)
+ (asdf:component-version (asdf:find-system name)))
+
+(defun asdf-version= (name version)
+ (or (string= (asdf-version name) version)
+ (error "~S must be version ~A" name version)))
+
+(defun asdf-version<= (name version)
+ (flet ((int (x) (parse-integer (remove #\. x))))
+ (or (<= (int version) (int (asdf-version name)))
+ (error "~S must be version ~A or higher" name version))))
+
+; --- Bindings --------------------------------------------------
+
+(defmacro when-let ((var form) &body body)
+ `(let ((,var ,form))
+ (when ,var ,@body)))
+
+(defmacro with-gensyms (syms &body body)
+ `(let ,(mapcar #'(lambda (s)
+ `(,s (gensym)))
+ syms)
+ ,@body))
+
+; --- Type casting ----------------------------------------------
+
+(defun ->string (x)
+ (if (stringp x)
+ x
+ (with-output-to-string (s)
+ (when x (princ x s)))))
+
+(defun ->string-down (x) (string-downcase (->string x)))
+(defun ->string-up (x) (string-upcase (->string x)))
+
+(defun ->list (x)
+ (if (listp x)
+ x
+ (list x)))
+
+(defun ->int (x)
+ (if (integerp x)
+ x
+ (ignore-errors (parse-integer x))))
+
+(defun ->keyword (x)
+ (if (keywordp x)
+ x
+ (intern (->string-up x) :keyword)))
+
+(defun ->symbol (x)
+ (intern (->string (->string-up x))))
+
+(defun hash->alist (hash)
+ (declare (hash-table hash))
+ (loop for key being the hash-key of hash
+ using (hash-value value)
+ collect (cons key value)))
+
+; --- Strings ---------------------------------------------------
+
+(defun concat (&rest args)
+ (apply #'concatenate 'string (mapcar #'->string args)))
+
+(defun join (joiner &rest args)
+ (format nil (concat "~{~A~^" (->string joiner) "~}")
+ (remove nil args)))
+
+; --- Hooks -----------------------------------------------------
+
+(defvar *hooks* (make-hash-table))
+
+(defun run-hooks (&rest hooks)
+ (dolist (hook hooks)
+ (dolist (function (gethash hook *hooks*))
+ do (funcall function))))
+
+(defun run-hook-with-args (hook &rest args)
+ (dolist (function (gethash hook *hooks*))
+ do (apply function args)))
+
+(defun add-hook (hook function)
+ (check-type function function)
+ (let ((functions (gethash hook *hooks*)))
+ (unless (member function functions)
+ (setf (gethash hook *hooks*)
+ (append functions (list function))))))
+
+(defun rem-hook (hook function)
+ (check-type function function)
+ (setf (gethash hook *hooks*)
+ (remove function (gethash hook *hooks*))))
--- /dev/null
+(in-package :cl-user)
+
+(macrolet
+ ((define-package ()
+ `(defpackage :my-util
+ (:use :cl :anaphora :cl-ppcre)
+ (:export ; --- util ---
+ :pm
+ :pm1
+ :asdf-version
+ :asdf-version=
+ :asdf-version<=
+ :when-let
+ :with-gensyms
+ :->string
+ :->string-down
+ :->string-up
+ :->list
+ :->int
+ :->keyword
+ :->symbol
+ :hash->alist
+ :concat
+ :join
+ :run-hooks
+ :run-hook-with-args
+ :add-hook
+ :rem-hook
+ ; --- anaphora ---
+ ,@(loop for s being the external-symbol
+ in :anaphora collect s)
+ ; --- cl-ppcre ---
+ ,@(loop for s being the external-symbol
+ in :cl-ppcre collect s)
+ ))))
+ (define-package))
--- /dev/null
+(in-package :cl-user)
+
+(defpackage :my-util-tests
+ (:use :cl :my-util :5am))
+
+(in-package :my-util-tests)
+
+(def-suite my-util)
+(in-suite my-util)
+
+(test ->string
+ (is (string= (->string 1) "1"))
+ (is (string= (->string "1") "1"))
+ (is (string= (->string nil) ""))
+ (is (string= (->string 'a) "A"))
+ (is (string= (->string :a) "A"))
+ (is (string= (->string '(1)) "(1)")))
+
+(test ->string-down
+ (is (string= (->string-down "A") "a"))
+ (is (string= (->string-down "a") "a"))
+ (is (string= (->string-down 'a) "a"))
+ (is (string= (->string-down :a) "a")))
+
+(test ->string-up
+ (is (string= (->string-up "A") "A"))
+ (is (string= (->string-up "a") "A"))
+ (is (string= (->string-up 'a) "A"))
+ (is (string= (->string-up :a) "A")))
+
+(test ->list
+ (is (equal '(1) (->list 1)))
+ (is (equal '(1) (->list '(1)))))
+
+(test ->int
+ (is (eq (->int 1) 1))
+ (is (eq (->int "1") 1))
+ (is (eq (->int '(1)) nil))
+ (is (eq (->int "1.1") nil)))
+
+(test ->keyword
+ (is (eq :keyword (->keyword "keyword")))
+ (is (eq :keyword (->keyword "KEYWORD")))
+ (is (eq :keyword (->keyword 'keyword)))
+ (is (eq :keyword (->keyword :keyword))))
+
+(test ->symbol
+ (is (eq 'symbol (->symbol "symbol")))
+ (is (eq 'symbol (->symbol "SYMBOL")))
+ (is (eq 'symbol (->symbol 'symbol)))
+ (is (eq 'symbol (->symbol :symbol))))
+
+(test hash->alist
+ (let ((hash (make-hash-table)))
+ (setf (gethash 'k1 hash) 'v1)
+ (setf (gethash 'k2 hash) 'v2)
+ (setf (gethash 'k3 hash) 'v3)
+ (is (equal (hash->alist hash)
+ #+:allegro '((k3 . v3) (k2 . v2) (k1 . v1))
+ #-:allegro '((k1 . v1) (k2 . v2) (k3 . v3))))))
+
+(test concat
+ (is (string= (concat 1 2 3) "123"))
+ (is (string= (concat "1" "2" "3") "123"))
+ (is (string= (concat nil 1 nil 2 nil 3 nil) "123"))
+ (is (string= (concat nil "1" nil "2" nil "3"nil) "123")))
+
+(test join
+ (is (string= (join "," 1 2 3) "1,2,3"))
+ (is (string= (join "," nil 1 nil 2 nil 3 nil) "1,2,3"))
+ (is (string= (join "," "1" "2" "3") "1,2,3"))
+ (is (string= (join "," nil "1" nil "2" nil "3"nil) "1,2,3")))
+
+(test hooks
+ (let (var)
+ (defun init-test-var () (setf var nil))
+ (defun test-fn1 () (push 1 var))
+ (defun test-fn2 () (push 2 var))
+ (defun test-fn3 () (push 3 var))
+ (defun test-fn4 (x) (push x var))
+ (defun get-test-var () var))
+ (progn
+ (init-test-var)
+ (add-hook 't1 #'test-fn1)
+ (add-hook 't1 #'test-fn2)
+ (add-hook 't1 #'test-fn3)
+ (run-hooks 't1)
+ (is (equal (get-test-var) '(3 2 1))))
+ (progn
+ (init-test-var)
+ (add-hook 't2 #'test-fn1)
+ (add-hook 't2 #'test-fn2)
+ (add-hook 't2 #'test-fn3)
+ (rem-hook 't2 #'test-fn2)
+ (run-hooks 't2)
+ (is (equal (get-test-var) '(3 1))))
+ (progn
+ (init-test-var)
+ (add-hook 't3 #'test-fn4)
+ (run-hook-with-args 't3 1)
+ (run-hook-with-args 't3 2)
+ (run-hook-with-args 't3 3)
+ (is (equal (get-test-var) '(3 2 1)))))
+
--- /dev/null
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (asdf:oos 'asdf:load-op :my-util-tests))
+
+(in-package :my-util-tests)
+
+; run all tests
+;(5am:run! 'my-util)
--- /dev/null
+
+
+
+
+
+
+Network Working Group N. Freed
+Request for Comments: 2045 Innosoft
+Obsoletes: 1521, 1522, 1590 N. Borenstein
+Category: Standards Track First Virtual
+ November 1996
+
+
+ Multipurpose Internet Mail Extensions
+ (MIME) Part One:
+ Format of Internet Message Bodies
+
+Status of this Memo
+
+ This document specifies an Internet standards track protocol for the
+ Internet community, and requests discussion and suggestions for
+ improvements. Please refer to the current edition of the "Internet
+ Official Protocol Standards" (STD 1) for the standardization state
+ and status of this protocol. Distribution of this memo is unlimited.
+
+Abstract
+
+ STD 11, RFC 822, defines a message representation protocol specifying
+ considerable detail about US-ASCII message headers, and leaves the
+ message content, or message body, as flat US-ASCII text. This set of
+ documents, collectively called the Multipurpose Internet Mail
+ Extensions, or MIME, redefines the format of messages to allow for
+
+ (1) textual message bodies in character sets other than
+ US-ASCII,
+
+ (2) an extensible set of different formats for non-textual
+ message bodies,
+
+ (3) multi-part message bodies, and
+
+ (4) textual header information in character sets other than
+ US-ASCII.
+
+ These documents are based on earlier work documented in RFC 934, STD
+ 11, and RFC 1049, but extends and revises them. Because RFC 822 said
+ so little about message bodies, these documents are largely
+ orthogonal to (rather than a revision of) RFC 822.
+
+ This initial document specifies the various headers used to describe
+ the structure of MIME messages. The second document, RFC 2046,
+ defines the general structure of the MIME media typing system and
+ defines an initial set of media types. The third document, RFC 2047,
+ describes extensions to RFC 822 to allow non-US-ASCII text data in
+
+
+
+Freed & Borenstein Standards Track [Page 1]
+\f
+RFC 2045 Internet Message Bodies November 1996
+
+
+ Internet mail header fields. The fourth document, RFC 2048, specifies
+ various IANA registration procedures for MIME-related facilities. The
+ fifth and final document, RFC 2049, describes MIME conformance
+ criteria as well as providing some illustrative examples of MIME
+ message formats, acknowledgements, and the bibliography.
+
+ These documents are revisions of RFCs 1521, 1522, and 1590, which
+ themselves were revisions of RFCs 1341 and 1342. An appendix in RFC
+ 2049 describes differences and changes from previous versions.
+
+Table of Contents
+
+ 1. Introduction ......................................... 3
+ 2. Definitions, Conventions, and Generic BNF Grammar .... 5
+ 2.1 CRLF ................................................ 5
+ 2.2 Character Set ....................................... 6
+ 2.3 Message ............................................. 6
+ 2.4 Entity .............................................. 6
+ 2.5 Body Part ........................................... 7
+ 2.6 Body ................................................ 7
+ 2.7 7bit Data ........................................... 7
+ 2.8 8bit Data ........................................... 7
+ 2.9 Binary Data ......................................... 7
+ 2.10 Lines .............................................. 7
+ 3. MIME Header Fields ................................... 8
+ 4. MIME-Version Header Field ............................ 8
+ 5. Content-Type Header Field ............................ 10
+ 5.1 Syntax of the Content-Type Header Field ............. 12
+ 5.2 Content-Type Defaults ............................... 14
+ 6. Content-Transfer-Encoding Header Field ............... 14
+ 6.1 Content-Transfer-Encoding Syntax .................... 14
+ 6.2 Content-Transfer-Encodings Semantics ................ 15
+ 6.3 New Content-Transfer-Encodings ...................... 16
+ 6.4 Interpretation and Use .............................. 16
+ 6.5 Translating Encodings ............................... 18
+ 6.6 Canonical Encoding Model ............................ 19
+ 6.7 Quoted-Printable Content-Transfer-Encoding .......... 19
+ 6.8 Base64 Content-Transfer-Encoding .................... 24
+ 7. Content-ID Header Field .............................. 26
+ 8. Content-Description Header Field ..................... 27
+ 9. Additional MIME Header Fields ........................ 27
+ 10. Summary ............................................. 27
+ 11. Security Considerations ............................. 27
+ 12. Authors' Addresses .................................. 28
+ A. Collected Grammar .................................... 29
+
+
+
+
+
+
+Freed & Borenstein Standards Track [Page 2]
+\f
+RFC 2045 Internet Message Bodies November 1996
+
+
+1. Introduction
+
+ Since its publication in 1982, RFC 822 has defined the standard
+ format of textual mail messages on the Internet. Its success has
+ been such that the RFC 822 format has been adopted, wholly or
+ partially, well beyond the confines of the Internet and the Internet
+ SMTP transport defined by RFC 821. As the format has seen wider use,
+ a number of limitations have proven increasingly restrictive for the
+ user community.
+
+ RFC 822 was intended to specify a format for text messages. As such,
+ non-text messages, such as multimedia messages that might include
+ audio or images, are simply not mentioned. Even in the case of text,
+ however, RFC 822 is inadequate for the needs of mail users whose
+ languages require the use of character sets richer than US-ASCII.
+ Since RFC 822 does not specify mechanisms for mail containing audio,
+ video, Asian language text, or even text in most European languages,
+ additional specifications are needed.
+
+ One of the notable limitations of RFC 821/822 based mail systems is
+ the fact that they limit the contents of electronic mail messages to
+ relatively short lines (e.g. 1000 characters or less [RFC-821]) of
+ 7bit US-ASCII. This forces users to convert any non-textual data
+ that they may wish to send into seven-bit bytes representable as
+ printable US-ASCII characters before invoking a local mail UA (User
+ Agent, a program with which human users send and receive mail).
+ Examples of such encodings currently used in the Internet include
+ pure hexadecimal, uuencode, the 3-in-4 base 64 scheme specified in
+ RFC 1421, the Andrew Toolkit Representation [ATK], and many others.
+
+ The limitations of RFC 822 mail become even more apparent as gateways
+ are designed to allow for the exchange of mail messages between RFC
+ 822 hosts and X.400 hosts. X.400 [X400] specifies mechanisms for the
+ inclusion of non-textual material within electronic mail messages.
+ The current standards for the mapping of X.400 messages to RFC 822
+ messages specify either that X.400 non-textual material must be
+ converted to (not encoded in) IA5Text format, or that they must be
+ discarded, notifying the RFC 822 user that discarding has occurred.
+ This is clearly undesirable, as information that a user may wish to
+ receive is lost. Even though a user agent may not have the
+ capability of dealing with the non-textual material, the user might
+ have some mechanism external to the UA that can extract useful
+ information from the material. Moreover, it does not allow for the
+ fact that the message may eventually be gatewayed back into an X.400
+ message handling system (i.e., the X.400 message is "tunneled"
+ through Internet mail), where the non-textual information would
+ definitely become useful again.
+
+
+
+
+Freed & Borenstein Standards Track [Page 3]
+\f
+RFC 2045 Internet Message Bodies November 1996
+
+
+ This document describes several mechanisms that combine to solve most
+ of these problems without introducing any serious incompatibilities
+ with the existing world of RFC 822 mail. In particular, it
+ describes:
+
+ (1) A MIME-Version header field, which uses a version
+ number to declare a message to be conformant with MIME
+ and allows mail processing agents to distinguish
+ between such messages and those generated by older or
+ non-conformant software, which are presumed to lack
+ such a field.
+
+ (2) A Content-Type header field, generalized from RFC 1049,
+ which can be used to specify the media type and subtype
+ of data in the body of a message and to fully specify
+ the native representation (canonical form) of such
+ data.
+
+ (3) A Content-Transfer-Encoding header field, which can be
+ used to specify both the encoding transformation that
+ was applied to the body and the domain of the result.
+ Encoding transformations other than the identity
+ transformation are usually applied to data in order to
+ allow it to pass through mail transport mechanisms
+ which may have data or character set limitations.
+
+ (4) Two additional header fields that can be used to
+ further describe the data in a body, the Content-ID and
+ Content-Description header fields.
+
+ All of the header fields defined in this document are subject to the
+ general syntactic rules for header fields specified in RFC 822. In
+ particular, all of these header fields except for Content-Disposition
+ can include RFC 822 comments, which have no semantic content and
+ should be ignored during MIME processing.
+
+ Finally, to specify and promote interoperability, RFC 2049 provides a
+ basic applicability statement for a subset of the above mechanisms
+ that defines a minimal level of "conformance" with this document.
+
+ HISTORICAL NOTE: Several of the mechanisms described in this set of
+ documents may seem somewhat strange or even baroque at first reading.
+ It is important to note that compatibility with existing standards
+ AND robustness across existing practice were two of the highest
+ priorities of the working group that developed this set of documents.
+ In particular, compatibility was always favored over elegance.
+
+
+
+
+
+Freed & Borenstein Standards Track [Page 4]
+\f
+RFC 2045 Internet Message Bodies November 1996
+
+
+ Please refer to the current edition of the "Internet Official
+ Protocol Standards" for the standardization state and status of this
+ protocol. RFC 822 and STD 3, RFC 1123 also provide essential
+ background for MIME since no conforming implementation of MIME can
+ violate them. In addition, several other informational RFC documents
+ will be of interest to the MIME implementor, in particular RFC 1344,
+ RFC 1345, and RFC 1524.
+
+2. Definitions, Conventions, and Generic BNF Grammar
+
+ Although the mechanisms specified in this set of documents are all
+ described in prose, most are also described formally in the augmented
+ BNF notation of RFC 822. Implementors will need to be familiar with
+ this notation in order to understand this set of documents, and are
+ referred to RFC 822 for a complete explanation of the augmented BNF
+ notation.
+
+ Some of the augmented BNF in this set of documents makes named
+ references to syntax rules defined in RFC 822. A complete formal
+ grammar, then, is obtained by combining the collected grammar
+ appendices in each document in this set with the BNF of RFC 822 plus
+ the modifications to RFC 822 defined in RFC 1123 (which specifically
+ changes the syntax for `return', `date' and `mailbox').
+
+ All numeric and octet values are given in decimal notation in this
+ set of documents. All media type values, subtype values, and
+ parameter names as defined are case-insensitive. However, parameter
+ values are case-sensitive unless otherwise specified for the specific
+ parameter.
+
+ FORMATTING NOTE: Notes, such at this one, provide additional
+ nonessential information which may be skipped by the reader without
+ missing anything essential. The primary purpose of these non-
+ essential notes is to convey information about the rationale of this
+ set of documents, or to place these documents in the proper
+ historical or evolutionary context. Such information may in
+ particular be skipped by those who are focused entirely on building a
+ conformant implementation, but may be of use to those who wish to
+ understand why certain design choices were made.
+
+2.1. CRLF
+
+ The term CRLF, in this set of documents, refers to the sequence of
+ octets corresponding to the two US-ASCII characters CR (decimal value
+ 13) and LF (decimal value 10) which, taken together, in this order,
+ denote a line break in RFC 822 mail.
+
+
+
+
+
+Freed & Borenstein Standards Track [Page 5]
+\f
+RFC 2045 Internet Message Bodies November 1996
+
+
+2.2. Character Set
+
+ The term "character set" is used in MIME to refer to a method of
+ converting a sequence of octets into a sequence of characters. Note
+ that unconditional and unambiguous conversion in the other direction
+ is not required, in that not all characters may be representable by a
+ given character set and a character set may provide more than one
+ sequence of octets to represent a particular sequence of characters.
+
+ This definition is intended to allow various kinds of character
+ encodings, from simple single-table mappings such as US-ASCII to
+ complex table switching methods such as those that use ISO 2022's
+ techniques, to be used as character sets. However, the definition
+ associated with a MIME character set name must fully specify the
+ mapping to be performed. In particular, use of external profiling
+ information to determine the exact mapping is not permitted.
+
+ NOTE: The term "character set" was originally to describe such
+ straightforward schemes as US-ASCII and ISO-8859-1 which have a
+ simple one-to-one mapping from single octets to single characters.
+ Multi-octet coded character sets and switching techniques make the
+ situation more complex. For example, some communities use the term
+ "character encoding" for what MIME calls a "character set", while
+ using the phrase "coded character set" to denote an abstract mapping
+ from integers (not octets) to characters.
+
+2.3. Message
+
+ The term "message", when not further qualified, means either a
+ (complete or "top-level") RFC 822 message being transferred on a
+ network, or a message encapsulated in a body of type "message/rfc822"
+ or "message/partial".
+
+2.4. Entity
+
+ The term "entity", refers specifically to the MIME-defined header
+ fields and contents of either a message or one of the parts in the
+ body of a multipart entity. The specification of such entities is
+ the essence of MIME. Since the contents of an entity are often
+ called the "body", it makes sense to speak about the body of an
+ entity. Any sort of field may be present in the header of an entity,
+ but only those fields whose names begin with "content-" actually have
+ any MIME-related meaning. Note that this does NOT imply thay they
+ have no meaning at all -- an entity that is also a message has non-
+ MIME header fields whose meanings are defined by RFC 822.
+
+
+
+
+
+
+Freed & Borenstein Standards Track [Page 6]
+\f
+RFC 2045 Internet Message Bodies November 1996
+
+
+2.5. Body Part
+
+ The term "body part" refers to an entity inside of a multipart
+ entity.
+
+2.6. Body
+
+ The term "body", when not further qualified, means the body of an
+ entity, that is, the body of either a message or of a body part.
+
+ NOTE: The previous four definitions are clearly circular. This is
+ unavoidable, since the overall structure of a MIME message is indeed
+ recursive.
+
+2.7. 7bit Data
+
+ "7bit data" refers to data that is all represented as relatively
+ short lines with 998 octets or less between CRLF line separation
+ sequences [RFC-821]. No octets with decimal values greater than 127
+ are allowed and neither are NULs (octets with decimal value 0). CR
+ (decimal value 13) and LF (decimal value 10) octets only occur as
+ part of CRLF line separation sequences.
+
+2.8. 8bit Data
+
+ "8bit data" refers to data that is all represented as relatively
+ short lines with 998 octets or less between CRLF line separation
+ sequences [RFC-821]), but octets with decimal values greater than 127
+ may be used. As with "7bit data" CR and LF octets only occur as part
+ of CRLF line separation sequences and no NULs are allowed.
+
+2.9. Binary Data
+
+ "Binary data" refers to data where any sequence of octets whatsoever
+ is allowed.
+
+2.10. Lines
+
+ "Lines" are defined as sequences of octets separated by a CRLF
+ sequences. This is consistent with both RFC 821 and RFC 822.
+ "Lines" only refers to a unit of data in a message, which may or may
+ not correspond to something that is actually displayed by a user
+ agent.
+
+
+
+
+
+
+
+
+Freed & Borenstein Standards Track [Page 7]
+\f
+RFC 2045 Internet Message Bodies November 1996
+
+
+3. MIME Header Fields
+
+ MIME defines a number of new RFC 822 header fields that are used to
+ describe the content of a MIME entity. These header fields occur in
+ at least two contexts:
+
+ (1) As part of a regular RFC 822 message header.
+
+ (2) In a MIME body part header within a multipart
+ construct.
+
+ The formal definition of these header fields is as follows:
+
+ entity-headers := [ content CRLF ]
+ [ encoding CRLF ]
+ [ id CRLF ]
+ [ description CRLF ]
+ *( MIME-extension-field CRLF )
+
+ MIME-message-headers := entity-headers
+ fields
+ version CRLF
+ ; The ordering of the header
+ ; fields implied by this BNF
+ ; definition should be ignored.
+
+ MIME-part-headers := entity-headers
+ [ fields ]
+ ; Any field not beginning with
+ ; "content-" can have no defined
+ ; meaning and may be ignored.
+ ; The ordering of the header
+ ; fields implied by this BNF
+ ; definition should be ignored.
+
+ The syntax of the various specific MIME header fields will be
+ described in the following sections.
+
+4. MIME-Version Header Field
+
+ Since RFC 822 was published in 1982, there has really been only one
+ format standard for Internet messages, and there has been little
+ perceived need to declare the format standard in use. This document
+ is an independent specification that complements RFC 822. Although
+ the extensions in this document have been defined in such a way as to
+ be compatible with RFC 822, there are still circumstances in which it
+ might be desirable for a mail-processing agent to know whether a
+ message was composed with the new standard in mind.
+
+
+
+Freed & Borenstein Standards Track [Page 8]
+\f
+RFC 2045 Internet Message Bodies November 1996
+
+
+ Therefore, this document defines a new header field, "MIME-Version",
+ which is to be used to declare the version of the Internet message
+ body format standard in use.
+
+ Messages composed in accordance with this document MUST include such
+ a header field, with the following verbatim text:
+
+ MIME-Version: 1.0
+
+ The presence of this header field is an assertion that the message
+ has been composed in compliance with this document.
+
+ Since it is possible that a future document might extend the message
+ format standard again, a formal BNF is given for the content of the
+ MIME-Version field:
+
+ version := "MIME-Version" ":" 1*DIGIT "." 1*DIGIT
+
+ Thus, future format specifiers, which might replace or extend "1.0",
+ are constrained to be two integer fields, separated by a period. If
+ a message is received with a MIME-version value other than "1.0", it
+ cannot be assumed to conform with this document.
+
+ Note that the MIME-Version header field is required at the top level
+ of a message. It is not required for each body part of a multipart
+ entity. It is required for the embedded headers of a body of type
+ "message/rfc822" or "message/partial" if and only if the embedded
+ message is itself claimed to be MIME-conformant.
+
+ It is not possible to fully specify how a mail reader that conforms
+ with MIME as defined in this document should treat a message that
+ might arrive in the future with some value of MIME-Version other than
+ "1.0".
+
+ It is also worth noting that version control for specific media types
+ is not accomplished using the MIME-Version mechanism. In particular,
+ some formats (such as application/postscript) have version numbering
+ conventions that are internal to the media format. Where such
+ conventions exist, MIME does nothing to supersede them. Where no
+ such conventions exist, a MIME media type might use a "version"
+ parameter in the content-type field if necessary.
+
+
+
+
+
+
+
+
+
+
+Freed & Borenstein Standards Track [Page 9]
+\f
+RFC 2045 Internet Message Bodies November 1996
+
+
+ NOTE TO IMPLEMENTORS: When checking MIME-Version values any RFC 822
+ comment strings that are present must be ignored. In particular, the
+ following four MIME-Version fields are equivalent:
+
+ MIME-Version: 1.0
+
+ MIME-Version: 1.0 (produced by MetaSend Vx.x)
+
+ MIME-Version: (produced by MetaSend Vx.x) 1.0
+
+ MIME-Version: 1.(produced by MetaSend Vx.x)0
+
+ In the absence of a MIME-Version field, a receiving mail user agent
+ (whether conforming to MIME requirements or not) may optionally
+ choose to interpret the body of the message according to local
+ conventions. Many such conventions are currently in use and it
+ should be noted that in practice non-MIME messages can contain just
+ about anything.
+
+ It is impossible to be certain that a non-MIME mail message is
+ actually plain text in the US-ASCII character set since it might well
+ be a message that, using some set of nonstandard local conventions
+ that predate MIME, includes text in another character set or non-
+ textual data presented in a manner that cannot be automatically
+ recognized (e.g., a uuencoded compressed UNIX tar file).
+
+5. Content-Type Header Field
+
+ The purpose of the Content-Type field is to describe the data
+ contained in the body fully enough that the receiving user agent can
+ pick an appropriate agent or mechanism to present the data to the
+ user, or otherwise deal with the data in an appropriate manner. The
+ value in this field is called a media type.
+
+ HISTORICAL NOTE: The Content-Type header field was first defined in
+ RFC 1049. RFC 1049 used a simpler and less powerful syntax, but one
+ that is largely compatible with the mechanism given here.
+
+ The Content-Type header field specifies the nature of the data in the
+ body of an entity by giving media type and subtype identifiers, and
+ by providing auxiliary information that may be required for certain
+ media types. After the media type and subtype names, the remainder
+ of the header field is simply a set of parameters, specified in an
+ attribute=value notation. The ordering of parameters is not
+ significant.
+
+
+
+
+
+
+Freed & Borenstein Standards Track [Page 10]
+\f
+RFC 2045 Internet Message Bodies November 1996
+
+
+ In general, the top-level media type is used to declare the general
+ type of data, while the subtype specifies a specific format for that
+ type of data. Thus, a media type of "image/xyz" is enough to tell a
+ user agent that the data is an image, even if the user agent has no
+ knowledge of the specific image format "xyz". Such information can
+ be used, for example, to decide whether or not to show a user the raw
+ data from an unrecognized subtype -- such an action might be
+ reasonable for unrecognized subtypes of text, but not for
+ unrecognized subtypes of image or audio. For this reason, registered
+ subtypes of text, image, audio, and video should not contain embedded
+ information that is really of a different type. Such compound
+ formats should be represented using the "multipart" or "application"
+ types.
+
+ Parameters are modifiers of the media subtype, and as such do not
+ fundamentally affect the nature of the content. The set of
+ meaningful parameters depends on the media type and subtype. Most
+ parameters are associated with a single specific subtype. However, a
+ given top-level media type may define parameters which are applicable
+ to any subtype of that type. Parameters may be required by their
+ defining content type or subtype or they may be optional. MIME
+ implementations must ignore any parameters whose names they do not
+ recognize.
+
+ For example, the "charset" parameter is applicable to any subtype of
+ "text", while the "boundary" parameter is required for any subtype of
+ the "multipart" media type.
+
+ There are NO globally-meaningful parameters that apply to all media
+ types. Truly global mechanisms are best addressed, in the MIME
+ model, by the definition of additional Content-* header fields.
+
+ An initial set of seven top-level media types is defined in RFC 2046.
+ Five of these are discrete types whose content is essentially opaque
+ as far as MIME processing is concerned. The remaining two are
+ composite types whose contents require additional handling by MIME
+ processors.
+
+ This set of top-level media types is intended to be substantially
+ complete. It is expected that additions to the larger set of
+ supported types can generally be accomplished by the creation of new
+ subtypes of these initial types. In the future, more top-level types
+ may be defined only by a standards-track extension to this standard.
+ If another top-level type is to be used for any reason, it must be
+ given a name starting with "X-" to indicate its non-standard status
+ and to avoid a potential conflict with a future official name.
+
+
+
+
+
+Freed & Borenstein Standards Track [Page 11]
+\f
+RFC 2045 Internet Message Bodies November 1996
+
+
+5.1. Syntax of the Content-Type Header Field
+
+ In the Augmented BNF notation of RFC 822, a Content-Type header field
+ value is defined as follows:
+
+ content := "Content-Type" ":" type "/" subtype
+ *(";" parameter)
+ ; Matching of media type and subtype
+ ; is ALWAYS case-insensitive.
+
+ type := discrete-type / composite-type
+
+ discrete-type := "text" / "image" / "audio" / "video" /
+ "application" / extension-token
+
+ composite-type := "message" / "multipart" / extension-token
+
+ extension-token := ietf-token / x-token
+
+ ietf-token := <An extension token defined by a
+ standards-track RFC and registered
+ with IANA.>
+
+ x-token := <The two characters "X-" or "x-" followed, with
+ no intervening white space, by any token>
+
+ subtype := extension-token / iana-token
+
+ iana-token := <A publicly-defined extension token. Tokens
+ of this form must be registered with IANA
+ as specified in RFC 2048.>
+
+ parameter := attribute "=" value
+
+ attribute := token
+ ; Matching of attributes
+ ; is ALWAYS case-insensitive.
+
+ value := token / quoted-string
+
+ token := 1*<any (US-ASCII) CHAR except SPACE, CTLs,
+ or tspecials>
+
+ tspecials := "(" / ")" / "<" / ">" / "@" /
+ "," / ";" / ":" / "\" / <">
+ "/" / "[" / "]" / "?" / "="
+ ; Must be in quoted-string,
+ ; to use within parameter values
+
+
+
+Freed & Borenstein Standards Track [Page 12]
+\f
+RFC 2045 Internet Message Bodies November 1996
+
+
+ Note that the definition of "tspecials" is the same as the RFC 822
+ definition of "specials" with the addition of the three characters
+ "/", "?", and "=", and the removal of ".".
+
+ Note also that a subtype specification is MANDATORY -- it may not be
+ omitted from a Content-Type header field. As such, there are no
+ default subtypes.
+
+ The type, subtype, and parameter names are not case sensitive. For
+ example, TEXT, Text, and TeXt are all equivalent top-level media
+ types. Parameter values are normally case sensitive, but sometimes
+ are interpreted in a case-insensitive fashion, depending on the
+ intended use. (For example, multipart boundaries are case-sensitive,
+ but the "access-type" parameter for message/External-body is not
+ case-sensitive.)
+
+ Note that the value of a quoted string parameter does not include the
+ quotes. That is, the quotation marks in a quoted-string are not a
+ part of the value of the parameter, but are merely used to delimit
+ that parameter value. In addition, comments are allowed in
+ accordance with RFC 822 rules for structured header fields. Thus the
+ following two forms
+
+ Content-type: text/plain; charset=us-ascii (Plain text)
+
+ Content-type: text/plain; charset="us-ascii"
+
+ are completely equivalent.
+
+ Beyond this syntax, the only syntactic constraint on the definition
+ of subtype names is the desire that their uses must not conflict.
+ That is, it would be undesirable to have two different communities
+ using "Content-Type: application/foobar" to mean two different
+ things. The process of defining new media subtypes, then, is not
+ intended to be a mechanism for imposing restrictions, but simply a
+ mechanism for publicizing their definition and usage. There are,
+ therefore, two acceptable mechanisms for defining new media subtypes:
+
+ (1) Private values (starting with "X-") may be defined
+ bilaterally between two cooperating agents without
+ outside registration or standardization. Such values
+ cannot be registered or standardized.
+
+ (2) New standard values should be registered with IANA as
+ described in RFC 2048.
+
+ The second document in this set, RFC 2046, defines the initial set of
+ media types for MIME.
+
+
+
+Freed & Borenstein Standards Track [Page 13]
+\f
+RFC 2045 Internet Message Bodies November 1996
+
+
+5.2. Content-Type Defaults
+
+ Default RFC 822 messages without a MIME Content-Type header are taken
+ by this protocol to be plain text in the US-ASCII character set,
+ which can be explicitly specified as:
+
+ Content-type: text/plain; charset=us-ascii
+
+ This default is assumed if no Content-Type header field is specified.
+ It is also recommend that this default be assumed when a
+ syntactically invalid Content-Type header field is encountered. In
+ the presence of a MIME-Version header field and the absence of any
+ Content-Type header field, a receiving User Agent can also assume
+ that plain US-ASCII text was the sender's intent. Plain US-ASCII
+ text may still be assumed in the absence of a MIME-Version or the
+ presence of an syntactically invalid Content-Type header field, but
+ the sender's intent might have been otherwise.
+
+6. Content-Transfer-Encoding Header Field
+
+ Many media types which could be usefully transported via email are
+ represented, in their "natural" format, as 8bit character or binary
+ data. Such data cannot be transmitted over some transfer protocols.
+ For example, RFC 821 (SMTP) restricts mail messages to 7bit US-ASCII
+ data with lines no longer than 1000 characters including any trailing
+ CRLF line separator.
+
+ It is necessary, therefore, to define a standard mechanism for
+ encoding such data into a 7bit short line format. Proper labelling
+ of unencoded material in less restrictive formats for direct use over
+ less restrictive transports is also desireable. This document
+ specifies that such encodings will be indicated by a new "Content-
+ Transfer-Encoding" header field. This field has not been defined by
+ any previous standard.
+
+6.1. Content-Transfer-Encoding Syntax
+
+ The Content-Transfer-Encoding field's value is a single token
+ specifying the type of encoding, as enumerated below. Formally:
+
+ encoding := "Content-Transfer-Encoding" ":" mechanism
+
+ mechanism := "7bit" / "8bit" / "binary" /
+ "quoted-printable" / "base64" /
+ ietf-token / x-token
+
+ These values are not case sensitive -- Base64 and BASE64 and bAsE64
+ are all equivalent. An encoding type of 7BIT requires that the body
+
+
+
+Freed & Borenstein Standards Track [Page 14]
+\f
+RFC 2045 Internet Message Bodies November 1996
+
+
+ is already in a 7bit mail-ready representation. This is the default
+ value -- that is, "Content-Transfer-Encoding: 7BIT" is assumed if the
+ Content-Transfer-Encoding header field is not present.
+
+6.2. Content-Transfer-Encodings Semantics
+
+ This single Content-Transfer-Encoding token actually provides two
+ pieces of information. It specifies what sort of encoding
+ transformation the body was subjected to and hence what decoding
+ operation must be used to restore it to its original form, and it
+ specifies what the domain of the result is.
+
+ The transformation part of any Content-Transfer-Encodings specifies,
+ either explicitly or implicitly, a single, well-defined decoding
+ algorithm, which for any sequence of encoded octets either transforms
+ it to the original sequence of octets which was encoded, or shows
+ that it is illegal as an encoded sequence. Content-Transfer-
+ Encodings transformations never depend on any additional external
+ profile information for proper operation. Note that while decoders
+ must produce a single, well-defined output for a valid encoding no
+ such restrictions exist for encoders: Encoding a given sequence of
+ octets to different, equivalent encoded sequences is perfectly legal.
+
+ Three transformations are currently defined: identity, the "quoted-
+ printable" encoding, and the "base64" encoding. The domains are
+ "binary", "8bit" and "7bit".
+
+ The Content-Transfer-Encoding values "7bit", "8bit", and "binary" all
+ mean that the identity (i.e. NO) encoding transformation has been
+ performed. As such, they serve simply as indicators of the domain of
+ the body data, and provide useful information about the sort of
+ encoding that might be needed for transmission in a given transport
+ system. The terms "7bit data", "8bit data", and "binary data" are
+ all defined in Section 2.
+
+ The quoted-printable and base64 encodings transform their input from
+ an arbitrary domain into material in the "7bit" range, thus making it
+ safe to carry over restricted transports. The specific definition of
+ the transformations are given below.
+
+ The proper Content-Transfer-Encoding label must always be used.
+ Labelling unencoded data containing 8bit characters as "7bit" is not
+ allowed, nor is labelling unencoded non-line-oriented data as
+ anything other than "binary" allowed.
+
+ Unlike media subtypes, a proliferation of Content-Transfer-Encoding
+ values is both undesirable and unnecessary. However, establishing
+ only a single transformation into the "7bit" domain does not seem
+
+
+
+Freed & Borenstein Standards Track [Page 15]
+\f
+RFC 2045 Internet Message Bodies November 1996
+
+
+ possible. There is a tradeoff between the desire for a compact and
+ efficient encoding of largely- binary data and the desire for a
+ somewhat readable encoding of data that is mostly, but not entirely,
+ 7bit. For this reason, at least two encoding mechanisms are
+ necessary: a more or less readable encoding (quoted-printable) and a
+ "dense" or "uniform" encoding (base64).
+
+ Mail transport for unencoded 8bit data is defined in RFC 1652. As of
+ the initial publication of this document, there are no standardized
+ Internet mail transports for which it is legitimate to include
+ unencoded binary data in mail bodies. Thus there are no
+ circumstances in which the "binary" Content-Transfer-Encoding is
+ actually valid in Internet mail. However, in the event that binary
+ mail transport becomes a reality in Internet mail, or when MIME is
+ used in conjunction with any other binary-capable mail transport
+ mechanism, binary bodies must be labelled as such using this
+ mechanism.
+
+ NOTE: The five values defined for the Content-Transfer-Encoding field
+ imply nothing about the media type other than the algorithm by which
+ it was encoded or the transport system requirements if unencoded.
+
+6.3. New Content-Transfer-Encodings
+
+ Implementors may, if necessary, define private Content-Transfer-
+ Encoding values, but must use an x-token, which is a name prefixed by
+ "X-", to indicate its non-standard status, e.g., "Content-Transfer-
+ Encoding: x-my-new-encoding". Additional standardized Content-
+ Transfer-Encoding values must be specified by a standards-track RFC.
+ The requirements such specifications must meet are given in RFC 2048.
+ As such, all content-transfer-encoding namespace except that
+ beginning with "X-" is explicitly reserved to the IETF for future
+ use.
+
+ Unlike media types and subtypes, the creation of new Content-
+ Transfer-Encoding values is STRONGLY discouraged, as it seems likely
+ to hinder interoperability with little potential benefit
+
+6.4. Interpretation and Use
+
+ If a Content-Transfer-Encoding header field appears as part of a
+ message header, it applies to the entire body of that message. If a
+ Content-Transfer-Encoding header field appears as part of an entity's
+ headers, it applies only to the body of that entity. If an entity is
+ of type "multipart" the Content-Transfer-Encoding is not permitted to
+ have any value other than "7bit", "8bit" or "binary". Even more
+ severe restrictions apply to some subtypes of the "message" type.
+
+
+
+
+Freed & Borenstein Standards Track [Page 16]
+\f
+RFC 2045 Internet Message Bodies November 1996
+
+
+ It should be noted that most media types are defined in terms of
+ octets rather than bits, so that the mechanisms described here are
+ mechanisms for encoding arbitrary octet streams, not bit streams. If
+ a bit stream is to be encoded via one of these mechanisms, it must
+ first be converted to an 8bit byte stream using the network standard
+ bit order ("big-endian"), in which the earlier bits in a stream
+ become the higher-order bits in a 8bit byte. A bit stream not ending
+ at an 8bit boundary must be padded with zeroes. RFC 2046 provides a
+ mechanism for noting the addition of such padding in the case of the
+ application/octet-stream media type, which has a "padding" parameter.
+
+ The encoding mechanisms defined here explicitly encode all data in
+ US-ASCII. Thus, for example, suppose an entity has header fields
+ such as:
+
+ Content-Type: text/plain; charset=ISO-8859-1
+ Content-transfer-encoding: base64
+
+ This must be interpreted to mean that the body is a base64 US-ASCII
+ encoding of data that was originally in ISO-8859-1, and will be in
+ that character set again after decoding.
+
+ Certain Content-Transfer-Encoding values may only be used on certain
+ media types. In particular, it is EXPRESSLY FORBIDDEN to use any
+ encodings other than "7bit", "8bit", or "binary" with any composite
+ media type, i.e. one that recursively includes other Content-Type
+ fields. Currently the only composite media types are "multipart" and
+ "message". All encodings that are desired for bodies of type
+ multipart or message must be done at the innermost level, by encoding
+ the actual body that needs to be encoded.
+
+ It should also be noted that, by definition, if a composite entity
+ has a transfer-encoding value such as "7bit", but one of the enclosed
+ entities has a less restrictive value such as "8bit", then either the
+ outer "7bit" labelling is in error, because 8bit data are included,
+ or the inner "8bit" labelling placed an unnecessarily high demand on
+ the transport system because the actual included data were actually
+ 7bit-safe.
+
+ NOTE ON ENCODING RESTRICTIONS: Though the prohibition against using
+ content-transfer-encodings on composite body data may seem overly
+ restrictive, it is necessary to prevent nested encodings, in which
+ data are passed through an encoding algorithm multiple times, and
+ must be decoded multiple times in order to be properly viewed.
+ Nested encodings add considerable complexity to user agents: Aside
+ from the obvious efficiency problems with such multiple encodings,
+ they can obscure the basic structure of a message. In particular,
+ they can imply that several decoding operations are necessary simply
+
+
+
+Freed & Borenstein Standards Track [Page 17]
+\f
+RFC 2045 Internet Message Bodies November 1996
+
+
+ to find out what types of bodies a message contains. Banning nested
+ encodings may complicate the job of certain mail gateways, but this
+ seems less of a problem than the effect of nested encodings on user
+ agents.
+
+ Any entity with an unrecognized Content-Transfer-Encoding must be
+ treated as if it has a Content-Type of "application/octet-stream",
+ regardless of what the Content-Type header field actually says.
+
+ NOTE ON THE RELATIONSHIP BETWEEN CONTENT-TYPE AND CONTENT-TRANSFER-
+ ENCODING: It may seem that the Content-Transfer-Encoding could be
+ inferred from the characteristics of the media that is to be encoded,
+ or, at the very least, that certain Content-Transfer-Encodings could
+ be mandated for use with specific media types. There are several
+ reasons why this is not the case. First, given the varying types of
+ transports used for mail, some encodings may be appropriate for some
+ combinations of media types and transports but not for others. (For
+ example, in an 8bit transport, no encoding would be required for text
+ in certain character sets, while such encodings are clearly required
+ for 7bit SMTP.)
+
+ Second, certain media types may require different types of transfer
+ encoding under different circumstances. For example, many PostScript
+ bodies might consist entirely of short lines of 7bit data and hence
+ require no encoding at all. Other PostScript bodies (especially
+ those using Level 2 PostScript's binary encoding mechanism) may only
+ be reasonably represented using a binary transport encoding.
+ Finally, since the Content-Type field is intended to be an open-ended
+ specification mechanism, strict specification of an association
+ between media types and encodings effectively couples the
+ specification of an application protocol with a specific lower-level
+ transport. This is not desirable since the developers of a media
+ type should not have to be aware of all the transports in use and
+ what their limitations are.
+
+6.5. Translating Encodings
+
+ The quoted-printable and base64 encodings are designed so that
+ conversion between them is possible. The only issue that arises in
+ such a conversion is the handling of hard line breaks in quoted-
+ printable encoding output. When converting from quoted-printable to
+ base64 a hard line break in the quoted-printable form represents a
+ CRLF sequence in the canonical form of the data. It must therefore be
+ converted to a corresponding encoded CRLF in the base64 form of the
+ data. Similarly, a CRLF sequence in the canonical form of the data
+ obtained after base64 decoding must be converted to a quoted-
+ printable hard line break, but ONLY when converting text data.
+
+
+
+
+Freed & Borenstein Standards Track [Page 18]
+\f
+RFC 2045 Internet Message Bodies November 1996
+
+
+6.6. Canonical Encoding Model
+
+ There was some confusion, in the previous versions of this RFC,
+ regarding the model for when email data was to be converted to
+ canonical form and encoded, and in particular how this process would
+ affect the treatment of CRLFs, given that the representation of
+ newlines varies greatly from system to system, and the relationship
+ between content-transfer-encodings and character sets. A canonical
+ model for encoding is presented in RFC 2049 for this reason.
+
+6.7. Quoted-Printable Content-Transfer-Encoding
+
+ The Quoted-Printable encoding is intended to represent data that
+ largely consists of octets that correspond to printable characters in
+ the US-ASCII character set. It encodes the data in such a way that
+ the resulting octets are unlikely to be modified by mail transport.
+ If the data being encoded are mostly US-ASCII text, the encoded form
+ of the data remains largely recognizable by humans. A body which is
+ entirely US-ASCII may also be encoded in Quoted-Printable to ensure
+ the integrity of the data should the message pass through a
+ character-translating, and/or line-wrapping gateway.
+
+ In this encoding, octets are to be represented as determined by the
+ following rules:
+
+ (1) (General 8bit representation) Any octet, except a CR or
+ LF that is part of a CRLF line break of the canonical
+ (standard) form of the data being encoded, may be
+ represented by an "=" followed by a two digit
+ hexadecimal representation of the octet's value. The
+ digits of the hexadecimal alphabet, for this purpose,
+ are "0123456789ABCDEF". Uppercase letters must be
+ used; lowercase letters are not allowed. Thus, for
+ example, the decimal value 12 (US-ASCII form feed) can
+ be represented by "=0C", and the decimal value 61 (US-
+ ASCII EQUAL SIGN) can be represented by "=3D". This
+ rule must be followed except when the following rules
+ allow an alternative encoding.
+
+ (2) (Literal representation) Octets with decimal values of
+ 33 through 60 inclusive, and 62 through 126, inclusive,
+ MAY be represented as the US-ASCII characters which
+ correspond to those octets (EXCLAMATION POINT through
+ LESS THAN, and GREATER THAN through TILDE,
+ respectively).
+
+ (3) (White Space) Octets with values of 9 and 32 MAY be
+ represented as US-ASCII TAB (HT) and SPACE characters,
+
+
+
+Freed & Borenstein Standards Track [Page 19]
+\f
+RFC 2045 Internet Message Bodies November 1996
+
+
+ respectively, but MUST NOT be so represented at the end
+ of an encoded line. Any TAB (HT) or SPACE characters
+ on an encoded line MUST thus be followed on that line
+ by a printable character. In particular, an "=" at the
+ end of an encoded line, indicating a soft line break
+ (see rule #5) may follow one or more TAB (HT) or SPACE
+ characters. It follows that an octet with decimal
+ value 9 or 32 appearing at the end of an encoded line
+ must be represented according to Rule #1. This rule is
+ necessary because some MTAs (Message Transport Agents,
+ programs which transport messages from one user to
+ another, or perform a portion of such transfers) are
+ known to pad lines of text with SPACEs, and others are
+ known to remove "white space" characters from the end
+ of a line. Therefore, when decoding a Quoted-Printable
+ body, any trailing white space on a line must be
+ deleted, as it will necessarily have been added by
+ intermediate transport agents.
+
+ (4) (Line Breaks) A line break in a text body, represented
+ as a CRLF sequence in the text canonical form, must be
+ represented by a (RFC 822) line break, which is also a
+ CRLF sequence, in the Quoted-Printable encoding. Since
+ the canonical representation of media types other than
+ text do not generally include the representation of
+ line breaks as CRLF sequences, no hard line breaks
+ (i.e. line breaks that are intended to be meaningful
+ and to be displayed to the user) can occur in the
+ quoted-printable encoding of such types. Sequences
+ like "=0D", "=0A", "=0A=0D" and "=0D=0A" will routinely
+ appear in non-text data represented in quoted-
+ printable, of course.
+
+ Note that many implementations may elect to encode the
+ local representation of various content types directly
+ rather than converting to canonical form first,
+ encoding, and then converting back to local
+ representation. In particular, this may apply to plain
+ text material on systems that use newline conventions
+ other than a CRLF terminator sequence. Such an
+ implementation optimization is permissible, but only
+ when the combined canonicalization-encoding step is
+ equivalent to performing the three steps separately.
+
+ (5) (Soft Line Breaks) The Quoted-Printable encoding
+ REQUIRES that encoded lines be no more than 76
+ characters long. If longer lines are to be encoded
+ with the Quoted-Printable encoding, "soft" line breaks
+
+
+
+Freed & Borenstein Standards Track [Page 20]
+\f
+RFC 2045 Internet Message Bodies November 1996
+
+
+ must be used. An equal sign as the last character on a
+ encoded line indicates such a non-significant ("soft")
+ line break in the encoded text.
+
+ Thus if the "raw" form of the line is a single unencoded line that
+ says:
+
+ Now's the time for all folk to come to the aid of their country.
+
+ This can be represented, in the Quoted-Printable encoding, as:
+
+ Now's the time =
+ for all folk to come=
+ to the aid of their country.
+
+ This provides a mechanism with which long lines are encoded in such a
+ way as to be restored by the user agent. The 76 character limit does
+ not count the trailing CRLF, but counts all other characters,
+ including any equal signs.
+
+ Since the hyphen character ("-") may be represented as itself in the
+ Quoted-Printable encoding, care must be taken, when encapsulating a
+ quoted-printable encoded body inside one or more multipart entities,
+ to ensure that the boundary delimiter does not appear anywhere in the
+ encoded body. (A good strategy is to choose a boundary that includes
+ a character sequence such as "=_" which can never appear in a
+ quoted-printable body. See the definition of multipart messages in
+ RFC 2046.)
+
+ NOTE: The quoted-printable encoding represents something of a
+ compromise between readability and reliability in transport. Bodies
+ encoded with the quoted-printable encoding will work reliably over
+ most mail gateways, but may not work perfectly over a few gateways,
+ notably those involving translation into EBCDIC. A higher level of
+ confidence is offered by the base64 Content-Transfer-Encoding. A way
+ to get reasonably reliable transport through EBCDIC gateways is to
+ also quote the US-ASCII characters
+
+ !"#$@[\]^`{|}~
+
+ according to rule #1.
+
+ Because quoted-printable data is generally assumed to be line-
+ oriented, it is to be expected that the representation of the breaks
+ between the lines of quoted-printable data may be altered in
+ transport, in the same manner that plain text mail has always been
+ altered in Internet mail when passing between systems with differing
+ newline conventions. If such alterations are likely to constitute a
+
+
+
+Freed & Borenstein Standards Track [Page 21]
+\f
+RFC 2045 Internet Message Bodies November 1996
+
+
+ corruption of the data, it is probably more sensible to use the
+ base64 encoding rather than the quoted-printable encoding.
+
+ NOTE: Several kinds of substrings cannot be generated according to
+ the encoding rules for the quoted-printable content-transfer-
+ encoding, and hence are formally illegal if they appear in the output
+ of a quoted-printable encoder. This note enumerates these cases and
+ suggests ways to handle such illegal substrings if any are
+ encountered in quoted-printable data that is to be decoded.
+
+ (1) An "=" followed by two hexadecimal digits, one or both
+ of which are lowercase letters in "abcdef", is formally
+ illegal. A robust implementation might choose to
+ recognize them as the corresponding uppercase letters.
+
+ (2) An "=" followed by a character that is neither a
+ hexadecimal digit (including "abcdef") nor the CR
+ character of a CRLF pair is illegal. This case can be
+ the result of US-ASCII text having been included in a
+ quoted-printable part of a message without itself
+ having been subjected to quoted-printable encoding. A
+ reasonable approach by a robust implementation might be
+ to include the "=" character and the following
+ character in the decoded data without any
+ transformation and, if possible, indicate to the user
+ that proper decoding was not possible at this point in
+ the data.
+
+ (3) An "=" cannot be the ultimate or penultimate character
+ in an encoded object. This could be handled as in case
+ (2) above.
+
+ (4) Control characters other than TAB, or CR and LF as
+ parts of CRLF pairs, must not appear. The same is true
+ for octets with decimal values greater than 126. If
+ found in incoming quoted-printable data by a decoder, a
+ robust implementation might exclude them from the
+ decoded data and warn the user that illegal characters
+ were discovered.
+
+ (5) Encoded lines must not be longer than 76 characters,
+ not counting the trailing CRLF. If longer lines are
+ found in incoming, encoded data, a robust
+ implementation might nevertheless decode the lines, and
+ might report the erroneous encoding to the user.
+
+
+
+
+
+
+Freed & Borenstein Standards Track [Page 22]
+\f
+RFC 2045 Internet Message Bodies November 1996
+
+
+ WARNING TO IMPLEMENTORS: If binary data is encoded in quoted-
+ printable, care must be taken to encode CR and LF characters as "=0D"
+ and "=0A", respectively. In particular, a CRLF sequence in binary
+ data should be encoded as "=0D=0A". Otherwise, if CRLF were
+ represented as a hard line break, it might be incorrectly decoded on
+ platforms with different line break conventions.
+
+ For formalists, the syntax of quoted-printable data is described by
+ the following grammar:
+
+ quoted-printable := qp-line *(CRLF qp-line)
+
+ qp-line := *(qp-segment transport-padding CRLF)
+ qp-part transport-padding
+
+ qp-part := qp-section
+ ; Maximum length of 76 characters
+
+ qp-segment := qp-section *(SPACE / TAB) "="
+ ; Maximum length of 76 characters
+
+ qp-section := [*(ptext / SPACE / TAB) ptext]
+
+ ptext := hex-octet / safe-char
+
+ safe-char := <any octet with decimal value of 33 through
+ 60 inclusive, and 62 through 126>
+ ; Characters not listed as "mail-safe" in
+ ; RFC 2049 are also not recommended.
+
+ hex-octet := "=" 2(DIGIT / "A" / "B" / "C" / "D" / "E" / "F")
+ ; Octet must be used for characters > 127, =,
+ ; SPACEs or TABs at the ends of lines, and is
+ ; recommended for any character not listed in
+ ; RFC 2049 as "mail-safe".
+
+ transport-padding := *LWSP-char
+ ; Composers MUST NOT generate
+ ; non-zero length transport
+ ; padding, but receivers MUST
+ ; be able to handle padding
+ ; added by message transports.
+
+ IMPORTANT: The addition of LWSP between the elements shown in this
+ BNF is NOT allowed since this BNF does not specify a structured
+ header field.
+
+
+
+
+
+Freed & Borenstein Standards Track [Page 23]
+\f
+RFC 2045 Internet Message Bodies November 1996
+
+
+6.8. Base64 Content-Transfer-Encoding
+
+ The Base64 Content-Transfer-Encoding is designed to represent
+ arbitrary sequences of octets in a form that need not be humanly
+ readable. The encoding and decoding algorithms are simple, but the
+ encoded data are consistently only about 33 percent larger than the
+ unencoded data. This encoding is virtually identical to the one used
+ in Privacy Enhanced Mail (PEM) applications, as defined in RFC 1421.
+
+ A 65-character subset of US-ASCII is used, enabling 6 bits to be
+ represented per printable character. (The extra 65th character, "=",
+ is used to signify a special processing function.)
+
+ NOTE: This subset has the important property that it is represented
+ identically in all versions of ISO 646, including US-ASCII, and all
+ characters in the subset are also represented identically in all
+ versions of EBCDIC. Other popular encodings, such as the encoding
+ used by the uuencode utility, Macintosh binhex 4.0 [RFC-1741], and
+ the base85 encoding specified as part of Level 2 PostScript, do not
+ share these properties, and thus do not fulfill the portability
+ requirements a binary transport encoding for mail must meet.
+
+ The encoding process represents 24-bit groups of input bits as output
+ strings of 4 encoded characters. Proceeding from left to right, a
+ 24-bit input group is formed by concatenating 3 8bit input groups.
+ These 24 bits are then treated as 4 concatenated 6-bit groups, each
+ of which is translated into a single digit in the base64 alphabet.
+ When encoding a bit stream via the base64 encoding, the bit stream
+ must be presumed to be ordered with the most-significant-bit first.
+ That is, the first bit in the stream will be the high-order bit in
+ the first 8bit byte, and the eighth bit will be the low-order bit in
+ the first 8bit byte, and so on.
+
+ Each 6-bit group is used as an index into an array of 64 printable
+ characters. The character referenced by the index is placed in the
+ output string. These characters, identified in Table 1, below, are
+ selected so as to be universally representable, and the set excludes
+ characters with particular significance to SMTP (e.g., ".", CR, LF)
+ and to the multipart boundary delimiters defined in RFC 2046 (e.g.,
+ "-").
+
+
+
+
+
+
+
+
+
+
+
+Freed & Borenstein Standards Track [Page 24]
+\f
+RFC 2045 Internet Message Bodies November 1996
+
+
+ Table 1: The Base64 Alphabet
+
+ Value Encoding Value Encoding Value Encoding Value Encoding
+ 0 A 17 R 34 i 51 z
+ 1 B 18 S 35 j 52 0
+ 2 C 19 T 36 k 53 1
+ 3 D 20 U 37 l 54 2
+ 4 E 21 V 38 m 55 3
+ 5 F 22 W 39 n 56 4
+ 6 G 23 X 40 o 57 5
+ 7 H 24 Y 41 p 58 6
+ 8 I 25 Z 42 q 59 7
+ 9 J 26 a 43 r 60 8
+ 10 K 27 b 44 s 61 9
+ 11 L 28 c 45 t 62 +
+ 12 M 29 d 46 u 63 /
+ 13 N 30 e 47 v
+ 14 O 31 f 48 w (pad) =
+ 15 P 32 g 49 x
+ 16 Q 33 h 50 y
+
+ The encoded output stream must be represented in lines of no more
+ than 76 characters each. All line breaks or other characters not
+ found in Table 1 must be ignored by decoding software. In base64
+ data, characters other than those in Table 1, line breaks, and other
+ white space probably indicate a transmission error, about which a
+ warning message or even a message rejection might be appropriate
+ under some circumstances.
+
+ Special processing is performed if fewer than 24 bits are available
+ at the end of the data being encoded. A full encoding quantum is
+ always completed at the end of a body. When fewer than 24 input bits
+ are available in an input group, zero bits are added (on the right)
+ to form an integral number of 6-bit groups. Padding at the end of
+ the data is performed using the "=" character. Since all base64
+ input is an integral number of octets, only the following cases can
+ arise: (1) the final quantum of encoding input is an integral
+ multiple of 24 bits; here, the final unit of encoded output will be
+ an integral multiple of 4 characters with no "=" padding, (2) the
+ final quantum of encoding input is exactly 8 bits; here, the final
+ unit of encoded output will be two characters followed by two "="
+ padding characters, or (3) the final quantum of encoding input is
+ exactly 16 bits; here, the final unit of encoded output will be three
+ characters followed by one "=" padding character.
+
+ Because it is used only for padding at the end of the data, the
+ occurrence of any "=" characters may be taken as evidence that the
+ end of the data has been reached (without truncation in transit). No
+
+
+
+Freed & Borenstein Standards Track [Page 25]
+\f
+RFC 2045 Internet Message Bodies November 1996
+
+
+ such assurance is possible, however, when the number of octets
+ transmitted was a multiple of three and no "=" characters are
+ present.
+
+ Any characters outside of the base64 alphabet are to be ignored in
+ base64-encoded data.
+
+ Care must be taken to use the proper octets for line breaks if base64
+ encoding is applied directly to text material that has not been
+ converted to canonical form. In particular, text line breaks must be
+ converted into CRLF sequences prior to base64 encoding. The
+ important thing to note is that this may be done directly by the
+ encoder rather than in a prior canonicalization step in some
+ implementations.
+
+ NOTE: There is no need to worry about quoting potential boundary
+ delimiters within base64-encoded bodies within multipart entities
+ because no hyphen characters are used in the base64 encoding.
+
+7. Content-ID Header Field
+
+ In constructing a high-level user agent, it may be desirable to allow
+ one body to make reference to another. Accordingly, bodies may be
+ labelled using the "Content-ID" header field, which is syntactically
+ identical to the "Message-ID" header field:
+
+ id := "Content-ID" ":" msg-id
+
+ Like the Message-ID values, Content-ID values must be generated to be
+ world-unique.
+
+ The Content-ID value may be used for uniquely identifying MIME
+ entities in several contexts, particularly for caching data
+ referenced by the message/external-body mechanism. Although the
+ Content-ID header is generally optional, its use is MANDATORY in
+ implementations which generate data of the optional MIME media type
+ "message/external-body". That is, each message/external-body entity
+ must have a Content-ID field to permit caching of such data.
+
+ It is also worth noting that the Content-ID value has special
+ semantics in the case of the multipart/alternative media type. This
+ is explained in the section of RFC 2046 dealing with
+ multipart/alternative.
+
+
+
+
+
+
+
+
+Freed & Borenstein Standards Track [Page 26]
+\f
+RFC 2045 Internet Message Bodies November 1996
+
+
+8. Content-Description Header Field
+
+ The ability to associate some descriptive information with a given
+ body is often desirable. For example, it may be useful to mark an
+ "image" body as "a picture of the Space Shuttle Endeavor." Such text
+ may be placed in the Content-Description header field. This header
+ field is always optional.
+
+ description := "Content-Description" ":" *text
+
+ The description is presumed to be given in the US-ASCII character
+ set, although the mechanism specified in RFC 2047 may be used for
+ non-US-ASCII Content-Description values.
+
+9. Additional MIME Header Fields
+
+ Future documents may elect to define additional MIME header fields
+ for various purposes. Any new header field that further describes
+ the content of a message should begin with the string "Content-" to
+ allow such fields which appear in a message header to be
+ distinguished from ordinary RFC 822 message header fields.
+
+ MIME-extension-field := <Any RFC 822 header field which
+ begins with the string
+ "Content-">
+
+10. Summary
+
+ Using the MIME-Version, Content-Type, and Content-Transfer-Encoding
+ header fields, it is possible to include, in a standardized way,
+ arbitrary types of data with RFC 822 conformant mail messages. No
+ restrictions imposed by either RFC 821 or RFC 822 are violated, and
+ care has been taken to avoid problems caused by additional
+ restrictions imposed by the characteristics of some Internet mail
+ transport mechanisms (see RFC 2049).
+
+ The next document in this set, RFC 2046, specifies the initial set of
+ media types that can be labelled and transported using these headers.
+
+11. Security Considerations
+
+ Security issues are discussed in the second document in this set, RFC
+ 2046.
+
+
+
+
+
+
+
+
+Freed & Borenstein Standards Track [Page 27]
+\f
+RFC 2045 Internet Message Bodies November 1996
+
+
+12. Authors' Addresses
+
+ For more information, the authors of this document are best contacted
+ via Internet mail:
+
+ Ned Freed
+ Innosoft International, Inc.
+ 1050 East Garvey Avenue South
+ West Covina, CA 91790
+ USA
+
+ Phone: +1 818 919 3600
+ Fax: +1 818 919 3614
+ EMail: ned@innosoft.com
+
+
+ Nathaniel S. Borenstein
+ First Virtual Holdings
+ 25 Washington Avenue
+ Morristown, NJ 07960
+ USA
+
+ Phone: +1 201 540 8967
+ Fax: +1 201 993 3032
+ EMail: nsb@nsb.fv.com
+
+
+ MIME is a result of the work of the Internet Engineering Task Force
+ Working Group on RFC 822 Extensions. The chairman of that group,
+ Greg Vaudreuil, may be reached at:
+
+ Gregory M. Vaudreuil
+ Octel Network Services
+ 17080 Dallas Parkway
+ Dallas, TX 75248-1905
+ USA
+
+ EMail: Greg.Vaudreuil@Octel.Com
+
+
+
+
+
+
+
+
+
+
+
+
+
+Freed & Borenstein Standards Track [Page 28]
+\f
+RFC 2045 Internet Message Bodies November 1996
+
+
+Appendix A -- Collected Grammar
+
+ This appendix contains the complete BNF grammar for all the syntax
+ specified by this document.
+
+ By itself, however, this grammar is incomplete. It refers by name to
+ several syntax rules that are defined by RFC 822. Rather than
+ reproduce those definitions here, and risk unintentional differences
+ between the two, this document simply refers the reader to RFC 822
+ for the remaining definitions. Wherever a term is undefined, it
+ refers to the RFC 822 definition.
+
+ attribute := token
+ ; Matching of attributes
+ ; is ALWAYS case-insensitive.
+
+ composite-type := "message" / "multipart" / extension-token
+
+ content := "Content-Type" ":" type "/" subtype
+ *(";" parameter)
+ ; Matching of media type and subtype
+ ; is ALWAYS case-insensitive.
+
+ description := "Content-Description" ":" *text
+
+ discrete-type := "text" / "image" / "audio" / "video" /
+ "application" / extension-token
+
+ encoding := "Content-Transfer-Encoding" ":" mechanism
+
+ entity-headers := [ content CRLF ]
+ [ encoding CRLF ]
+ [ id CRLF ]
+ [ description CRLF ]
+ *( MIME-extension-field CRLF )
+
+ extension-token := ietf-token / x-token
+
+ hex-octet := "=" 2(DIGIT / "A" / "B" / "C" / "D" / "E" / "F")
+ ; Octet must be used for characters > 127, =,
+ ; SPACEs or TABs at the ends of lines, and is
+ ; recommended for any character not listed in
+ ; RFC 2049 as "mail-safe".
+
+ iana-token := <A publicly-defined extension token. Tokens
+ of this form must be registered with IANA
+ as specified in RFC 2048.>
+
+
+
+
+Freed & Borenstein Standards Track [Page 29]
+\f
+RFC 2045 Internet Message Bodies November 1996
+
+
+ ietf-token := <An extension token defined by a
+ standards-track RFC and registered
+ with IANA.>
+
+ id := "Content-ID" ":" msg-id
+
+ mechanism := "7bit" / "8bit" / "binary" /
+ "quoted-printable" / "base64" /
+ ietf-token / x-token
+
+ MIME-extension-field := <Any RFC 822 header field which
+ begins with the string
+ "Content-">
+
+ MIME-message-headers := entity-headers
+ fields
+ version CRLF
+ ; The ordering of the header
+ ; fields implied by this BNF
+ ; definition should be ignored.
+
+ MIME-part-headers := entity-headers
+ [fields]
+ ; Any field not beginning with
+ ; "content-" can have no defined
+ ; meaning and may be ignored.
+ ; The ordering of the header
+ ; fields implied by this BNF
+ ; definition should be ignored.
+
+ parameter := attribute "=" value
+
+ ptext := hex-octet / safe-char
+
+ qp-line := *(qp-segment transport-padding CRLF)
+ qp-part transport-padding
+
+ qp-part := qp-section
+ ; Maximum length of 76 characters
+
+ qp-section := [*(ptext / SPACE / TAB) ptext]
+
+ qp-segment := qp-section *(SPACE / TAB) "="
+ ; Maximum length of 76 characters
+
+ quoted-printable := qp-line *(CRLF qp-line)
+
+
+
+
+
+Freed & Borenstein Standards Track [Page 30]
+\f
+RFC 2045 Internet Message Bodies November 1996
+
+
+ safe-char := <any octet with decimal value of 33 through
+ 60 inclusive, and 62 through 126>
+ ; Characters not listed as "mail-safe" in
+ ; RFC 2049 are also not recommended.
+
+ subtype := extension-token / iana-token
+
+ token := 1*<any (US-ASCII) CHAR except SPACE, CTLs,
+ or tspecials>
+
+ transport-padding := *LWSP-char
+ ; Composers MUST NOT generate
+ ; non-zero length transport
+ ; padding, but receivers MUST
+ ; be able to handle padding
+ ; added by message transports.
+
+ tspecials := "(" / ")" / "<" / ">" / "@" /
+ "," / ";" / ":" / "\" / <">
+ "/" / "[" / "]" / "?" / "="
+ ; Must be in quoted-string,
+ ; to use within parameter values
+
+ type := discrete-type / composite-type
+
+ value := token / quoted-string
+
+ version := "MIME-Version" ":" 1*DIGIT "." 1*DIGIT
+
+ x-token := <The two characters "X-" or "x-" followed, with
+ no intervening white space, by any token>
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+Freed & Borenstein Standards Track [Page 31]
+\f
--- /dev/null
+
+
+
+
+
+
+Network Working Group N. Freed
+Request for Comments: 2046 Innosoft
+Obsoletes: 1521, 1522, 1590 N. Borenstein
+Category: Standards Track First Virtual
+ November 1996
+
+
+ Multipurpose Internet Mail Extensions
+ (MIME) Part Two:
+ Media Types
+
+Status of this Memo
+
+ This document specifies an Internet standards track protocol for the
+ Internet community, and requests discussion and suggestions for
+ improvements. Please refer to the current edition of the "Internet
+ Official Protocol Standards" (STD 1) for the standardization state
+ and status of this protocol. Distribution of this memo is unlimited.
+
+Abstract
+
+ STD 11, RFC 822 defines a message representation protocol specifying
+ considerable detail about US-ASCII message headers, but which leaves
+ the message content, or message body, as flat US-ASCII text. This
+ set of documents, collectively called the Multipurpose Internet Mail
+ Extensions, or MIME, redefines the format of messages to allow for
+
+ (1) textual message bodies in character sets other than
+ US-ASCII,
+
+ (2) an extensible set of different formats for non-textual
+ message bodies,
+
+ (3) multi-part message bodies, and
+
+ (4) textual header information in character sets other than
+ US-ASCII.
+
+ These documents are based on earlier work documented in RFC 934, STD
+ 11, and RFC 1049, but extends and revises them. Because RFC 822 said
+ so little about message bodies, these documents are largely
+ orthogonal to (rather than a revision of) RFC 822.
+
+ The initial document in this set, RFC 2045, specifies the various
+ headers used to describe the structure of MIME messages. This second
+ document defines the general structure of the MIME media typing
+ system and defines an initial set of media types. The third document,
+ RFC 2047, describes extensions to RFC 822 to allow non-US-ASCII text
+
+
+
+Freed & Borenstein Standards Track [Page 1]
+\f
+RFC 2046 Media Types November 1996
+
+
+ data in Internet mail header fields. The fourth document, RFC 2048,
+ specifies various IANA registration procedures for MIME-related
+ facilities. The fifth and final document, RFC 2049, describes MIME
+ conformance criteria as well as providing some illustrative examples
+ of MIME message formats, acknowledgements, and the bibliography.
+
+ These documents are revisions of RFCs 1521 and 1522, which themselves
+ were revisions of RFCs 1341 and 1342. An appendix in RFC 2049
+ describes differences and changes from previous versions.
+
+Table of Contents
+
+ 1. Introduction ......................................... 3
+ 2. Definition of a Top-Level Media Type ................. 4
+ 3. Overview Of The Initial Top-Level Media Types ........ 4
+ 4. Discrete Media Type Values ........................... 6
+ 4.1 Text Media Type ..................................... 6
+ 4.1.1 Representation of Line Breaks ..................... 7
+ 4.1.2 Charset Parameter ................................. 7
+ 4.1.3 Plain Subtype ..................................... 11
+ 4.1.4 Unrecognized Subtypes ............................. 11
+ 4.2 Image Media Type .................................... 11
+ 4.3 Audio Media Type .................................... 11
+ 4.4 Video Media Type .................................... 12
+ 4.5 Application Media Type .............................. 12
+ 4.5.1 Octet-Stream Subtype .............................. 13
+ 4.5.2 PostScript Subtype ................................ 14
+ 4.5.3 Other Application Subtypes ........................ 17
+ 5. Composite Media Type Values .......................... 17
+ 5.1 Multipart Media Type ................................ 17
+ 5.1.1 Common Syntax ..................................... 19
+ 5.1.2 Handling Nested Messages and Multiparts ........... 24
+ 5.1.3 Mixed Subtype ..................................... 24
+ 5.1.4 Alternative Subtype ............................... 24
+ 5.1.5 Digest Subtype .................................... 26
+ 5.1.6 Parallel Subtype .................................. 27
+ 5.1.7 Other Multipart Subtypes .......................... 28
+ 5.2 Message Media Type .................................. 28
+ 5.2.1 RFC822 Subtype .................................... 28
+ 5.2.2 Partial Subtype ................................... 29
+ 5.2.2.1 Message Fragmentation and Reassembly ............ 30
+ 5.2.2.2 Fragmentation and Reassembly Example ............ 31
+ 5.2.3 External-Body Subtype ............................. 33
+ 5.2.4 Other Message Subtypes ............................ 40
+ 6. Experimental Media Type Values ....................... 40
+ 7. Summary .............................................. 41
+ 8. Security Considerations .............................. 41
+ 9. Authors' Addresses ................................... 42
+
+
+
+Freed & Borenstein Standards Track [Page 2]
+\f
+RFC 2046 Media Types November 1996
+
+
+ A. Collected Grammar .................................... 43
+
+1. Introduction
+
+ The first document in this set, RFC 2045, defines a number of header
+ fields, including Content-Type. The Content-Type field is used to
+ specify the nature of the data in the body of a MIME entity, by
+ giving media type and subtype identifiers, and by providing auxiliary
+ information that may be required for certain media types. After the
+ type and subtype names, the remainder of the header field is simply a
+ set of parameters, specified in an attribute/value notation. The
+ ordering of parameters is not significant.
+
+ In general, the top-level media type is used to declare the general
+ type of data, while the subtype specifies a specific format for that
+ type of data. Thus, a media type of "image/xyz" is enough to tell a
+ user agent that the data is an image, even if the user agent has no
+ knowledge of the specific image format "xyz". Such information can
+ be used, for example, to decide whether or not to show a user the raw
+ data from an unrecognized subtype -- such an action might be
+ reasonable for unrecognized subtypes of "text", but not for
+ unrecognized subtypes of "image" or "audio". For this reason,
+ registered subtypes of "text", "image", "audio", and "video" should
+ not contain embedded information that is really of a different type.
+ Such compound formats should be represented using the "multipart" or
+ "application" types.
+
+ Parameters are modifiers of the media subtype, and as such do not
+ fundamentally affect the nature of the content. The set of
+ meaningful parameters depends on the media type and subtype. Most
+ parameters are associated with a single specific subtype. However, a
+ given top-level media type may define parameters which are applicable
+ to any subtype of that type. Parameters may be required by their
+ defining media type or subtype or they may be optional. MIME
+ implementations must also ignore any parameters whose names they do
+ not recognize.
+
+ MIME's Content-Type header field and media type mechanism has been
+ carefully designed to be extensible, and it is expected that the set
+ of media type/subtype pairs and their associated parameters will grow
+ significantly over time. Several other MIME facilities, such as
+ transfer encodings and "message/external-body" access types, are
+ likely to have new values defined over time. In order to ensure that
+ the set of such values is developed in an orderly, well-specified,
+ and public manner, MIME sets up a registration process which uses the
+ Internet Assigned Numbers Authority (IANA) as a central registry for
+ MIME's various areas of extensibility. The registration process for
+ these areas is described in a companion document, RFC 2048.
+
+
+
+Freed & Borenstein Standards Track [Page 3]
+\f
+RFC 2046 Media Types November 1996
+
+
+ The initial seven standard top-level media type are defined and
+ described in the remainder of this document.
+
+2. Definition of a Top-Level Media Type
+
+ The definition of a top-level media type consists of:
+
+ (1) a name and a description of the type, including
+ criteria for whether a particular type would qualify
+ under that type,
+
+ (2) the names and definitions of parameters, if any, which
+ are defined for all subtypes of that type (including
+ whether such parameters are required or optional),
+
+ (3) how a user agent and/or gateway should handle unknown
+ subtypes of this type,
+
+ (4) general considerations on gatewaying entities of this
+ top-level type, if any, and
+
+ (5) any restrictions on content-transfer-encodings for
+ entities of this top-level type.
+
+3. Overview Of The Initial Top-Level Media Types
+
+ The five discrete top-level media types are:
+
+ (1) text -- textual information. The subtype "plain" in
+ particular indicates plain text containing no
+ formatting commands or directives of any sort. Plain
+ text is intended to be displayed "as-is". No special
+ software is required to get the full meaning of the
+ text, aside from support for the indicated character
+ set. Other subtypes are to be used for enriched text in
+ forms where application software may enhance the
+ appearance of the text, but such software must not be
+ required in order to get the general idea of the
+ content. Possible subtypes of "text" thus include any
+ word processor format that can be read without
+ resorting to software that understands the format. In
+ particular, formats that employ embeddded binary
+ formatting information are not considered directly
+ readable. A very simple and portable subtype,
+ "richtext", was defined in RFC 1341, with a further
+ revision in RFC 1896 under the name "enriched".
+
+
+
+
+
+Freed & Borenstein Standards Track [Page 4]
+\f
+RFC 2046 Media Types November 1996
+
+
+ (2) image -- image data. "Image" requires a display device
+ (such as a graphical display, a graphics printer, or a
+ FAX machine) to view the information. An initial
+ subtype is defined for the widely-used image format
+ JPEG. . subtypes are defined for two widely-used image
+ formats, jpeg and gif.
+
+ (3) audio -- audio data. "Audio" requires an audio output
+ device (such as a speaker or a telephone) to "display"
+ the contents. An initial subtype "basic" is defined in
+ this document.
+
+ (4) video -- video data. "Video" requires the capability
+ to display moving images, typically including
+ specialized hardware and software. An initial subtype
+ "mpeg" is defined in this document.
+
+ (5) application -- some other kind of data, typically
+ either uninterpreted binary data or information to be
+ processed by an application. The subtype "octet-
+ stream" is to be used in the case of uninterpreted
+ binary data, in which case the simplest recommended
+ action is to offer to write the information into a file
+ for the user. The "PostScript" subtype is also defined
+ for the transport of PostScript material. Other
+ expected uses for "application" include spreadsheets,
+ data for mail-based scheduling systems, and languages
+ for "active" (computational) messaging, and word
+ processing formats that are not directly readable.
+ Note that security considerations may exist for some
+ types of application data, most notably
+ "application/PostScript" and any form of active
+ messaging. These issues are discussed later in this
+ document.
+
+ The two composite top-level media types are:
+
+ (1) multipart -- data consisting of multiple entities of
+ independent data types. Four subtypes are initially
+ defined, including the basic "mixed" subtype specifying
+ a generic mixed set of parts, "alternative" for
+ representing the same data in multiple formats,
+ "parallel" for parts intended to be viewed
+ simultaneously, and "digest" for multipart entities in
+ which each part has a default type of "message/rfc822".
+
+
+
+
+
+
+Freed & Borenstein Standards Track [Page 5]
+\f
+RFC 2046 Media Types November 1996
+
+
+ (2) message -- an encapsulated message. A body of media
+ type "message" is itself all or a portion of some kind
+ of message object. Such objects may or may not in turn
+ contain other entities. The "rfc822" subtype is used
+ when the encapsulated content is itself an RFC 822
+ message. The "partial" subtype is defined for partial
+ RFC 822 messages, to permit the fragmented transmission
+ of bodies that are thought to be too large to be passed
+ through transport facilities in one piece. Another
+ subtype, "external-body", is defined for specifying
+ large bodies by reference to an external data source.
+
+ It should be noted that the list of media type values given here may
+ be augmented in time, via the mechanisms described above, and that
+ the set of subtypes is expected to grow substantially.
+
+4. Discrete Media Type Values
+
+ Five of the seven initial media type values refer to discrete bodies.
+ The content of these types must be handled by non-MIME mechanisms;
+ they are opaque to MIME processors.
+
+4.1. Text Media Type
+
+ The "text" media type is intended for sending material which is
+ principally textual in form. A "charset" parameter may be used to
+ indicate the character set of the body text for "text" subtypes,
+ notably including the subtype "text/plain", which is a generic
+ subtype for plain text. Plain text does not provide for or allow
+ formatting commands, font attribute specifications, processing
+ instructions, interpretation directives, or content markup. Plain
+ text is seen simply as a linear sequence of characters, possibly
+ interrupted by line breaks or page breaks. Plain text may allow the
+ stacking of several characters in the same position in the text.
+ Plain text in scripts like Arabic and Hebrew may also include
+ facilitites that allow the arbitrary mixing of text segments with
+ opposite writing directions.
+
+ Beyond plain text, there are many formats for representing what might
+ be known as "rich text". An interesting characteristic of many such
+ representations is that they are to some extent readable even without
+ the software that interprets them. It is useful, then, to
+ distinguish them, at the highest level, from such unreadable data as
+ images, audio, or text represented in an unreadable form. In the
+ absence of appropriate interpretation software, it is reasonable to
+ show subtypes of "text" to the user, while it is not reasonable to do
+ so with most nontextual data. Such formatted textual data should be
+ represented using subtypes of "text".
+
+
+
+Freed & Borenstein Standards Track [Page 6]
+\f
+RFC 2046 Media Types November 1996
+
+
+4.1.1. Representation of Line Breaks
+
+ The canonical form of any MIME "text" subtype MUST always represent a
+ line break as a CRLF sequence. Similarly, any occurrence of CRLF in
+ MIME "text" MUST represent a line break. Use of CR and LF outside of
+ line break sequences is also forbidden.
+
+ This rule applies regardless of format or character set or sets
+ involved.
+
+ NOTE: The proper interpretation of line breaks when a body is
+ displayed depends on the media type. In particular, while it is
+ appropriate to treat a line break as a transition to a new line when
+ displaying a "text/plain" body, this treatment is actually incorrect
+ for other subtypes of "text" like "text/enriched" [RFC-1896].
+ Similarly, whether or not line breaks should be added during display
+ operations is also a function of the media type. It should not be
+ necessary to add any line breaks to display "text/plain" correctly,
+ whereas proper display of "text/enriched" requires the appropriate
+ addition of line breaks.
+
+ NOTE: Some protocols defines a maximum line length. E.g. SMTP [RFC-
+ 821] allows a maximum of 998 octets before the next CRLF sequence.
+ To be transported by such protocols, data which includes too long
+ segments without CRLF sequences must be encoded with a suitable
+ content-transfer-encoding.
+
+4.1.2. Charset Parameter
+
+ A critical parameter that may be specified in the Content-Type field
+ for "text/plain" data is the character set. This is specified with a
+ "charset" parameter, as in:
+
+ Content-type: text/plain; charset=iso-8859-1
+
+ Unlike some other parameter values, the values of the charset
+ parameter are NOT case sensitive. The default character set, which
+ must be assumed in the absence of a charset parameter, is US-ASCII.
+
+ The specification for any future subtypes of "text" must specify
+ whether or not they will also utilize a "charset" parameter, and may
+ possibly restrict its values as well. For other subtypes of "text"
+ than "text/plain", the semantics of the "charset" parameter should be
+ defined to be identical to those specified here for "text/plain",
+ i.e., the body consists entirely of characters in the given charset.
+ In particular, definers of future "text" subtypes should pay close
+ attention to the implications of multioctet character sets for their
+ subtype definitions.
+
+
+
+Freed & Borenstein Standards Track [Page 7]
+\f
+RFC 2046 Media Types November 1996
+
+
+ The charset parameter for subtypes of "text" gives a name of a
+ character set, as "character set" is defined in RFC 2045. The rules
+ regarding line breaks detailed in the previous section must also be
+ observed -- a character set whose definition does not conform to
+ these rules cannot be used in a MIME "text" subtype.
+
+ An initial list of predefined character set names can be found at the
+ end of this section. Additional character sets may be registered
+ with IANA.
+
+ Other media types than subtypes of "text" might choose to employ the
+ charset parameter as defined here, but with the CRLF/line break
+ restriction removed. Therefore, all character sets that conform to
+ the general definition of "character set" in RFC 2045 can be
+ registered for MIME use.
+
+ Note that if the specified character set includes 8-bit characters
+ and such characters are used in the body, a Content-Transfer-Encoding
+ header field and a corresponding encoding on the data are required in
+ order to transmit the body via some mail transfer protocols, such as
+ SMTP [RFC-821].
+
+ The default character set, US-ASCII, has been the subject of some
+ confusion and ambiguity in the past. Not only were there some
+ ambiguities in the definition, there have been wide variations in
+ practice. In order to eliminate such ambiguity and variations in the
+ future, it is strongly recommended that new user agents explicitly
+ specify a character set as a media type parameter in the Content-Type
+ header field. "US-ASCII" does not indicate an arbitrary 7-bit
+ character set, but specifies that all octets in the body must be
+ interpreted as characters according to the US-ASCII character set.
+ National and application-oriented versions of ISO 646 [ISO-646] are
+ usually NOT identical to US-ASCII, and in that case their use in
+ Internet mail is explicitly discouraged. The omission of the ISO 646
+ character set from this document is deliberate in this regard. The
+ character set name of "US-ASCII" explicitly refers to the character
+ set defined in ANSI X3.4-1986 [US- ASCII]. The new international
+ reference version (IRV) of the 1991 edition of ISO 646 is identical
+ to US-ASCII. The character set name "ASCII" is reserved and must not
+ be used for any purpose.
+
+ NOTE: RFC 821 explicitly specifies "ASCII", and references an earlier
+ version of the American Standard. Insofar as one of the purposes of
+ specifying a media type and character set is to permit the receiver
+ to unambiguously determine how the sender intended the coded message
+ to be interpreted, assuming anything other than "strict ASCII" as the
+ default would risk unintentional and incompatible changes to the
+ semantics of messages now being transmitted. This also implies that
+
+
+
+Freed & Borenstein Standards Track [Page 8]
+\f
+RFC 2046 Media Types November 1996
+
+
+ messages containing characters coded according to other versions of
+ ISO 646 than US-ASCII and the 1991 IRV, or using code-switching
+ procedures (e.g., those of ISO 2022), as well as 8bit or multiple
+ octet character encodings MUST use an appropriate character set
+ specification to be consistent with MIME.
+
+ The complete US-ASCII character set is listed in ANSI X3.4- 1986.
+ Note that the control characters including DEL (0-31, 127) have no
+ defined meaning in apart from the combination CRLF (US-ASCII values
+ 13 and 10) indicating a new line. Two of the characters have de
+ facto meanings in wide use: FF (12) often means "start subsequent
+ text on the beginning of a new page"; and TAB or HT (9) often (though
+ not always) means "move the cursor to the next available column after
+ the current position where the column number is a multiple of 8
+ (counting the first column as column 0)." Aside from these
+ conventions, any use of the control characters or DEL in a body must
+ either occur
+
+ (1) because a subtype of text other than "plain"
+ specifically assigns some additional meaning, or
+
+ (2) within the context of a private agreement between the
+ sender and recipient. Such private agreements are
+ discouraged and should be replaced by the other
+ capabilities of this document.
+
+ NOTE: An enormous proliferation of character sets exist beyond US-
+ ASCII. A large number of partially or totally overlapping character
+ sets is NOT a good thing. A SINGLE character set that can be used
+ universally for representing all of the world's languages in Internet
+ mail would be preferrable. Unfortunately, existing practice in
+ several communities seems to point to the continued use of multiple
+ character sets in the near future. A small number of standard
+ character sets are, therefore, defined for Internet use in this
+ document.
+
+ The defined charset values are:
+
+ (1) US-ASCII -- as defined in ANSI X3.4-1986 [US-ASCII].
+
+ (2) ISO-8859-X -- where "X" is to be replaced, as
+ necessary, for the parts of ISO-8859 [ISO-8859]. Note
+ that the ISO 646 character sets have deliberately been
+ omitted in favor of their 8859 replacements, which are
+ the designated character sets for Internet mail. As of
+ the publication of this document, the legitimate values
+ for "X" are the digits 1 through 10.
+
+
+
+
+Freed & Borenstein Standards Track [Page 9]
+\f
+RFC 2046 Media Types November 1996
+
+
+ Characters in the range 128-159 has no assigned meaning in ISO-8859-
+ X. Characters with values below 128 in ISO-8859-X have the same
+ assigned meaning as they do in US-ASCII.
+
+ Part 6 of ISO 8859 (Latin/Arabic alphabet) and part 8 (Latin/Hebrew
+ alphabet) includes both characters for which the normal writing
+ direction is right to left and characters for which it is left to
+ right, but do not define a canonical ordering method for representing
+ bi-directional text. The charset values "ISO-8859-6" and "ISO-8859-
+ 8", however, specify that the visual method is used [RFC-1556].
+
+ All of these character sets are used as pure 7bit or 8bit sets
+ without any shift or escape functions. The meaning of shift and
+ escape sequences in these character sets is not defined.
+
+ The character sets specified above are the ones that were relatively
+ uncontroversial during the drafting of MIME. This document does not
+ endorse the use of any particular character set other than US-ASCII,
+ and recognizes that the future evolution of world character sets
+ remains unclear.
+
+ Note that the character set used, if anything other than US- ASCII,
+ must always be explicitly specified in the Content-Type field.
+
+ No character set name other than those defined above may be used in
+ Internet mail without the publication of a formal specification and
+ its registration with IANA, or by private agreement, in which case
+ the character set name must begin with "X-".
+
+ Implementors are discouraged from defining new character sets unless
+ absolutely necessary.
+
+ The "charset" parameter has been defined primarily for the purpose of
+ textual data, and is described in this section for that reason.
+ However, it is conceivable that non-textual data might also wish to
+ specify a charset value for some purpose, in which case the same
+ syntax and values should be used.
+
+ In general, composition software should always use the "lowest common
+ denominator" character set possible. For example, if a body contains
+ only US-ASCII characters, it SHOULD be marked as being in the US-
+ ASCII character set, not ISO-8859-1, which, like all the ISO-8859
+ family of character sets, is a superset of US-ASCII. More generally,
+ if a widely-used character set is a subset of another character set,
+ and a body contains only characters in the widely-used subset, it
+ should be labelled as being in that subset. This will increase the
+ chances that the recipient will be able to view the resulting entity
+ correctly.
+
+
+
+Freed & Borenstein Standards Track [Page 10]
+\f
+RFC 2046 Media Types November 1996
+
+
+4.1.3. Plain Subtype
+
+ The simplest and most important subtype of "text" is "plain". This
+ indicates plain text that does not contain any formatting commands or
+ directives. Plain text is intended to be displayed "as-is", that is,
+ no interpretation of embedded formatting commands, font attribute
+ specifications, processing instructions, interpretation directives,
+ or content markup should be necessary for proper display. The
+ default media type of "text/plain; charset=us-ascii" for Internet
+ mail describes existing Internet practice. That is, it is the type
+ of body defined by RFC 822.
+
+ No other "text" subtype is defined by this document.
+
+4.1.4. Unrecognized Subtypes
+
+ Unrecognized subtypes of "text" should be treated as subtype "plain"
+ as long as the MIME implementation knows how to handle the charset.
+ Unrecognized subtypes which also specify an unrecognized charset
+ should be treated as "application/octet- stream".
+
+4.2. Image Media Type
+
+ A media type of "image" indicates that the body contains an image.
+ The subtype names the specific image format. These names are not
+ case sensitive. An initial subtype is "jpeg" for the JPEG format
+ using JFIF encoding [JPEG].
+
+ The list of "image" subtypes given here is neither exclusive nor
+ exhaustive, and is expected to grow as more types are registered with
+ IANA, as described in RFC 2048.
+
+ Unrecognized subtypes of "image" should at a miniumum be treated as
+ "application/octet-stream". Implementations may optionally elect to
+ pass subtypes of "image" that they do not specifically recognize to a
+ secure and robust general-purpose image viewing application, if such
+ an application is available.
+
+ NOTE: Using of a generic-purpose image viewing application this way
+ inherits the security problems of the most dangerous type supported
+ by the application.
+
+4.3. Audio Media Type
+
+ A media type of "audio" indicates that the body contains audio data.
+ Although there is not yet a consensus on an "ideal" audio format for
+ use with computers, there is a pressing need for a format capable of
+ providing interoperable behavior.
+
+
+
+Freed & Borenstein Standards Track [Page 11]
+\f
+RFC 2046 Media Types November 1996
+
+
+ The initial subtype of "basic" is specified to meet this requirement
+ by providing an absolutely minimal lowest common denominator audio
+ format. It is expected that richer formats for higher quality and/or
+ lower bandwidth audio will be defined by a later document.
+
+ The content of the "audio/basic" subtype is single channel audio
+ encoded using 8bit ISDN mu-law [PCM] at a sample rate of 8000 Hz.
+
+ Unrecognized subtypes of "audio" should at a miniumum be treated as
+ "application/octet-stream". Implementations may optionally elect to
+ pass subtypes of "audio" that they do not specifically recognize to a
+ robust general-purpose audio playing application, if such an
+ application is available.
+
+4.4. Video Media Type
+
+ A media type of "video" indicates that the body contains a time-
+ varying-picture image, possibly with color and coordinated sound.
+ The term 'video' is used in its most generic sense, rather than with
+ reference to any particular technology or format, and is not meant to
+ preclude subtypes such as animated drawings encoded compactly. The
+ subtype "mpeg" refers to video coded according to the MPEG standard
+ [MPEG].
+
+ Note that although in general this document strongly discourages the
+ mixing of multiple media in a single body, it is recognized that many
+ so-called video formats include a representation for synchronized
+ audio, and this is explicitly permitted for subtypes of "video".
+
+ Unrecognized subtypes of "video" should at a minumum be treated as
+ "application/octet-stream". Implementations may optionally elect to
+ pass subtypes of "video" that they do not specifically recognize to a
+ robust general-purpose video display application, if such an
+ application is available.
+
+4.5. Application Media Type
+
+ The "application" media type is to be used for discrete data which do
+ not fit in any of the other categories, and particularly for data to
+ be processed by some type of application program. This is
+ information which must be processed by an application before it is
+ viewable or usable by a user. Expected uses for the "application"
+ media type include file transfer, spreadsheets, data for mail-based
+ scheduling systems, and languages for "active" (computational)
+ material. (The latter, in particular, can pose security problems
+ which must be understood by implementors, and are considered in
+ detail in the discussion of the "application/PostScript" media type.)
+
+
+
+
+Freed & Borenstein Standards Track [Page 12]
+\f
+RFC 2046 Media Types November 1996
+
+
+ For example, a meeting scheduler might define a standard
+ representation for information about proposed meeting dates. An
+ intelligent user agent would use this information to conduct a dialog
+ with the user, and might then send additional material based on that
+ dialog. More generally, there have been several "active" messaging
+ languages developed in which programs in a suitably specialized
+ language are transported to a remote location and automatically run
+ in the recipient's environment.
+
+ Such applications may be defined as subtypes of the "application"
+ media type. This document defines two subtypes:
+
+ octet-stream, and PostScript.
+
+ The subtype of "application" will often be either the name or include
+ part of the name of the application for which the data are intended.
+ This does not mean, however, that any application program name may be
+ used freely as a subtype of "application".
+
+4.5.1. Octet-Stream Subtype
+
+ The "octet-stream" subtype is used to indicate that a body contains
+ arbitrary binary data. The set of currently defined parameters is:
+
+ (1) TYPE -- the general type or category of binary data.
+ This is intended as information for the human recipient
+ rather than for any automatic processing.
+
+ (2) PADDING -- the number of bits of padding that were
+ appended to the bit-stream comprising the actual
+ contents to produce the enclosed 8bit byte-oriented
+ data. This is useful for enclosing a bit-stream in a
+ body when the total number of bits is not a multiple of
+ 8.
+
+ Both of these parameters are optional.
+
+ An additional parameter, "CONVERSIONS", was defined in RFC 1341 but
+ has since been removed. RFC 1341 also defined the use of a "NAME"
+ parameter which gave a suggested file name to be used if the data
+ were to be written to a file. This has been deprecated in
+ anticipation of a separate Content-Disposition header field, to be
+ defined in a subsequent RFC.
+
+ The recommended action for an implementation that receives an
+ "application/octet-stream" entity is to simply offer to put the data
+ in a file, with any Content-Transfer-Encoding undone, or perhaps to
+ use it as input to a user-specified process.
+
+
+
+Freed & Borenstein Standards Track [Page 13]
+\f
+RFC 2046 Media Types November 1996
+
+
+ To reduce the danger of transmitting rogue programs, it is strongly
+ recommended that implementations NOT implement a path-search
+ mechanism whereby an arbitrary program named in the Content-Type
+ parameter (e.g., an "interpreter=" parameter) is found and executed
+ using the message body as input.
+
+4.5.2. PostScript Subtype
+
+ A media type of "application/postscript" indicates a PostScript
+ program. Currently two variants of the PostScript language are
+ allowed; the original level 1 variant is described in [POSTSCRIPT]
+ and the more recent level 2 variant is described in [POSTSCRIPT2].
+
+ PostScript is a registered trademark of Adobe Systems, Inc. Use of
+ the MIME media type "application/postscript" implies recognition of
+ that trademark and all the rights it entails.
+
+ The PostScript language definition provides facilities for internal
+ labelling of the specific language features a given program uses.
+ This labelling, called the PostScript document structuring
+ conventions, or DSC, is very general and provides substantially more
+ information than just the language level. The use of document
+ structuring conventions, while not required, is strongly recommended
+ as an aid to interoperability. Documents which lack proper
+ structuring conventions cannot be tested to see whether or not they
+ will work in a given environment. As such, some systems may assume
+ the worst and refuse to process unstructured documents.
+
+ The execution of general-purpose PostScript interpreters entails
+ serious security risks, and implementors are discouraged from simply
+ sending PostScript bodies to "off- the-shelf" interpreters. While it
+ is usually safe to send PostScript to a printer, where the potential
+ for harm is greatly constrained by typical printer environments,
+ implementors should consider all of the following before they add
+ interactive display of PostScript bodies to their MIME readers.
+
+ The remainder of this section outlines some, though probably not all,
+ of the possible problems with the transport of PostScript entities.
+
+ (1) Dangerous operations in the PostScript language
+ include, but may not be limited to, the PostScript
+ operators "deletefile", "renamefile", "filenameforall",
+ and "file". "File" is only dangerous when applied to
+ something other than standard input or output.
+ Implementations may also define additional nonstandard
+ file operators; these may also pose a threat to
+ security. "Filenameforall", the wildcard file search
+ operator, may appear at first glance to be harmless.
+
+
+
+Freed & Borenstein Standards Track [Page 14]
+\f
+RFC 2046 Media Types November 1996
+
+
+ Note, however, that this operator has the potential to
+ reveal information about what files the recipient has
+ access to, and this information may itself be
+ sensitive. Message senders should avoid the use of
+ potentially dangerous file operators, since these
+ operators are quite likely to be unavailable in secure
+ PostScript implementations. Message receiving and
+ displaying software should either completely disable
+ all potentially dangerous file operators or take
+ special care not to delegate any special authority to
+ their operation. These operators should be viewed as
+ being done by an outside agency when interpreting
+ PostScript documents. Such disabling and/or checking
+ should be done completely outside of the reach of the
+ PostScript language itself; care should be taken to
+ insure that no method exists for re-enabling full-
+ function versions of these operators.
+
+ (2) The PostScript language provides facilities for exiting
+ the normal interpreter, or server, loop. Changes made
+ in this "outer" environment are customarily retained
+ across documents, and may in some cases be retained
+ semipermanently in nonvolatile memory. The operators
+ associated with exiting the interpreter loop have the
+ potential to interfere with subsequent document
+ processing. As such, their unrestrained use
+ constitutes a threat of service denial. PostScript
+ operators that exit the interpreter loop include, but
+ may not be limited to, the exitserver and startjob
+ operators. Message sending software should not
+ generate PostScript that depends on exiting the
+ interpreter loop to operate, since the ability to exit
+ will probably be unavailable in secure PostScript
+ implementations. Message receiving and displaying
+ software should completely disable the ability to make
+ retained changes to the PostScript environment by
+ eliminating or disabling the "startjob" and
+ "exitserver" operations. If these operations cannot be
+ eliminated or completely disabled the password
+ associated with them should at least be set to a hard-
+ to-guess value.
+
+ (3) PostScript provides operators for setting system-wide
+ and device-specific parameters. These parameter
+ settings may be retained across jobs and may
+ potentially pose a threat to the correct operation of
+ the interpreter. The PostScript operators that set
+ system and device parameters include, but may not be
+
+
+
+Freed & Borenstein Standards Track [Page 15]
+\f
+RFC 2046 Media Types November 1996
+
+
+ limited to, the "setsystemparams" and "setdevparams"
+ operators. Message sending software should not
+ generate PostScript that depends on the setting of
+ system or device parameters to operate correctly. The
+ ability to set these parameters will probably be
+ unavailable in secure PostScript implementations.
+ Message receiving and displaying software should
+ disable the ability to change system and device
+ parameters. If these operators cannot be completely
+ disabled the password associated with them should at
+ least be set to a hard-to-guess value.
+
+ (4) Some PostScript implementations provide nonstandard
+ facilities for the direct loading and execution of
+ machine code. Such facilities are quite obviously open
+ to substantial abuse. Message sending software should
+ not make use of such features. Besides being totally
+ hardware-specific, they are also likely to be
+ unavailable in secure implementations of PostScript.
+ Message receiving and displaying software should not
+ allow such operators to be used if they exist.
+
+ (5) PostScript is an extensible language, and many, if not
+ most, implementations of it provide a number of their
+ own extensions. This document does not deal with such
+ extensions explicitly since they constitute an unknown
+ factor. Message sending software should not make use
+ of nonstandard extensions; they are likely to be
+ missing from some implementations. Message receiving
+ and displaying software should make sure that any
+ nonstandard PostScript operators are secure and don't
+ present any kind of threat.
+
+ (6) It is possible to write PostScript that consumes huge
+ amounts of various system resources. It is also
+ possible to write PostScript programs that loop
+ indefinitely. Both types of programs have the
+ potential to cause damage if sent to unsuspecting
+ recipients. Message-sending software should avoid the
+ construction and dissemination of such programs, which
+ is antisocial. Message receiving and displaying
+ software should provide appropriate mechanisms to abort
+ processing after a reasonable amount of time has
+ elapsed. In addition, PostScript interpreters should be
+ limited to the consumption of only a reasonable amount
+ of any given system resource.
+
+
+
+
+
+Freed & Borenstein Standards Track [Page 16]
+\f
+RFC 2046 Media Types November 1996
+
+
+ (7) It is possible to include raw binary information inside
+ PostScript in various forms. This is not recommended
+ for use in Internet mail, both because it is not
+ supported by all PostScript interpreters and because it
+ significantly complicates the use of a MIME Content-
+ Transfer-Encoding. (Without such binary, PostScript
+ may typically be viewed as line-oriented data. The
+ treatment of CRLF sequences becomes extremely
+ problematic if binary and line-oriented data are mixed
+ in a single Postscript data stream.)
+
+ (8) Finally, bugs may exist in some PostScript interpreters
+ which could possibly be exploited to gain unauthorized
+ access to a recipient's system. Apart from noting this
+ possibility, there is no specific action to take to
+ prevent this, apart from the timely correction of such
+ bugs if any are found.
+
+4.5.3. Other Application Subtypes
+
+ It is expected that many other subtypes of "application" will be
+ defined in the future. MIME implementations must at a minimum treat
+ any unrecognized subtypes as being equivalent to "application/octet-
+ stream".
+
+5. Composite Media Type Values
+
+ The remaining two of the seven initial Content-Type values refer to
+ composite entities. Composite entities are handled using MIME
+ mechanisms -- a MIME processor typically handles the body directly.
+
+5.1. Multipart Media Type
+
+ In the case of multipart entities, in which one or more different
+ sets of data are combined in a single body, a "multipart" media type
+ field must appear in the entity's header. The body must then contain
+ one or more body parts, each preceded by a boundary delimiter line,
+ and the last one followed by a closing boundary delimiter line.
+ After its boundary delimiter line, each body part then consists of a
+ header area, a blank line, and a body area. Thus a body part is
+ similar to an RFC 822 message in syntax, but different in meaning.
+
+ A body part is an entity and hence is NOT to be interpreted as
+ actually being an RFC 822 message. To begin with, NO header fields
+ are actually required in body parts. A body part that starts with a
+ blank line, therefore, is allowed and is a body part for which all
+ default values are to be assumed. In such a case, the absence of a
+ Content-Type header usually indicates that the corresponding body has
+
+
+
+Freed & Borenstein Standards Track [Page 17]
+\f
+RFC 2046 Media Types November 1996
+
+
+ a content-type of "text/plain; charset=US-ASCII".
+
+ The only header fields that have defined meaning for body parts are
+ those the names of which begin with "Content-". All other header
+ fields may be ignored in body parts. Although they should generally
+ be retained if at all possible, they may be discarded by gateways if
+ necessary. Such other fields are permitted to appear in body parts
+ but must not be depended on. "X-" fields may be created for
+ experimental or private purposes, with the recognition that the
+ information they contain may be lost at some gateways.
+
+ NOTE: The distinction between an RFC 822 message and a body part is
+ subtle, but important. A gateway between Internet and X.400 mail,
+ for example, must be able to tell the difference between a body part
+ that contains an image and a body part that contains an encapsulated
+ message, the body of which is a JPEG image. In order to represent
+ the latter, the body part must have "Content-Type: message/rfc822",
+ and its body (after the blank line) must be the encapsulated message,
+ with its own "Content-Type: image/jpeg" header field. The use of
+ similar syntax facilitates the conversion of messages to body parts,
+ and vice versa, but the distinction between the two must be
+ understood by implementors. (For the special case in which parts
+ actually are messages, a "digest" subtype is also defined.)
+
+ As stated previously, each body part is preceded by a boundary
+ delimiter line that contains the boundary delimiter. The boundary
+ delimiter MUST NOT appear inside any of the encapsulated parts, on a
+ line by itself or as the prefix of any line. This implies that it is
+ crucial that the composing agent be able to choose and specify a
+ unique boundary parameter value that does not contain the boundary
+ parameter value of an enclosing multipart as a prefix.
+
+ All present and future subtypes of the "multipart" type must use an
+ identical syntax. Subtypes may differ in their semantics, and may
+ impose additional restrictions on syntax, but must conform to the
+ required syntax for the "multipart" type. This requirement ensures
+ that all conformant user agents will at least be able to recognize
+ and separate the parts of any multipart entity, even those of an
+ unrecognized subtype.
+
+ As stated in the definition of the Content-Transfer-Encoding field
+ [RFC 2045], no encoding other than "7bit", "8bit", or "binary" is
+ permitted for entities of type "multipart". The "multipart" boundary
+ delimiters and header fields are always represented as 7bit US-ASCII
+ in any case (though the header fields may encode non-US-ASCII header
+ text as per RFC 2047) and data within the body parts can be encoded
+ on a part-by-part basis, with Content-Transfer-Encoding fields for
+ each appropriate body part.
+
+
+
+Freed & Borenstein Standards Track [Page 18]
+\f
+RFC 2046 Media Types November 1996
+
+
+5.1.1. Common Syntax
+
+ This section defines a common syntax for subtypes of "multipart".
+ All subtypes of "multipart" must use this syntax. A simple example
+ of a multipart message also appears in this section. An example of a
+ more complex multipart message is given in RFC 2049.
+
+ The Content-Type field for multipart entities requires one parameter,
+ "boundary". The boundary delimiter line is then defined as a line
+ consisting entirely of two hyphen characters ("-", decimal value 45)
+ followed by the boundary parameter value from the Content-Type header
+ field, optional linear whitespace, and a terminating CRLF.
+
+ NOTE: The hyphens are for rough compatibility with the earlier RFC
+ 934 method of message encapsulation, and for ease of searching for
+ the boundaries in some implementations. However, it should be noted
+ that multipart messages are NOT completely compatible with RFC 934
+ encapsulations; in particular, they do not obey RFC 934 quoting
+ conventions for embedded lines that begin with hyphens. This
+ mechanism was chosen over the RFC 934 mechanism because the latter
+ causes lines to grow with each level of quoting. The combination of
+ this growth with the fact that SMTP implementations sometimes wrap
+ long lines made the RFC 934 mechanism unsuitable for use in the event
+ that deeply-nested multipart structuring is ever desired.
+
+ WARNING TO IMPLEMENTORS: The grammar for parameters on the Content-
+ type field is such that it is often necessary to enclose the boundary
+ parameter values in quotes on the Content-type line. This is not
+ always necessary, but never hurts. Implementors should be sure to
+ study the grammar carefully in order to avoid producing invalid
+ Content-type fields. Thus, a typical "multipart" Content-Type header
+ field might look like this:
+
+ Content-Type: multipart/mixed; boundary=gc0p4Jq0M2Yt08j34c0p
+
+ But the following is not valid:
+
+ Content-Type: multipart/mixed; boundary=gc0pJq0M:08jU534c0p
+
+ (because of the colon) and must instead be represented as
+
+ Content-Type: multipart/mixed; boundary="gc0pJq0M:08jU534c0p"
+
+ This Content-Type value indicates that the content consists of one or
+ more parts, each with a structure that is syntactically identical to
+ an RFC 822 message, except that the header area is allowed to be
+ completely empty, and that the parts are each preceded by the line
+
+
+
+
+Freed & Borenstein Standards Track [Page 19]
+\f
+RFC 2046 Media Types November 1996
+
+
+ --gc0pJq0M:08jU534c0p
+
+ The boundary delimiter MUST occur at the beginning of a line, i.e.,
+ following a CRLF, and the initial CRLF is considered to be attached
+ to the boundary delimiter line rather than part of the preceding
+ part. The boundary may be followed by zero or more characters of
+ linear whitespace. It is then terminated by either another CRLF and
+ the header fields for the next part, or by two CRLFs, in which case
+ there are no header fields for the next part. If no Content-Type
+ field is present it is assumed to be "message/rfc822" in a
+ "multipart/digest" and "text/plain" otherwise.
+
+ NOTE: The CRLF preceding the boundary delimiter line is conceptually
+ attached to the boundary so that it is possible to have a part that
+ does not end with a CRLF (line break). Body parts that must be
+ considered to end with line breaks, therefore, must have two CRLFs
+ preceding the boundary delimiter line, the first of which is part of
+ the preceding body part, and the second of which is part of the
+ encapsulation boundary.
+
+ Boundary delimiters must not appear within the encapsulated material,
+ and must be no longer than 70 characters, not counting the two
+ leading hyphens.
+
+ The boundary delimiter line following the last body part is a
+ distinguished delimiter that indicates that no further body parts
+ will follow. Such a delimiter line is identical to the previous
+ delimiter lines, with the addition of two more hyphens after the
+ boundary parameter value.
+
+ --gc0pJq0M:08jU534c0p--
+
+ NOTE TO IMPLEMENTORS: Boundary string comparisons must compare the
+ boundary value with the beginning of each candidate line. An exact
+ match of the entire candidate line is not required; it is sufficient
+ that the boundary appear in its entirety following the CRLF.
+
+ There appears to be room for additional information prior to the
+ first boundary delimiter line and following the final boundary
+ delimiter line. These areas should generally be left blank, and
+ implementations must ignore anything that appears before the first
+ boundary delimiter line or after the last one.
+
+ NOTE: These "preamble" and "epilogue" areas are generally not used
+ because of the lack of proper typing of these parts and the lack of
+ clear semantics for handling these areas at gateways, particularly
+ X.400 gateways. However, rather than leaving the preamble area
+ blank, many MIME implementations have found this to be a convenient
+
+
+
+Freed & Borenstein Standards Track [Page 20]
+\f
+RFC 2046 Media Types November 1996
+
+
+ place to insert an explanatory note for recipients who read the
+ message with pre-MIME software, since such notes will be ignored by
+ MIME-compliant software.
+
+ NOTE: Because boundary delimiters must not appear in the body parts
+ being encapsulated, a user agent must exercise care to choose a
+ unique boundary parameter value. The boundary parameter value in the
+ example above could have been the result of an algorithm designed to
+ produce boundary delimiters with a very low probability of already
+ existing in the data to be encapsulated without having to prescan the
+ data. Alternate algorithms might result in more "readable" boundary
+ delimiters for a recipient with an old user agent, but would require
+ more attention to the possibility that the boundary delimiter might
+ appear at the beginning of some line in the encapsulated part. The
+ simplest boundary delimiter line possible is something like "---",
+ with a closing boundary delimiter line of "-----".
+
+ As a very simple example, the following multipart message has two
+ parts, both of them plain text, one of them explicitly typed and one
+ of them implicitly typed:
+
+ From: Nathaniel Borenstein <nsb@bellcore.com>
+ To: Ned Freed <ned@innosoft.com>
+ Date: Sun, 21 Mar 1993 23:56:48 -0800 (PST)
+ Subject: Sample message
+ MIME-Version: 1.0
+ Content-type: multipart/mixed; boundary="simple boundary"
+
+ This is the preamble. It is to be ignored, though it
+ is a handy place for composition agents to include an
+ explanatory note to non-MIME conformant readers.
+
+ --simple boundary
+
+ This is implicitly typed plain US-ASCII text.
+ It does NOT end with a linebreak.
+ --simple boundary
+ Content-type: text/plain; charset=us-ascii
+
+ This is explicitly typed plain US-ASCII text.
+ It DOES end with a linebreak.
+
+ --simple boundary--
+
+ This is the epilogue. It is also to be ignored.
+
+
+
+
+
+
+Freed & Borenstein Standards Track [Page 21]
+\f
+RFC 2046 Media Types November 1996
+
+
+ The use of a media type of "multipart" in a body part within another
+ "multipart" entity is explicitly allowed. In such cases, for obvious
+ reasons, care must be taken to ensure that each nested "multipart"
+ entity uses a different boundary delimiter. See RFC 2049 for an
+ example of nested "multipart" entities.
+
+ The use of the "multipart" media type with only a single body part
+ may be useful in certain contexts, and is explicitly permitted.
+
+ NOTE: Experience has shown that a "multipart" media type with a
+ single body part is useful for sending non-text media types. It has
+ the advantage of providing the preamble as a place to include
+ decoding instructions. In addition, a number of SMTP gateways move
+ or remove the MIME headers, and a clever MIME decoder can take a good
+ guess at multipart boundaries even in the absence of the Content-Type
+ header and thereby successfully decode the message.
+
+ The only mandatory global parameter for the "multipart" media type is
+ the boundary parameter, which consists of 1 to 70 characters from a
+ set of characters known to be very robust through mail gateways, and
+ NOT ending with white space. (If a boundary delimiter line appears to
+ end with white space, the white space must be presumed to have been
+ added by a gateway, and must be deleted.) It is formally specified
+ by the following BNF:
+
+ boundary := 0*69<bchars> bcharsnospace
+
+ bchars := bcharsnospace / " "
+
+ bcharsnospace := DIGIT / ALPHA / "'" / "(" / ")" /
+ "+" / "_" / "," / "-" / "." /
+ "/" / ":" / "=" / "?"
+
+ Overall, the body of a "multipart" entity may be specified as
+ follows:
+
+ dash-boundary := "--" boundary
+ ; boundary taken from the value of
+ ; boundary parameter of the
+ ; Content-Type field.
+
+ multipart-body := [preamble CRLF]
+ dash-boundary transport-padding CRLF
+ body-part *encapsulation
+ close-delimiter transport-padding
+ [CRLF epilogue]
+
+
+
+
+
+Freed & Borenstein Standards Track [Page 22]
+\f
+RFC 2046 Media Types November 1996
+
+
+ transport-padding := *LWSP-char
+ ; Composers MUST NOT generate
+ ; non-zero length transport
+ ; padding, but receivers MUST
+ ; be able to handle padding
+ ; added by message transports.
+
+ encapsulation := delimiter transport-padding
+ CRLF body-part
+
+ delimiter := CRLF dash-boundary
+
+ close-delimiter := delimiter "--"
+
+ preamble := discard-text
+
+ epilogue := discard-text
+
+ discard-text := *(*text CRLF) *text
+ ; May be ignored or discarded.
+
+ body-part := MIME-part-headers [CRLF *OCTET]
+ ; Lines in a body-part must not start
+ ; with the specified dash-boundary and
+ ; the delimiter must not appear anywhere
+ ; in the body part. Note that the
+ ; semantics of a body-part differ from
+ ; the semantics of a message, as
+ ; described in the text.
+
+ OCTET := <any 0-255 octet value>
+
+ IMPORTANT: The free insertion of linear-white-space and RFC 822
+ comments between the elements shown in this BNF is NOT allowed since
+ this BNF does not specify a structured header field.
+
+ NOTE: In certain transport enclaves, RFC 822 restrictions such as
+ the one that limits bodies to printable US-ASCII characters may not
+ be in force. (That is, the transport domains may exist that resemble
+ standard Internet mail transport as specified in RFC 821 and assumed
+ by RFC 822, but without certain restrictions.) The relaxation of
+ these restrictions should be construed as locally extending the
+ definition of bodies, for example to include octets outside of the
+ US-ASCII range, as long as these extensions are supported by the
+ transport and adequately documented in the Content- Transfer-Encoding
+ header field. However, in no event are headers (either message
+ headers or body part headers) allowed to contain anything other than
+ US-ASCII characters.
+
+
+
+Freed & Borenstein Standards Track [Page 23]
+\f
+RFC 2046 Media Types November 1996
+
+
+ NOTE: Conspicuously missing from the "multipart" type is a notion of
+ structured, related body parts. It is recommended that those wishing
+ to provide more structured or integrated multipart messaging
+ facilities should define subtypes of multipart that are syntactically
+ identical but define relationships between the various parts. For
+ example, subtypes of multipart could be defined that include a
+ distinguished part which in turn is used to specify the relationships
+ between the other parts, probably referring to them by their
+ Content-ID field. Old implementations will not recognize the new
+ subtype if this approach is used, but will treat it as
+ multipart/mixed and will thus be able to show the user the parts that
+ are recognized.
+
+5.1.2. Handling Nested Messages and Multiparts
+
+ The "message/rfc822" subtype defined in a subsequent section of this
+ document has no terminating condition other than running out of data.
+ Similarly, an improperly truncated "multipart" entity may not have
+ any terminating boundary marker, and can turn up operationally due to
+ mail system malfunctions.
+
+ It is essential that such entities be handled correctly when they are
+ themselves imbedded inside of another "multipart" structure. MIME
+ implementations are therefore required to recognize outer level
+ boundary markers at ANY level of inner nesting. It is not sufficient
+ to only check for the next expected marker or other terminating
+ condition.
+
+5.1.3. Mixed Subtype
+
+ The "mixed" subtype of "multipart" is intended for use when the body
+ parts are independent and need to be bundled in a particular order.
+ Any "multipart" subtypes that an implementation does not recognize
+ must be treated as being of subtype "mixed".
+
+5.1.4. Alternative Subtype
+
+ The "multipart/alternative" type is syntactically identical to
+ "multipart/mixed", but the semantics are different. In particular,
+ each of the body parts is an "alternative" version of the same
+ information.
+
+ Systems should recognize that the content of the various parts are
+ interchangeable. Systems should choose the "best" type based on the
+ local environment and references, in some cases even through user
+ interaction. As with "multipart/mixed", the order of body parts is
+ significant. In this case, the alternatives appear in an order of
+ increasing faithfulness to the original content. In general, the
+
+
+
+Freed & Borenstein Standards Track [Page 24]
+\f
+RFC 2046 Media Types November 1996
+
+
+ best choice is the LAST part of a type supported by the recipient
+ system's local environment.
+
+ "Multipart/alternative" may be used, for example, to send a message
+ in a fancy text format in such a way that it can easily be displayed
+ anywhere:
+
+ From: Nathaniel Borenstein <nsb@bellcore.com>
+ To: Ned Freed <ned@innosoft.com>
+ Date: Mon, 22 Mar 1993 09:41:09 -0800 (PST)
+ Subject: Formatted text mail
+ MIME-Version: 1.0
+ Content-Type: multipart/alternative; boundary=boundary42
+
+ --boundary42
+ Content-Type: text/plain; charset=us-ascii
+
+ ... plain text version of message goes here ...
+
+ --boundary42
+ Content-Type: text/enriched
+
+ ... RFC 1896 text/enriched version of same message
+ goes here ...
+
+ --boundary42
+ Content-Type: application/x-whatever
+
+ ... fanciest version of same message goes here ...
+
+ --boundary42--
+
+ In this example, users whose mail systems understood the
+ "application/x-whatever" format would see only the fancy version,
+ while other users would see only the enriched or plain text version,
+ depending on the capabilities of their system.
+
+ In general, user agents that compose "multipart/alternative" entities
+ must place the body parts in increasing order of preference, that is,
+ with the preferred format last. For fancy text, the sending user
+ agent should put the plainest format first and the richest format
+ last. Receiving user agents should pick and display the last format
+ they are capable of displaying. In the case where one of the
+ alternatives is itself of type "multipart" and contains unrecognized
+ sub-parts, the user agent may choose either to show that alternative,
+ an earlier alternative, or both.
+
+
+
+
+
+Freed & Borenstein Standards Track [Page 25]
+\f
+RFC 2046 Media Types November 1996
+
+
+ NOTE: From an implementor's perspective, it might seem more sensible
+ to reverse this ordering, and have the plainest alternative last.
+ However, placing the plainest alternative first is the friendliest
+ possible option when "multipart/alternative" entities are viewed
+ using a non-MIME-conformant viewer. While this approach does impose
+ some burden on conformant MIME viewers, interoperability with older
+ mail readers was deemed to be more important in this case.
+
+ It may be the case that some user agents, if they can recognize more
+ than one of the formats, will prefer to offer the user the choice of
+ which format to view. This makes sense, for example, if a message
+ includes both a nicely- formatted image version and an easily-edited
+ text version. What is most critical, however, is that the user not
+ automatically be shown multiple versions of the same data. Either
+ the user should be shown the last recognized version or should be
+ given the choice.
+
+ THE SEMANTICS OF CONTENT-ID IN MULTIPART/ALTERNATIVE: Each part of a
+ "multipart/alternative" entity represents the same data, but the
+ mappings between the two are not necessarily without information
+ loss. For example, information is lost when translating ODA to
+ PostScript or plain text. It is recommended that each part should
+ have a different Content-ID value in the case where the information
+ content of the two parts is not identical. And when the information
+ content is identical -- for example, where several parts of type
+ "message/external-body" specify alternate ways to access the
+ identical data -- the same Content-ID field value should be used, to
+ optimize any caching mechanisms that might be present on the
+ recipient's end. However, the Content-ID values used by the parts
+ should NOT be the same Content-ID value that describes the
+ "multipart/alternative" as a whole, if there is any such Content-ID
+ field. That is, one Content-ID value will refer to the
+ "multipart/alternative" entity, while one or more other Content-ID
+ values will refer to the parts inside it.
+
+5.1.5. Digest Subtype
+
+ This document defines a "digest" subtype of the "multipart" Content-
+ Type. This type is syntactically identical to "multipart/mixed", but
+ the semantics are different. In particular, in a digest, the default
+ Content-Type value for a body part is changed from "text/plain" to
+ "message/rfc822". This is done to allow a more readable digest
+ format that is largely compatible (except for the quoting convention)
+ with RFC 934.
+
+ Note: Though it is possible to specify a Content-Type value for a
+ body part in a digest which is other than "message/rfc822", such as a
+ "text/plain" part containing a description of the material in the
+
+
+
+Freed & Borenstein Standards Track [Page 26]
+\f
+RFC 2046 Media Types November 1996
+
+
+ digest, actually doing so is undesireble. The "multipart/digest"
+ Content-Type is intended to be used to send collections of messages.
+ If a "text/plain" part is needed, it should be included as a seperate
+ part of a "multipart/mixed" message.
+
+ A digest in this format might, then, look something like this:
+
+ From: Moderator-Address
+ To: Recipient-List
+ Date: Mon, 22 Mar 1994 13:34:51 +0000
+ Subject: Internet Digest, volume 42
+ MIME-Version: 1.0
+ Content-Type: multipart/mixed;
+ boundary="---- main boundary ----"
+
+ ------ main boundary ----
+
+ ...Introductory text or table of contents...
+
+ ------ main boundary ----
+ Content-Type: multipart/digest;
+ boundary="---- next message ----"
+
+ ------ next message ----
+
+ From: someone-else
+ Date: Fri, 26 Mar 1993 11:13:32 +0200
+ Subject: my opinion
+
+ ...body goes here ...
+
+ ------ next message ----
+
+ From: someone-else-again
+ Date: Fri, 26 Mar 1993 10:07:13 -0500
+ Subject: my different opinion
+
+ ... another body goes here ...
+
+ ------ next message ------
+
+ ------ main boundary ------
+
+5.1.6. Parallel Subtype
+
+ This document defines a "parallel" subtype of the "multipart"
+ Content-Type. This type is syntactically identical to
+ "multipart/mixed", but the semantics are different. In particular,
+
+
+
+Freed & Borenstein Standards Track [Page 27]
+\f
+RFC 2046 Media Types November 1996
+
+
+ in a parallel entity, the order of body parts is not significant.
+
+ A common presentation of this type is to display all of the parts
+ simultaneously on hardware and software that are capable of doing so.
+ However, composing agents should be aware that many mail readers will
+ lack this capability and will show the parts serially in any event.
+
+5.1.7. Other Multipart Subtypes
+
+ Other "multipart" subtypes are expected in the future. MIME
+ implementations must in general treat unrecognized subtypes of
+ "multipart" as being equivalent to "multipart/mixed".
+
+5.2. Message Media Type
+
+ It is frequently desirable, in sending mail, to encapsulate another
+ mail message. A special media type, "message", is defined to
+ facilitate this. In particular, the "rfc822" subtype of "message" is
+ used to encapsulate RFC 822 messages.
+
+ NOTE: It has been suggested that subtypes of "message" might be
+ defined for forwarded or rejected messages. However, forwarded and
+ rejected messages can be handled as multipart messages in which the
+ first part contains any control or descriptive information, and a
+ second part, of type "message/rfc822", is the forwarded or rejected
+ message. Composing rejection and forwarding messages in this manner
+ will preserve the type information on the original message and allow
+ it to be correctly presented to the recipient, and hence is strongly
+ encouraged.
+
+ Subtypes of "message" often impose restrictions on what encodings are
+ allowed. These restrictions are described in conjunction with each
+ specific subtype.
+
+ Mail gateways, relays, and other mail handling agents are commonly
+ known to alter the top-level header of an RFC 822 message. In
+ particular, they frequently add, remove, or reorder header fields.
+ These operations are explicitly forbidden for the encapsulated
+ headers embedded in the bodies of messages of type "message."
+
+5.2.1. RFC822 Subtype
+
+ A media type of "message/rfc822" indicates that the body contains an
+ encapsulated message, with the syntax of an RFC 822 message.
+ However, unlike top-level RFC 822 messages, the restriction that each
+ "message/rfc822" body must include a "From", "Date", and at least one
+ destination header is removed and replaced with the requirement that
+ at least one of "From", "Subject", or "Date" must be present.
+
+
+
+Freed & Borenstein Standards Track [Page 28]
+\f
+RFC 2046 Media Types November 1996
+
+
+ It should be noted that, despite the use of the numbers "822", a
+ "message/rfc822" entity isn't restricted to material in strict
+ conformance to RFC822, nor are the semantics of "message/rfc822"
+ objects restricted to the semantics defined in RFC822. More
+ specifically, a "message/rfc822" message could well be a News article
+ or a MIME message.
+
+ No encoding other than "7bit", "8bit", or "binary" is permitted for
+ the body of a "message/rfc822" entity. The message header fields are
+ always US-ASCII in any case, and data within the body can still be
+ encoded, in which case the Content-Transfer-Encoding header field in
+ the encapsulated message will reflect this. Non-US-ASCII text in the
+ headers of an encapsulated message can be specified using the
+ mechanisms described in RFC 2047.
+
+5.2.2. Partial Subtype
+
+ The "partial" subtype is defined to allow large entities to be
+ delivered as several separate pieces of mail and automatically
+ reassembled by a receiving user agent. (The concept is similar to IP
+ fragmentation and reassembly in the basic Internet Protocols.) This
+ mechanism can be used when intermediate transport agents limit the
+ size of individual messages that can be sent. The media type
+ "message/partial" thus indicates that the body contains a fragment of
+ a larger entity.
+
+ Because data of type "message" may never be encoded in base64 or
+ quoted-printable, a problem might arise if "message/partial" entities
+ are constructed in an environment that supports binary or 8bit
+ transport. The problem is that the binary data would be split into
+ multiple "message/partial" messages, each of them requiring binary
+ transport. If such messages were encountered at a gateway into a
+ 7bit transport environment, there would be no way to properly encode
+ them for the 7bit world, aside from waiting for all of the fragments,
+ reassembling the inner message, and then encoding the reassembled
+ data in base64 or quoted-printable. Since it is possible that
+ different fragments might go through different gateways, even this is
+ not an acceptable solution. For this reason, it is specified that
+ entities of type "message/partial" must always have a content-
+ transfer-encoding of 7bit (the default). In particular, even in
+ environments that support binary or 8bit transport, the use of a
+ content- transfer-encoding of "8bit" or "binary" is explicitly
+ prohibited for MIME entities of type "message/partial". This in turn
+ implies that the inner message must not use "8bit" or "binary"
+ encoding.
+
+
+
+
+
+
+Freed & Borenstein Standards Track [Page 29]
+\f
+RFC 2046 Media Types November 1996
+
+
+ Because some message transfer agents may choose to automatically
+ fragment large messages, and because such agents may use very
+ different fragmentation thresholds, it is possible that the pieces of
+ a partial message, upon reassembly, may prove themselves to comprise
+ a partial message. This is explicitly permitted.
+
+ Three parameters must be specified in the Content-Type field of type
+ "message/partial": The first, "id", is a unique identifier, as close
+ to a world-unique identifier as possible, to be used to match the
+ fragments together. (In general, the identifier is essentially a
+ message-id; if placed in double quotes, it can be ANY message-id, in
+ accordance with the BNF for "parameter" given in RFC 2045.) The
+ second, "number", an integer, is the fragment number, which indicates
+ where this fragment fits into the sequence of fragments. The third,
+ "total", another integer, is the total number of fragments. This
+ third subfield is required on the final fragment, and is optional
+ (though encouraged) on the earlier fragments. Note also that these
+ parameters may be given in any order.
+
+ Thus, the second piece of a 3-piece message may have either of the
+ following header fields:
+
+ Content-Type: Message/Partial; number=2; total=3;
+ id="oc=jpbe0M2Yt4s@thumper.bellcore.com"
+
+ Content-Type: Message/Partial;
+ id="oc=jpbe0M2Yt4s@thumper.bellcore.com";
+ number=2
+
+ But the third piece MUST specify the total number of fragments:
+
+ Content-Type: Message/Partial; number=3; total=3;
+ id="oc=jpbe0M2Yt4s@thumper.bellcore.com"
+
+ Note that fragment numbering begins with 1, not 0.
+
+ When the fragments of an entity broken up in this manner are put
+ together, the result is always a complete MIME entity, which may have
+ its own Content-Type header field, and thus may contain any other
+ data type.
+
+5.2.2.1. Message Fragmentation and Reassembly
+
+ The semantics of a reassembled partial message must be those of the
+ "inner" message, rather than of a message containing the inner
+ message. This makes it possible, for example, to send a large audio
+ message as several partial messages, and still have it appear to the
+ recipient as a simple audio message rather than as an encapsulated
+
+
+
+Freed & Borenstein Standards Track [Page 30]
+\f
+RFC 2046 Media Types November 1996
+
+
+ message containing an audio message. That is, the encapsulation of
+ the message is considered to be "transparent".
+
+ When generating and reassembling the pieces of a "message/partial"
+ message, the headers of the encapsulated message must be merged with
+ the headers of the enclosing entities. In this process the following
+ rules must be observed:
+
+ (1) Fragmentation agents must split messages at line
+ boundaries only. This restriction is imposed because
+ splits at points other than the ends of lines in turn
+ depends on message transports being able to preserve
+ the semantics of messages that don't end with a CRLF
+ sequence. Many transports are incapable of preserving
+ such semantics.
+
+ (2) All of the header fields from the initial enclosing
+ message, except those that start with "Content-" and
+ the specific header fields "Subject", "Message-ID",
+ "Encrypted", and "MIME-Version", must be copied, in
+ order, to the new message.
+
+ (3) The header fields in the enclosed message which start
+ with "Content-", plus the "Subject", "Message-ID",
+ "Encrypted", and "MIME-Version" fields, must be
+ appended, in order, to the header fields of the new
+ message. Any header fields in the enclosed message
+ which do not start with "Content-" (except for the
+ "Subject", "Message-ID", "Encrypted", and "MIME-
+ Version" fields) will be ignored and dropped.
+
+ (4) All of the header fields from the second and any
+ subsequent enclosing messages are discarded by the
+ reassembly process.
+
+5.2.2.2. Fragmentation and Reassembly Example
+
+ If an audio message is broken into two pieces, the first piece might
+ look something like this:
+
+ X-Weird-Header-1: Foo
+ From: Bill@host.com
+ To: joe@otherhost.com
+ Date: Fri, 26 Mar 1993 12:59:38 -0500 (EST)
+ Subject: Audio mail (part 1 of 2)
+ Message-ID: <id1@host.com>
+ MIME-Version: 1.0
+ Content-type: message/partial; id="ABC@host.com";
+
+
+
+Freed & Borenstein Standards Track [Page 31]
+\f
+RFC 2046 Media Types November 1996
+
+
+ number=1; total=2
+
+ X-Weird-Header-1: Bar
+ X-Weird-Header-2: Hello
+ Message-ID: <anotherid@foo.com>
+ Subject: Audio mail
+ MIME-Version: 1.0
+ Content-type: audio/basic
+ Content-transfer-encoding: base64
+
+ ... first half of encoded audio data goes here ...
+
+ and the second half might look something like this:
+
+ From: Bill@host.com
+ To: joe@otherhost.com
+ Date: Fri, 26 Mar 1993 12:59:38 -0500 (EST)
+ Subject: Audio mail (part 2 of 2)
+ MIME-Version: 1.0
+ Message-ID: <id2@host.com>
+ Content-type: message/partial;
+ id="ABC@host.com"; number=2; total=2
+
+ ... second half of encoded audio data goes here ...
+
+ Then, when the fragmented message is reassembled, the resulting
+ message to be displayed to the user should look something like this:
+
+ X-Weird-Header-1: Foo
+ From: Bill@host.com
+ To: joe@otherhost.com
+ Date: Fri, 26 Mar 1993 12:59:38 -0500 (EST)
+ Subject: Audio mail
+ Message-ID: <anotherid@foo.com>
+ MIME-Version: 1.0
+ Content-type: audio/basic
+ Content-transfer-encoding: base64
+
+ ... first half of encoded audio data goes here ...
+ ... second half of encoded audio data goes here ...
+
+ The inclusion of a "References" field in the headers of the second
+ and subsequent pieces of a fragmented message that references the
+ Message-Id on the previous piece may be of benefit to mail readers
+ that understand and track references. However, the generation of
+ such "References" fields is entirely optional.
+
+
+
+
+
+Freed & Borenstein Standards Track [Page 32]
+\f
+RFC 2046 Media Types November 1996
+
+
+ Finally, it should be noted that the "Encrypted" header field has
+ been made obsolete by Privacy Enhanced Messaging (PEM) [RFC-1421,
+ RFC-1422, RFC-1423, RFC-1424], but the rules above are nevertheless
+ believed to describe the correct way to treat it if it is encountered
+ in the context of conversion to and from "message/partial" fragments.
+
+5.2.3. External-Body Subtype
+
+ The external-body subtype indicates that the actual body data are not
+ included, but merely referenced. In this case, the parameters
+ describe a mechanism for accessing the external data.
+
+ When a MIME entity is of type "message/external-body", it consists of
+ a header, two consecutive CRLFs, and the message header for the
+ encapsulated message. If another pair of consecutive CRLFs appears,
+ this of course ends the message header for the encapsulated message.
+ However, since the encapsulated message's body is itself external, it
+ does NOT appear in the area that follows. For example, consider the
+ following message:
+
+ Content-type: message/external-body;
+ access-type=local-file;
+ name="/u/nsb/Me.jpeg"
+
+ Content-type: image/jpeg
+ Content-ID: <id42@guppylake.bellcore.com>
+ Content-Transfer-Encoding: binary
+
+ THIS IS NOT REALLY THE BODY!
+
+ The area at the end, which might be called the "phantom body", is
+ ignored for most external-body messages. However, it may be used to
+ contain auxiliary information for some such messages, as indeed it is
+ when the access-type is "mail- server". The only access-type defined
+ in this document that uses the phantom body is "mail-server", but
+ other access-types may be defined in the future in other
+ specifications that use this area.
+
+ The encapsulated headers in ALL "message/external-body" entities MUST
+ include a Content-ID header field to give a unique identifier by
+ which to reference the data. This identifier may be used for caching
+ mechanisms, and for recognizing the receipt of the data when the
+ access-type is "mail-server".
+
+ Note that, as specified here, the tokens that describe external-body
+ data, such as file names and mail server commands, are required to be
+ in the US-ASCII character set.
+
+
+
+
+Freed & Borenstein Standards Track [Page 33]
+\f
+RFC 2046 Media Types November 1996
+
+
+ If this proves problematic in practice, a new mechanism may be
+ required as a future extension to MIME, either as newly defined
+ access-types for "message/external-body" or by some other mechanism.
+
+ As with "message/partial", MIME entities of type "message/external-
+ body" MUST have a content-transfer-encoding of 7bit (the default).
+ In particular, even in environments that support binary or 8bit
+ transport, the use of a content- transfer-encoding of "8bit" or
+ "binary" is explicitly prohibited for entities of type
+ "message/external-body".
+
+5.2.3.1. General External-Body Parameters
+
+ The parameters that may be used with any "message/external- body"
+ are:
+
+ (1) ACCESS-TYPE -- A word indicating the supported access
+ mechanism by which the file or data may be obtained.
+ This word is not case sensitive. Values include, but
+ are not limited to, "FTP", "ANON-FTP", "TFTP", "LOCAL-
+ FILE", and "MAIL-SERVER". Future values, except for
+ experimental values beginning with "X-", must be
+ registered with IANA, as described in RFC 2048.
+ This parameter is unconditionally mandatory and MUST be
+ present on EVERY "message/external-body".
+
+ (2) EXPIRATION -- The date (in the RFC 822 "date-time"
+ syntax, as extended by RFC 1123 to permit 4 digits in
+ the year field) after which the existence of the
+ external data is not guaranteed. This parameter may be
+ used with ANY access-type and is ALWAYS optional.
+
+ (3) SIZE -- The size (in octets) of the data. The intent
+ of this parameter is to help the recipient decide
+ whether or not to expend the necessary resources to
+ retrieve the external data. Note that this describes
+ the size of the data in its canonical form, that is,
+ before any Content-Transfer-Encoding has been applied
+ or after the data have been decoded. This parameter
+ may be used with ANY access-type and is ALWAYS
+ optional.
+
+ (4) PERMISSION -- A case-insensitive field that indicates
+ whether or not it is expected that clients might also
+ attempt to overwrite the data. By default, or if
+ permission is "read", the assumption is that they are
+ not, and that if the data is retrieved once, it is
+ never needed again. If PERMISSION is "read-write",
+
+
+
+Freed & Borenstein Standards Track [Page 34]
+\f
+RFC 2046 Media Types November 1996
+
+
+ this assumption is invalid, and any local copy must be
+ considered no more than a cache. "Read" and "Read-
+ write" are the only defined values of permission. This
+ parameter may be used with ANY access-type and is
+ ALWAYS optional.
+
+ The precise semantics of the access-types defined here are described
+ in the sections that follow.
+
+5.2.3.2. The 'ftp' and 'tftp' Access-Types
+
+ An access-type of FTP or TFTP indicates that the message body is
+ accessible as a file using the FTP [RFC-959] or TFTP [RFC- 783]
+ protocols, respectively. For these access-types, the following
+ additional parameters are mandatory:
+
+ (1) NAME -- The name of the file that contains the actual
+ body data.
+
+ (2) SITE -- A machine from which the file may be obtained,
+ using the given protocol. This must be a fully
+ qualified domain name, not a nickname.
+
+ (3) Before any data are retrieved, using FTP, the user will
+ generally need to be asked to provide a login id and a
+ password for the machine named by the site parameter.
+ For security reasons, such an id and password are not
+ specified as content-type parameters, but must be
+ obtained from the user.
+
+ In addition, the following parameters are optional:
+
+ (1) DIRECTORY -- A directory from which the data named by
+ NAME should be retrieved.
+
+ (2) MODE -- A case-insensitive string indicating the mode
+ to be used when retrieving the information. The valid
+ values for access-type "TFTP" are "NETASCII", "OCTET",
+ and "MAIL", as specified by the TFTP protocol [RFC-
+ 783]. The valid values for access-type "FTP" are
+ "ASCII", "EBCDIC", "IMAGE", and "LOCALn" where "n" is a
+ decimal integer, typically 8. These correspond to the
+ representation types "A" "E" "I" and "L n" as specified
+ by the FTP protocol [RFC-959]. Note that "BINARY" and
+ "TENEX" are not valid values for MODE and that "OCTET"
+ or "IMAGE" or "LOCAL8" should be used instead. IF MODE
+ is not specified, the default value is "NETASCII" for
+ TFTP and "ASCII" otherwise.
+
+
+
+Freed & Borenstein Standards Track [Page 35]
+\f
+RFC 2046 Media Types November 1996
+
+
+5.2.3.3. The 'anon-ftp' Access-Type
+
+ The "anon-ftp" access-type is identical to the "ftp" access type,
+ except that the user need not be asked to provide a name and password
+ for the specified site. Instead, the ftp protocol will be used with
+ login "anonymous" and a password that corresponds to the user's mail
+ address.
+
+5.2.3.4. The 'local-file' Access-Type
+
+ An access-type of "local-file" indicates that the actual body is
+ accessible as a file on the local machine. Two additional parameters
+ are defined for this access type:
+
+ (1) NAME -- The name of the file that contains the actual
+ body data. This parameter is mandatory for the
+ "local-file" access-type.
+
+ (2) SITE -- A domain specifier for a machine or set of
+ machines that are known to have access to the data
+ file. This optional parameter is used to describe the
+ locality of reference for the data, that is, the site
+ or sites at which the file is expected to be visible.
+ Asterisks may be used for wildcard matching to a part
+ of a domain name, such as "*.bellcore.com", to indicate
+ a set of machines on which the data should be directly
+ visible, while a single asterisk may be used to
+ indicate a file that is expected to be universally
+ available, e.g., via a global file system.
+
+5.2.3.5. The 'mail-server' Access-Type
+
+ The "mail-server" access-type indicates that the actual body is
+ available from a mail server. Two additional parameters are defined
+ for this access-type:
+
+ (1) SERVER -- The addr-spec of the mail server from which
+ the actual body data can be obtained. This parameter
+ is mandatory for the "mail-server" access-type.
+
+ (2) SUBJECT -- The subject that is to be used in the mail
+ that is sent to obtain the data. Note that keying mail
+ servers on Subject lines is NOT recommended, but such
+ mail servers are known to exist. This is an optional
+ parameter.
+
+
+
+
+
+
+Freed & Borenstein Standards Track [Page 36]
+\f
+RFC 2046 Media Types November 1996
+
+
+ Because mail servers accept a variety of syntaxes, some of which is
+ multiline, the full command to be sent to a mail server is not
+ included as a parameter in the content-type header field. Instead,
+ it is provided as the "phantom body" when the media type is
+ "message/external-body" and the access-type is mail-server.
+
+ Note that MIME does not define a mail server syntax. Rather, it
+ allows the inclusion of arbitrary mail server commands in the phantom
+ body. Implementations must include the phantom body in the body of
+ the message it sends to the mail server address to retrieve the
+ relevant data.
+
+ Unlike other access-types, mail-server access is asynchronous and
+ will happen at an unpredictable time in the future. For this reason,
+ it is important that there be a mechanism by which the returned data
+ can be matched up with the original "message/external-body" entity.
+ MIME mail servers must use the same Content-ID field on the returned
+ message that was used in the original "message/external-body"
+ entities, to facilitate such matching.
+
+5.2.3.6. External-Body Security Issues
+
+ "Message/external-body" entities give rise to two important security
+ issues:
+
+ (1) Accessing data via a "message/external-body" reference
+ effectively results in the message recipient performing
+ an operation that was specified by the message
+ originator. It is therefore possible for the message
+ originator to trick a recipient into doing something
+ they would not have done otherwise. For example, an
+ originator could specify a action that attempts
+ retrieval of material that the recipient is not
+ authorized to obtain, causing the recipient to
+ unwittingly violate some security policy. For this
+ reason, user agents capable of resolving external
+ references must always take steps to describe the
+ action they are to take to the recipient and ask for
+ explicit permisssion prior to performing it.
+
+ The 'mail-server' access-type is particularly
+ vulnerable, in that it causes the recipient to send a
+ new message whose contents are specified by the
+ original message's originator. Given the potential for
+ abuse, any such request messages that are constructed
+ should contain a clear indication that they were
+ generated automatically (e.g. in a Comments: header
+ field) in an attempt to resolve a MIME
+
+
+
+Freed & Borenstein Standards Track [Page 37]
+\f
+RFC 2046 Media Types November 1996
+
+
+ "message/external-body" reference.
+
+ (2) MIME will sometimes be used in environments that
+ provide some guarantee of message integrity and
+ authenticity. If present, such guarantees may apply
+ only to the actual direct content of messages -- they
+ may or may not apply to data accessed through MIME's
+ "message/external-body" mechanism. In particular, it
+ may be possible to subvert certain access mechanisms
+ even when the messaging system itself is secure.
+
+ It should be noted that this problem exists either with
+ or without the availabilty of MIME mechanisms. A
+ casual reference to an FTP site containing a document
+ in the text of a secure message brings up similar
+ issues -- the only difference is that MIME provides for
+ automatic retrieval of such material, and users may
+ place unwarranted trust is such automatic retrieval
+ mechanisms.
+
+5.2.3.7. Examples and Further Explanations
+
+ When the external-body mechanism is used in conjunction with the
+ "multipart/alternative" media type it extends the functionality of
+ "multipart/alternative" to include the case where the same entity is
+ provided in the same format but via different accces mechanisms.
+ When this is done the originator of the message must order the parts
+ first in terms of preferred formats and then by preferred access
+ mechanisms. The recipient's viewer should then evaluate the list
+ both in terms of format and access mechanisms.
+
+ With the emerging possibility of very wide-area file systems, it
+ becomes very hard to know in advance the set of machines where a file
+ will and will not be accessible directly from the file system.
+ Therefore it may make sense to provide both a file name, to be tried
+ directly, and the name of one or more sites from which the file is
+ known to be accessible. An implementation can try to retrieve remote
+ files using FTP or any other protocol, using anonymous file retrieval
+ or prompting the user for the necessary name and password. If an
+ external body is accessible via multiple mechanisms, the sender may
+ include multiple entities of type "message/external-body" within the
+ body parts of an enclosing "multipart/alternative" entity.
+
+ However, the external-body mechanism is not intended to be limited to
+ file retrieval, as shown by the mail-server access-type. Beyond
+ this, one can imagine, for example, using a video server for external
+ references to video clips.
+
+
+
+
+Freed & Borenstein Standards Track [Page 38]
+\f
+RFC 2046 Media Types November 1996
+
+
+ The embedded message header fields which appear in the body of the
+ "message/external-body" data must be used to declare the media type
+ of the external body if it is anything other than plain US-ASCII
+ text, since the external body does not have a header section to
+ declare its type. Similarly, any Content-transfer-encoding other
+ than "7bit" must also be declared here. Thus a complete
+ "message/external-body" message, referring to an object in PostScript
+ format, might look like this:
+
+ From: Whomever
+ To: Someone
+ Date: Whenever
+ Subject: whatever
+ MIME-Version: 1.0
+ Message-ID: <id1@host.com>
+ Content-Type: multipart/alternative; boundary=42
+ Content-ID: <id001@guppylake.bellcore.com>
+
+ --42
+ Content-Type: message/external-body; name="BodyFormats.ps";
+ site="thumper.bellcore.com"; mode="image";
+ access-type=ANON-FTP; directory="pub";
+ expiration="Fri, 14 Jun 1991 19:13:14 -0400 (EDT)"
+
+ Content-type: application/postscript
+ Content-ID: <id42@guppylake.bellcore.com>
+
+ --42
+ Content-Type: message/external-body; access-type=local-file;
+ name="/u/nsb/writing/rfcs/RFC-MIME.ps";
+ site="thumper.bellcore.com";
+ expiration="Fri, 14 Jun 1991 19:13:14 -0400 (EDT)"
+
+ Content-type: application/postscript
+ Content-ID: <id42@guppylake.bellcore.com>
+
+ --42
+ Content-Type: message/external-body;
+ access-type=mail-server
+ server="listserv@bogus.bitnet";
+ expiration="Fri, 14 Jun 1991 19:13:14 -0400 (EDT)"
+
+ Content-type: application/postscript
+ Content-ID: <id42@guppylake.bellcore.com>
+
+ get RFC-MIME.DOC
+
+ --42--
+
+
+
+Freed & Borenstein Standards Track [Page 39]
+\f
+RFC 2046 Media Types November 1996
+
+
+ Note that in the above examples, the default Content-transfer-
+ encoding of "7bit" is assumed for the external postscript data.
+
+ Like the "message/partial" type, the "message/external-body" media
+ type is intended to be transparent, that is, to convey the data type
+ in the external body rather than to convey a message with a body of
+ that type. Thus the headers on the outer and inner parts must be
+ merged using the same rules as for "message/partial". In particular,
+ this means that the Content-type and Subject fields are overridden,
+ but the From field is preserved.
+
+ Note that since the external bodies are not transported along with
+ the external body reference, they need not conform to transport
+ limitations that apply to the reference itself. In particular,
+ Internet mail transports may impose 7bit and line length limits, but
+ these do not automatically apply to binary external body references.
+ Thus a Content-Transfer-Encoding is not generally necessary, though
+ it is permitted.
+
+ Note that the body of a message of type "message/external-body" is
+ governed by the basic syntax for an RFC 822 message. In particular,
+ anything before the first consecutive pair of CRLFs is header
+ information, while anything after it is body information, which is
+ ignored for most access-types.
+
+5.2.4. Other Message Subtypes
+
+ MIME implementations must in general treat unrecognized subtypes of
+ "message" as being equivalent to "application/octet-stream".
+
+ Future subtypes of "message" intended for use with email should be
+ restricted to "7bit" encoding. A type other than "message" should be
+ used if restriction to "7bit" is not possible.
+
+6. Experimental Media Type Values
+
+ A media type value beginning with the characters "X-" is a private
+ value, to be used by consenting systems by mutual agreement. Any
+ format without a rigorous and public definition must be named with an
+ "X-" prefix, and publicly specified values shall never begin with
+ "X-". (Older versions of the widely used Andrew system use the "X-
+ BE2" name, so new systems should probably choose a different name.)
+
+ In general, the use of "X-" top-level types is strongly discouraged.
+ Implementors should invent subtypes of the existing types whenever
+ possible. In many cases, a subtype of "application" will be more
+ appropriate than a new top-level type.
+
+
+
+
+Freed & Borenstein Standards Track [Page 40]
+\f
+RFC 2046 Media Types November 1996
+
+
+7. Summary
+
+ The five discrete media types provide provide a standardized
+ mechanism for tagging entities as "audio", "image", or several other
+ kinds of data. The composite "multipart" and "message" media types
+ allow mixing and hierarchical structuring of entities of different
+ types in a single message. A distinguished parameter syntax allows
+ further specification of data format details, particularly the
+ specification of alternate character sets. Additional optional
+ header fields provide mechanisms for certain extensions deemed
+ desirable by many implementors. Finally, a number of useful media
+ types are defined for general use by consenting user agents, notably
+ "message/partial" and "message/external-body".
+
+9. Security Considerations
+
+ Security issues are discussed in the context of the
+ "application/postscript" type, the "message/external-body" type, and
+ in RFC 2048. Implementors should pay special attention to the
+ security implications of any media types that can cause the remote
+ execution of any actions in the recipient's environment. In such
+ cases, the discussion of the "application/postscript" type may serve
+ as a model for considering other media types with remote execution
+ capabilities.
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+Freed & Borenstein Standards Track [Page 41]
+\f
+RFC 2046 Media Types November 1996
+
+
+9. Authors' Addresses
+
+ For more information, the authors of this document are best contacted
+ via Internet mail:
+
+ Ned Freed
+ Innosoft International, Inc.
+ 1050 East Garvey Avenue South
+ West Covina, CA 91790
+ USA
+
+ Phone: +1 818 919 3600
+ Fax: +1 818 919 3614
+ EMail: ned@innosoft.com
+
+
+ Nathaniel S. Borenstein
+ First Virtual Holdings
+ 25 Washington Avenue
+ Morristown, NJ 07960
+ USA
+
+ Phone: +1 201 540 8967
+ Fax: +1 201 993 3032
+ EMail: nsb@nsb.fv.com
+
+
+ MIME is a result of the work of the Internet Engineering Task Force
+ Working Group on RFC 822 Extensions. The chairman of that group,
+ Greg Vaudreuil, may be reached at:
+
+ Gregory M. Vaudreuil
+ Octel Network Services
+ 17080 Dallas Parkway
+ Dallas, TX 75248-1905
+ USA
+
+ EMail: Greg.Vaudreuil@Octel.Com
+
+
+
+
+
+
+
+
+
+
+
+
+
+Freed & Borenstein Standards Track [Page 42]
+\f
+RFC 2046 Media Types November 1996
+
+
+Appendix A -- Collected Grammar
+
+ This appendix contains the complete BNF grammar for all the syntax
+ specified by this document.
+
+ By itself, however, this grammar is incomplete. It refers by name to
+ several syntax rules that are defined by RFC 822. Rather than
+ reproduce those definitions here, and risk unintentional differences
+ between the two, this document simply refers the reader to RFC 822
+ for the remaining definitions. Wherever a term is undefined, it
+ refers to the RFC 822 definition.
+
+ boundary := 0*69<bchars> bcharsnospace
+
+ bchars := bcharsnospace / " "
+
+ bcharsnospace := DIGIT / ALPHA / "'" / "(" / ")" /
+ "+" / "_" / "," / "-" / "." /
+ "/" / ":" / "=" / "?"
+
+ body-part := <"message" as defined in RFC 822, with all
+ header fields optional, not starting with the
+ specified dash-boundary, and with the
+ delimiter not occurring anywhere in the
+ body part. Note that the semantics of a
+ part differ from the semantics of a message,
+ as described in the text.>
+
+ close-delimiter := delimiter "--"
+
+ dash-boundary := "--" boundary
+ ; boundary taken from the value of
+ ; boundary parameter of the
+ ; Content-Type field.
+
+ delimiter := CRLF dash-boundary
+
+ discard-text := *(*text CRLF)
+ ; May be ignored or discarded.
+
+ encapsulation := delimiter transport-padding
+ CRLF body-part
+
+ epilogue := discard-text
+
+ multipart-body := [preamble CRLF]
+ dash-boundary transport-padding CRLF
+ body-part *encapsulation
+
+
+
+Freed & Borenstein Standards Track [Page 43]
+\f
+RFC 2046 Media Types November 1996
+
+
+ close-delimiter transport-padding
+ [CRLF epilogue]
+
+ preamble := discard-text
+
+ transport-padding := *LWSP-char
+ ; Composers MUST NOT generate
+ ; non-zero length transport
+ ; padding, but receivers MUST
+ ; be able to handle padding
+ ; added by message transports.
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+Freed & Borenstein Standards Track [Page 44]
+\f
--- /dev/null
+
+
+
+
+
+
+Network Working Group K. Moore
+Request for Comments: 2047 University of Tennessee
+Obsoletes: 1521, 1522, 1590 November 1996
+Category: Standards Track
+
+
+ MIME (Multipurpose Internet Mail Extensions) Part Three:
+ Message Header Extensions for Non-ASCII Text
+
+Status of this Memo
+
+ This document specifies an Internet standards track protocol for the
+ Internet community, and requests discussion and suggestions for
+ improvements. Please refer to the current edition of the "Internet
+ Official Protocol Standards" (STD 1) for the standardization state
+ and status of this protocol. Distribution of this memo is unlimited.
+
+Abstract
+
+ STD 11, RFC 822, defines a message representation protocol specifying
+ considerable detail about US-ASCII message headers, and leaves the
+ message content, or message body, as flat US-ASCII text. This set of
+ documents, collectively called the Multipurpose Internet Mail
+ Extensions, or MIME, redefines the format of messages to allow for
+
+ (1) textual message bodies in character sets other than US-ASCII,
+
+ (2) an extensible set of different formats for non-textual message
+ bodies,
+
+ (3) multi-part message bodies, and
+
+ (4) textual header information in character sets other than US-ASCII.
+
+ These documents are based on earlier work documented in RFC 934, STD
+ 11, and RFC 1049, but extends and revises them. Because RFC 822 said
+ so little about message bodies, these documents are largely
+ orthogonal to (rather than a revision of) RFC 822.
+
+ This particular document is the third document in the series. It
+ describes extensions to RFC 822 to allow non-US-ASCII text data in
+ Internet mail header fields.
+
+
+
+
+
+
+
+
+
+Moore Standards Track [Page 1]
+\f
+RFC 2047 Message Header Extensions November 1996
+
+
+ Other documents in this series include:
+
+ + RFC 2045, which specifies the various headers used to describe
+ the structure of MIME messages.
+
+ + RFC 2046, which defines the general structure of the MIME media
+ typing system and defines an initial set of media types,
+
+ + RFC 2048, which specifies various IANA registration procedures
+ for MIME-related facilities, and
+
+ + RFC 2049, which describes MIME conformance criteria and
+ provides some illustrative examples of MIME message formats,
+ acknowledgements, and the bibliography.
+
+ These documents are revisions of RFCs 1521, 1522, and 1590, which
+ themselves were revisions of RFCs 1341 and 1342. An appendix in RFC
+ 2049 describes differences and changes from previous versions.
+
+1. Introduction
+
+ RFC 2045 describes a mechanism for denoting textual body parts which
+ are coded in various character sets, as well as methods for encoding
+ such body parts as sequences of printable US-ASCII characters. This
+ memo describes similar techniques to allow the encoding of non-ASCII
+ text in various portions of a RFC 822 [2] message header, in a manner
+ which is unlikely to confuse existing message handling software.
+
+ Like the encoding techniques described in RFC 2045, the techniques
+ outlined here were designed to allow the use of non-ASCII characters
+ in message headers in a way which is unlikely to be disturbed by the
+ quirks of existing Internet mail handling programs. In particular,
+ some mail relaying programs are known to (a) delete some message
+ header fields while retaining others, (b) rearrange the order of
+ addresses in To or Cc fields, (c) rearrange the (vertical) order of
+ header fields, and/or (d) "wrap" message headers at different places
+ than those in the original message. In addition, some mail reading
+ programs are known to have difficulty correctly parsing message
+ headers which, while legal according to RFC 822, make use of
+ backslash-quoting to "hide" special characters such as "<", ",", or
+ ":", or which exploit other infrequently-used features of that
+ specification.
+
+ While it is unfortunate that these programs do not correctly
+ interpret RFC 822 headers, to "break" these programs would cause
+ severe operational problems for the Internet mail system. The
+ extensions described in this memo therefore do not rely on little-
+ used features of RFC 822.
+
+
+
+Moore Standards Track [Page 2]
+\f
+RFC 2047 Message Header Extensions November 1996
+
+
+ Instead, certain sequences of "ordinary" printable ASCII characters
+ (known as "encoded-words") are reserved for use as encoded data. The
+ syntax of encoded-words is such that they are unlikely to
+ "accidentally" appear as normal text in message headers.
+ Furthermore, the characters used in encoded-words are restricted to
+ those which do not have special meanings in the context in which the
+ encoded-word appears.
+
+ Generally, an "encoded-word" is a sequence of printable ASCII
+ characters that begins with "=?", ends with "?=", and has two "?"s in
+ between. It specifies a character set and an encoding method, and
+ also includes the original text encoded as graphic ASCII characters,
+ according to the rules for that encoding method.
+
+ A mail composer that implements this specification will provide a
+ means of inputting non-ASCII text in header fields, but will
+ translate these fields (or appropriate portions of these fields) into
+ encoded-words before inserting them into the message header.
+
+ A mail reader that implements this specification will recognize
+ encoded-words when they appear in certain portions of the message
+ header. Instead of displaying the encoded-word "as is", it will
+ reverse the encoding and display the original text in the designated
+ character set.
+
+NOTES
+
+ This memo relies heavily on notation and terms defined RFC 822 and
+ RFC 2045. In particular, the syntax for the ABNF used in this memo
+ is defined in RFC 822, as well as many of the terminal or nonterminal
+ symbols from RFC 822 are used in the grammar for the header
+ extensions defined here. Among the symbols defined in RFC 822 and
+ referenced in this memo are: 'addr-spec', 'atom', 'CHAR', 'comment',
+ 'CTLs', 'ctext', 'linear-white-space', 'phrase', 'quoted-pair'.
+ 'quoted-string', 'SPACE', and 'word'. Successful implementation of
+ this protocol extension requires careful attention to the RFC 822
+ definitions of these terms.
+
+ When the term "ASCII" appears in this memo, it refers to the "7-Bit
+ American Standard Code for Information Interchange", ANSI X3.4-1986.
+ The MIME charset name for this character set is "US-ASCII". When not
+ specifically referring to the MIME charset name, this document uses
+ the term "ASCII", both for brevity and for consistency with RFC 822.
+ However, implementors are warned that the character set name must be
+ spelled "US-ASCII" in MIME message and body part headers.
+
+
+
+
+
+
+Moore Standards Track [Page 3]
+\f
+RFC 2047 Message Header Extensions November 1996
+
+
+ This memo specifies a protocol for the representation of non-ASCII
+ text in message headers. It specifically DOES NOT define any
+ translation between "8-bit headers" and pure ASCII headers, nor is
+ any such translation assumed to be possible.
+
+2. Syntax of encoded-words
+
+ An 'encoded-word' is defined by the following ABNF grammar. The
+ notation of RFC 822 is used, with the exception that white space
+ characters MUST NOT appear between components of an 'encoded-word'.
+
+ encoded-word = "=?" charset "?" encoding "?" encoded-text "?="
+
+ charset = token ; see section 3
+
+ encoding = token ; see section 4
+
+ token = 1*<Any CHAR except SPACE, CTLs, and especials>
+
+ especials = "(" / ")" / "<" / ">" / "@" / "," / ";" / ":" / "
+ <"> / "/" / "[" / "]" / "?" / "." / "="
+
+ encoded-text = 1*<Any printable ASCII character other than "?"
+ or SPACE>
+ ; (but see "Use of encoded-words in message
+ ; headers", section 5)
+
+ Both 'encoding' and 'charset' names are case-independent. Thus the
+ charset name "ISO-8859-1" is equivalent to "iso-8859-1", and the
+ encoding named "Q" may be spelled either "Q" or "q".
+
+ An 'encoded-word' may not be more than 75 characters long, including
+ 'charset', 'encoding', 'encoded-text', and delimiters. If it is
+ desirable to encode more text than will fit in an 'encoded-word' of
+ 75 characters, multiple 'encoded-word's (separated by CRLF SPACE) may
+ be used.
+
+ While there is no limit to the length of a multiple-line header
+ field, each line of a header field that contains one or more
+ 'encoded-word's is limited to 76 characters.
+
+ The length restrictions are included both to ease interoperability
+ through internetwork mail gateways, and to impose a limit on the
+ amount of lookahead a header parser must employ (while looking for a
+ final ?= delimiter) before it can decide whether a token is an
+ "encoded-word" or something else.
+
+
+
+
+
+Moore Standards Track [Page 4]
+\f
+RFC 2047 Message Header Extensions November 1996
+
+
+ IMPORTANT: 'encoded-word's are designed to be recognized as 'atom's
+ by an RFC 822 parser. As a consequence, unencoded white space
+ characters (such as SPACE and HTAB) are FORBIDDEN within an
+ 'encoded-word'. For example, the character sequence
+
+ =?iso-8859-1?q?this is some text?=
+
+ would be parsed as four 'atom's, rather than as a single 'atom' (by
+ an RFC 822 parser) or 'encoded-word' (by a parser which understands
+ 'encoded-words'). The correct way to encode the string "this is some
+ text" is to encode the SPACE characters as well, e.g.
+
+ =?iso-8859-1?q?this=20is=20some=20text?=
+
+ The characters which may appear in 'encoded-text' are further
+ restricted by the rules in section 5.
+
+3. Character sets
+
+ The 'charset' portion of an 'encoded-word' specifies the character
+ set associated with the unencoded text. A 'charset' can be any of
+ the character set names allowed in an MIME "charset" parameter of a
+ "text/plain" body part, or any character set name registered with
+ IANA for use with the MIME text/plain content-type.
+
+ Some character sets use code-switching techniques to switch between
+ "ASCII mode" and other modes. If unencoded text in an 'encoded-word'
+ contains a sequence which causes the charset interpreter to switch
+ out of ASCII mode, it MUST contain additional control codes such that
+ ASCII mode is again selected at the end of the 'encoded-word'. (This
+ rule applies separately to each 'encoded-word', including adjacent
+ 'encoded-word's within a single header field.)
+
+ When there is a possibility of using more than one character set to
+ represent the text in an 'encoded-word', and in the absence of
+ private agreements between sender and recipients of a message, it is
+ recommended that members of the ISO-8859-* series be used in
+ preference to other character sets.
+
+4. Encodings
+
+ Initially, the legal values for "encoding" are "Q" and "B". These
+ encodings are described below. The "Q" encoding is recommended for
+ use when most of the characters to be encoded are in the ASCII
+ character set; otherwise, the "B" encoding should be used.
+ Nevertheless, a mail reader which claims to recognize 'encoded-word's
+ MUST be able to accept either encoding for any character set which it
+ supports.
+
+
+
+Moore Standards Track [Page 5]
+\f
+RFC 2047 Message Header Extensions November 1996
+
+
+ Only a subset of the printable ASCII characters may be used in
+ 'encoded-text'. Space and tab characters are not allowed, so that
+ the beginning and end of an 'encoded-word' are obvious. The "?"
+ character is used within an 'encoded-word' to separate the various
+ portions of the 'encoded-word' from one another, and thus cannot
+ appear in the 'encoded-text' portion. Other characters are also
+ illegal in certain contexts. For example, an 'encoded-word' in a
+ 'phrase' preceding an address in a From header field may not contain
+ any of the "specials" defined in RFC 822. Finally, certain other
+ characters are disallowed in some contexts, to ensure reliability for
+ messages that pass through internetwork mail gateways.
+
+ The "B" encoding automatically meets these requirements. The "Q"
+ encoding allows a wide range of printable characters to be used in
+ non-critical locations in the message header (e.g., Subject), with
+ fewer characters available for use in other locations.
+
+4.1. The "B" encoding
+
+ The "B" encoding is identical to the "BASE64" encoding defined by RFC
+ 2045.
+
+4.2. The "Q" encoding
+
+ The "Q" encoding is similar to the "Quoted-Printable" content-
+ transfer-encoding defined in RFC 2045. It is designed to allow text
+ containing mostly ASCII characters to be decipherable on an ASCII
+ terminal without decoding.
+
+ (1) Any 8-bit value may be represented by a "=" followed by two
+ hexadecimal digits. For example, if the character set in use
+ were ISO-8859-1, the "=" character would thus be encoded as
+ "=3D", and a SPACE by "=20". (Upper case should be used for
+ hexadecimal digits "A" through "F".)
+
+ (2) The 8-bit hexadecimal value 20 (e.g., ISO-8859-1 SPACE) may be
+ represented as "_" (underscore, ASCII 95.). (This character may
+ not pass through some internetwork mail gateways, but its use
+ will greatly enhance readability of "Q" encoded data with mail
+ readers that do not support this encoding.) Note that the "_"
+ always represents hexadecimal 20, even if the SPACE character
+ occupies a different code position in the character set in use.
+
+ (3) 8-bit values which correspond to printable ASCII characters other
+ than "=", "?", and "_" (underscore), MAY be represented as those
+ characters. (But see section 5 for restrictions.) In
+ particular, SPACE and TAB MUST NOT be represented as themselves
+ within encoded words.
+
+
+
+Moore Standards Track [Page 6]
+\f
+RFC 2047 Message Header Extensions November 1996
+
+
+5. Use of encoded-words in message headers
+
+ An 'encoded-word' may appear in a message header or body part header
+ according to the following rules:
+
+(1) An 'encoded-word' may replace a 'text' token (as defined by RFC 822)
+ in any Subject or Comments header field, any extension message
+ header field, or any MIME body part field for which the field body
+ is defined as '*text'. An 'encoded-word' may also appear in any
+ user-defined ("X-") message or body part header field.
+
+ Ordinary ASCII text and 'encoded-word's may appear together in the
+ same header field. However, an 'encoded-word' that appears in a
+ header field defined as '*text' MUST be separated from any adjacent
+ 'encoded-word' or 'text' by 'linear-white-space'.
+
+(2) An 'encoded-word' may appear within a 'comment' delimited by "(" and
+ ")", i.e., wherever a 'ctext' is allowed. More precisely, the RFC
+ 822 ABNF definition for 'comment' is amended as follows:
+
+ comment = "(" *(ctext / quoted-pair / comment / encoded-word) ")"
+
+ A "Q"-encoded 'encoded-word' which appears in a 'comment' MUST NOT
+ contain the characters "(", ")" or "
+ 'encoded-word' that appears in a 'comment' MUST be separated from
+ any adjacent 'encoded-word' or 'ctext' by 'linear-white-space'.
+
+ It is important to note that 'comment's are only recognized inside
+ "structured" field bodies. In fields whose bodies are defined as
+ '*text', "(" and ")" are treated as ordinary characters rather than
+ comment delimiters, and rule (1) of this section applies. (See RFC
+ 822, sections 3.1.2 and 3.1.3)
+
+(3) As a replacement for a 'word' entity within a 'phrase', for example,
+ one that precedes an address in a From, To, or Cc header. The ABNF
+ definition for 'phrase' from RFC 822 thus becomes:
+
+ phrase = 1*( encoded-word / word )
+
+ In this case the set of characters that may be used in a "Q"-encoded
+ 'encoded-word' is restricted to: <upper and lower case ASCII
+ letters, decimal digits, "!", "*", "+", "-", "/", "=", and "_"
+ (underscore, ASCII 95.)>. An 'encoded-word' that appears within a
+ 'phrase' MUST be separated from any adjacent 'word', 'text' or
+ 'special' by 'linear-white-space'.
+
+
+
+
+
+
+Moore Standards Track [Page 7]
+\f
+RFC 2047 Message Header Extensions November 1996
+
+
+ These are the ONLY locations where an 'encoded-word' may appear. In
+ particular:
+
+ + An 'encoded-word' MUST NOT appear in any portion of an 'addr-spec'.
+
+ + An 'encoded-word' MUST NOT appear within a 'quoted-string'.
+
+ + An 'encoded-word' MUST NOT be used in a Received header field.
+
+ + An 'encoded-word' MUST NOT be used in parameter of a MIME
+ Content-Type or Content-Disposition field, or in any structured
+ field body except within a 'comment' or 'phrase'.
+
+ The 'encoded-text' in an 'encoded-word' must be self-contained;
+ 'encoded-text' MUST NOT be continued from one 'encoded-word' to
+ another. This implies that the 'encoded-text' portion of a "B"
+ 'encoded-word' will be a multiple of 4 characters long; for a "Q"
+ 'encoded-word', any "=" character that appears in the 'encoded-text'
+ portion will be followed by two hexadecimal characters.
+
+ Each 'encoded-word' MUST encode an integral number of octets. The
+ 'encoded-text' in each 'encoded-word' must be well-formed according
+ to the encoding specified; the 'encoded-text' may not be continued in
+ the next 'encoded-word'. (For example, "=?charset?Q?=?=
+ =?charset?Q?AB?=" would be illegal, because the two hex digits "AB"
+ must follow the "=" in the same 'encoded-word'.)
+
+ Each 'encoded-word' MUST represent an integral number of characters.
+ A multi-octet character may not be split across adjacent 'encoded-
+ word's.
+
+ Only printable and white space character data should be encoded using
+ this scheme. However, since these encoding schemes allow the
+ encoding of arbitrary octet values, mail readers that implement this
+ decoding should also ensure that display of the decoded data on the
+ recipient's terminal will not cause unwanted side-effects.
+
+ Use of these methods to encode non-textual data (e.g., pictures or
+ sounds) is not defined by this memo. Use of 'encoded-word's to
+ represent strings of purely ASCII characters is allowed, but
+ discouraged. In rare cases it may be necessary to encode ordinary
+ text that looks like an 'encoded-word'.
+
+
+
+
+
+
+
+
+
+Moore Standards Track [Page 8]
+\f
+RFC 2047 Message Header Extensions November 1996
+
+
+6. Support of 'encoded-word's by mail readers
+
+6.1. Recognition of 'encoded-word's in message headers
+
+ A mail reader must parse the message and body part headers according
+ to the rules in RFC 822 to correctly recognize 'encoded-word's.
+
+ 'encoded-word's are to be recognized as follows:
+
+ (1) Any message or body part header field defined as '*text', or any
+ user-defined header field, should be parsed as follows: Beginning
+ at the start of the field-body and immediately following each
+ occurrence of 'linear-white-space', each sequence of up to 75
+ printable characters (not containing any 'linear-white-space')
+ should be examined to see if it is an 'encoded-word' according to
+ the syntax rules in section 2. Any other sequence of printable
+ characters should be treated as ordinary ASCII text.
+
+ (2) Any header field not defined as '*text' should be parsed
+ according to the syntax rules for that header field. However,
+ any 'word' that appears within a 'phrase' should be treated as an
+ 'encoded-word' if it meets the syntax rules in section 2.
+ Otherwise it should be treated as an ordinary 'word'.
+
+ (3) Within a 'comment', any sequence of up to 75 printable characters
+ (not containing 'linear-white-space'), that meets the syntax
+ rules in section 2, should be treated as an 'encoded-word'.
+ Otherwise it should be treated as normal comment text.
+
+ (4) A MIME-Version header field is NOT required to be present for
+ 'encoded-word's to be interpreted according to this
+ specification. One reason for this is that the mail reader is
+ not expected to parse the entire message header before displaying
+ lines that may contain 'encoded-word's.
+
+6.2. Display of 'encoded-word's
+
+ Any 'encoded-word's so recognized are decoded, and if possible, the
+ resulting unencoded text is displayed in the original character set.
+
+ NOTE: Decoding and display of encoded-words occurs *after* a
+ structured field body is parsed into tokens. It is therefore
+ possible to hide 'special' characters in encoded-words which, when
+ displayed, will be indistinguishable from 'special' characters in the
+ surrounding text. For this and other reasons, it is NOT generally
+ possible to translate a message header containing 'encoded-word's to
+ an unencoded form which can be parsed by an RFC 822 mail reader.
+
+
+
+
+Moore Standards Track [Page 9]
+\f
+RFC 2047 Message Header Extensions November 1996
+
+
+ When displaying a particular header field that contains multiple
+ 'encoded-word's, any 'linear-white-space' that separates a pair of
+ adjacent 'encoded-word's is ignored. (This is to allow the use of
+ multiple 'encoded-word's to represent long strings of unencoded text,
+ without having to separate 'encoded-word's where spaces occur in the
+ unencoded text.)
+
+ In the event other encodings are defined in the future, and the mail
+ reader does not support the encoding used, it may either (a) display
+ the 'encoded-word' as ordinary text, or (b) substitute an appropriate
+ message indicating that the text could not be decoded.
+
+ If the mail reader does not support the character set used, it may
+ (a) display the 'encoded-word' as ordinary text (i.e., as it appears
+ in the header), (b) make a "best effort" to display using such
+ characters as are available, or (c) substitute an appropriate message
+ indicating that the decoded text could not be displayed.
+
+ If the character set being used employs code-switching techniques,
+ display of the encoded text implicitly begins in "ASCII mode". In
+ addition, the mail reader must ensure that the output device is once
+ again in "ASCII mode" after the 'encoded-word' is displayed.
+
+6.3. Mail reader handling of incorrectly formed 'encoded-word's
+
+ It is possible that an 'encoded-word' that is legal according to the
+ syntax defined in section 2, is incorrectly formed according to the
+ rules for the encoding being used. For example:
+
+ (1) An 'encoded-word' which contains characters which are not legal
+ for a particular encoding (for example, a "-" in the "B"
+ encoding, or a SPACE or HTAB in either the "B" or "Q" encoding),
+ is incorrectly formed.
+
+ (2) Any 'encoded-word' which encodes a non-integral number of
+ characters or octets is incorrectly formed.
+
+ A mail reader need not attempt to display the text associated with an
+ 'encoded-word' that is incorrectly formed. However, a mail reader
+ MUST NOT prevent the display or handling of a message because an
+ 'encoded-word' is incorrectly formed.
+
+7. Conformance
+
+ A mail composing program claiming compliance with this specification
+ MUST ensure that any string of non-white-space printable ASCII
+ characters within a '*text' or '*ctext' that begins with "=?" and
+ ends with "?=" be a valid 'encoded-word'. ("begins" means: at the
+
+
+
+Moore Standards Track [Page 10]
+\f
+RFC 2047 Message Header Extensions November 1996
+
+
+ start of the field-body, immediately following 'linear-white-space',
+ or immediately following a "(" for an 'encoded-word' within '*ctext';
+ "ends" means: at the end of the field-body, immediately preceding
+ 'linear-white-space', or immediately preceding a ")" for an
+ 'encoded-word' within '*ctext'.) In addition, any 'word' within a
+ 'phrase' that begins with "=?" and ends with "?=" must be a valid
+ 'encoded-word'.
+
+ A mail reading program claiming compliance with this specification
+ must be able to distinguish 'encoded-word's from 'text', 'ctext', or
+ 'word's, according to the rules in section 6, anytime they appear in
+ appropriate places in message headers. It must support both the "B"
+ and "Q" encodings for any character set which it supports. The
+ program must be able to display the unencoded text if the character
+ set is "US-ASCII". For the ISO-8859-* character sets, the mail
+ reading program must at least be able to display the characters which
+ are also in the ASCII set.
+
+8. Examples
+
+ The following are examples of message headers containing 'encoded-
+ word's:
+
+ From: =?US-ASCII?Q?Keith_Moore?= <moore@cs.utk.edu>
+ To: =?ISO-8859-1?Q?Keld_J=F8rn_Simonsen?= <keld@dkuug.dk>
+ CC: =?ISO-8859-1?Q?Andr=E9?= Pirard <PIRARD@vm1.ulg.ac.be>
+ Subject: =?ISO-8859-1?B?SWYgeW91IGNhbiByZWFkIHRoaXMgeW8=?=
+ =?ISO-8859-2?B?dSB1bmRlcnN0YW5kIHRoZSBleGFtcGxlLg==?=
+
+ Note: In the first 'encoded-word' of the Subject field above, the
+ last "=" at the end of the 'encoded-text' is necessary because each
+ 'encoded-word' must be self-contained (the "=" character completes a
+ group of 4 base64 characters representing 2 octets). An additional
+ octet could have been encoded in the first 'encoded-word' (so that
+ the encoded-word would contain an exact multiple of 3 encoded
+ octets), except that the second 'encoded-word' uses a different
+ 'charset' than the first one.
+
+ From: =?ISO-8859-1?Q?Olle_J=E4rnefors?= <ojarnef@admin.kth.se>
+ To: ietf-822@dimacs.rutgers.edu, ojarnef@admin.kth.se
+ Subject: Time for ISO 10646?
+
+ To: Dave Crocker <dcrocker@mordor.stanford.edu>
+ Cc: ietf-822@dimacs.rutgers.edu, paf@comsol.se
+ From: =?ISO-8859-1?Q?Patrik_F=E4ltstr=F6m?= <paf@nada.kth.se>
+ Subject: Re: RFC-HDR care and feeding
+
+
+
+
+
+Moore Standards Track [Page 11]
+\f
+RFC 2047 Message Header Extensions November 1996
+
+
+ From: Nathaniel Borenstein <nsb@thumper.bellcore.com>
+ (=?iso-8859-8?b?7eXs+SDv4SDp7Oj08A==?=)
+ To: Greg Vaudreuil <gvaudre@NRI.Reston.VA.US>, Ned Freed
+ <ned@innosoft.com>, Keith Moore <moore@cs.utk.edu>
+ Subject: Test of new header generator
+ MIME-Version: 1.0
+ Content-type: text/plain; charset=ISO-8859-1
+
+ The following examples illustrate how text containing 'encoded-word's
+ which appear in a structured field body. The rules are slightly
+ different for fields defined as '*text' because "(" and ")" are not
+ recognized as 'comment' delimiters. [Section 5, paragraph (1)].
+
+ In each of the following examples, if the same sequence were to occur
+ in a '*text' field, the "displayed as" form would NOT be treated as
+ encoded words, but be identical to the "encoded form". This is
+ because each of the encoded-words in the following examples is
+ adjacent to a "(" or ")" character.
+
+ encoded form displayed as
+ ---------------------------------------------------------------------
+ (=?ISO-8859-1?Q?a?=) (a)
+
+ (=?ISO-8859-1?Q?a?= b) (a b)
+
+ Within a 'comment', white space MUST appear between an
+ 'encoded-word' and surrounding text. [Section 5,
+ paragraph (2)]. However, white space is not needed between
+ the initial "(" that begins the 'comment', and the
+ 'encoded-word'.
+
+
+ (=?ISO-8859-1?Q?a?= =?ISO-8859-1?Q?b?=) (ab)
+
+ White space between adjacent 'encoded-word's is not
+ displayed.
+
+ (=?ISO-8859-1?Q?a?= =?ISO-8859-1?Q?b?=) (ab)
+
+ Even multiple SPACEs between 'encoded-word's are ignored
+ for the purpose of display.
+
+ (=?ISO-8859-1?Q?a?= (ab)
+ =?ISO-8859-1?Q?b?=)
+
+ Any amount of linear-space-white between 'encoded-word's,
+ even if it includes a CRLF followed by one or more SPACEs,
+ is ignored for the purposes of display.
+
+
+
+Moore Standards Track [Page 12]
+\f
+RFC 2047 Message Header Extensions November 1996
+
+
+ (=?ISO-8859-1?Q?a_b?=) (a b)
+
+ In order to cause a SPACE to be displayed within a portion
+ of encoded text, the SPACE MUST be encoded as part of the
+ 'encoded-word'.
+
+ (=?ISO-8859-1?Q?a?= =?ISO-8859-2?Q?_b?=) (a b)
+
+ In order to cause a SPACE to be displayed between two strings
+ of encoded text, the SPACE MAY be encoded as part of one of
+ the 'encoded-word's.
+
+9. References
+
+ [RFC 822] Crocker, D., "Standard for the Format of ARPA Internet Text
+ Messages", STD 11, RFC 822, UDEL, August 1982.
+
+ [RFC 2049] Borenstein, N., and N. Freed, "Multipurpose Internet Mail
+ Extensions (MIME) Part Five: Conformance Criteria and Examples",
+ RFC 2049, November 1996.
+
+ [RFC 2045] Borenstein, N., and N. Freed, "Multipurpose Internet Mail
+ Extensions (MIME) Part One: Format of Internet Message Bodies",
+ RFC 2045, November 1996.
+
+ [RFC 2046] Borenstein N., and N. Freed, "Multipurpose Internet Mail
+ Extensions (MIME) Part Two: Media Types", RFC 2046,
+ November 1996.
+
+ [RFC 2048] Freed, N., Klensin, J., and J. Postel, "Multipurpose
+ Internet Mail Extensions (MIME) Part Four: Registration
+ Procedures", RFC 2048, November 1996.
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+Moore Standards Track [Page 13]
+\f
+RFC 2047 Message Header Extensions November 1996
+
+
+10. Security Considerations
+
+ Security issues are not discussed in this memo.
+
+11. Acknowledgements
+
+ The author wishes to thank Nathaniel Borenstein, Issac Chan, Lutz
+ Donnerhacke, Paul Eggert, Ned Freed, Andreas M. Kirchwitz, Olle
+ Jarnefors, Mike Rosin, Yutaka Sato, Bart Schaefer, and Kazuhiko
+ Yamamoto, for their helpful advice, insightful comments, and
+ illuminating questions in response to earlier versions of this
+ specification.
+
+12. Author's Address
+
+ Keith Moore
+ University of Tennessee
+ 107 Ayres Hall
+ Knoxville TN 37996-1301
+
+ EMail: moore@cs.utk.edu
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+Moore Standards Track [Page 14]
+\f
+RFC 2047 Message Header Extensions November 1996
+
+
+Appendix - changes since RFC 1522 (in no particular order)
+
+ + explicitly state that the MIME-Version is not requried to use
+ 'encoded-word's.
+
+ + add explicit note that SPACEs and TABs are not allowed within
+ 'encoded-word's, explaining that an 'encoded-word' must look like an
+ 'atom' to an RFC822 parser.values, to be precise).
+
+ + add examples from Olle Jarnefors (thanks!) which illustrate how
+ encoded-words with adjacent linear-white-space are displayed.
+
+ + explicitly list terms defined in RFC822 and referenced in this memo
+
+ + fix transcription typos that caused one or two lines and a couple of
+ characters to disappear in the resulting text, due to nroff quirks.
+
+ + clarify that encoded-words are allowed in '*text' fields in both
+ RFC822 headers and MIME body part headers, but NOT as parameter
+ values.
+
+ + clarify the requirement to switch back to ASCII within the encoded
+ portion of an 'encoded-word', for any charset that uses code switching
+ sequences.
+
+ + add a note about 'encoded-word's being delimited by "(" and ")"
+ within a comment, but not in a *text (how bizarre!).
+
+ + fix the Andre Pirard example to get rid of the trailing "_" after
+ the =E9. (no longer needed post-1342).
+
+ + clarification: an 'encoded-word' may appear immediately following
+ the initial "(" or immediately before the final ")" that delimits a
+ comment, not just adjacent to "(" and ")" *within* *ctext.
+
+ + add a note to explain that a "B" 'encoded-word' will always have a
+ multiple of 4 characters in the 'encoded-text' portion.
+
+ + add note about the "=" in the examples
+
+ + note that processing of 'encoded-word's occurs *after* parsing, and
+ some of the implications thereof.
+
+ + explicitly state that you can't expect to translate between
+ 1522 and either vanilla 822 or so-called "8-bit headers".
+
+ + explicitly state that 'encoded-word's are not valid within a
+ 'quoted-string'.
+
+
+
+Moore Standards Track [Page 15]
+\f
--- /dev/null
+
+
+
+
+
+
+Network Working Group N. Freed
+Request for Comments: 2049 Innosoft
+Obsoletes: 1521, 1522, 1590 N. Borenstein
+Category: Standards Track First Virtual
+ November 1996
+
+
+ Multipurpose Internet Mail Extensions
+ (MIME) Part Five:
+ Conformance Criteria and Examples
+
+Status of this Memo
+
+ This document specifies an Internet standards track protocol for the
+ Internet community, and requests discussion and suggestions for
+ improvements. Please refer to the current edition of the "Internet
+ Official Protocol Standards" (STD 1) for the standardization state
+ and status of this protocol. Distribution of this memo is unlimited.
+
+Abstract
+
+ STD 11, RFC 822, defines a message representation protocol specifying
+ considerable detail about US-ASCII message headers, and leaves the
+ message content, or message body, as flat US-ASCII text. This set of
+ documents, collectively called the Multipurpose Internet Mail
+ Extensions, or MIME, redefines the format of messages to allow for
+
+ (1) textual message bodies in character sets other than
+ US-ASCII,
+
+ (2) an extensible set of different formats for non-textual
+ message bodies,
+
+ (3) multi-part message bodies, and
+
+ (4) textual header information in character sets other than
+ US-ASCII.
+
+ These documents are based on earlier work documented in RFC 934, STD
+ 11, and RFC 1049, but extends and revises them. Because RFC 822 said
+ so little about message bodies, these documents are largely
+ orthogonal to (rather than a revision of) RFC 822.
+
+ The initial document in this set, RFC 2045, specifies the various
+ headers used to describe the structure of MIME messages. The second
+ document defines the general structure of the MIME media typing
+ system and defines an initial set of media types. The third
+ document, RFC 2047, describes extensions to RFC 822 to allow non-US-
+
+
+
+Freed & Borenstein Standards Track [Page 1]
+\f
+RFC 2049 MIME Conformance November 1996
+
+
+ ASCII text data in Internet mail header fields. The fourth document,
+ RFC 2048, specifies various IANA registration procedures for MIME-
+ related facilities. This fifth and final document describes MIME
+ conformance criteria as well as providing some illustrative examples
+ of MIME message formats, acknowledgements, and the bibliography.
+
+ These documents are revisions of RFCs 1521, 1522, and 1590, which
+ themselves were revisions of RFCs 1341 and 1342. Appendix B of this
+ document describes differences and changes from previous versions.
+
+Table of Contents
+
+ 1. Introduction .......................................... 2
+ 2. MIME Conformance ...................................... 2
+ 3. Guidelines for Sending Email Data ..................... 6
+ 4. Canonical Encoding Model .............................. 9
+ 5. Summary ............................................... 12
+ 6. Security Considerations ............................... 12
+ 7. Authors' Addresses .................................... 12
+ 8. Acknowledgements ...................................... 13
+ A. A Complex Multipart Example ........................... 15
+ B. Changes from RFC 1521, 1522, and 1590 ................. 16
+ C. References ............................................ 20
+
+1. Introduction
+
+ The first and second documents in this set define MIME header fields
+ and the initial set of MIME media types. The third document
+ describes extensions to RFC822 formats to allow for character sets
+ other than US-ASCII. This document describes what portions of MIME
+ must be supported by a conformant MIME implementation. It also
+ describes various pitfalls of contemporary messaging systems as well
+ as the canonical encoding model MIME is based on.
+
+2. MIME Conformance
+
+ The mechanisms described in these documents are open-ended. It is
+ definitely not expected that all implementations will support all
+ available media types, nor that they will all share the same
+ extensions. In order to promote interoperability, however, it is
+ useful to define the concept of "MIME-conformance" to define a
+ certain level of implementation that allows the useful interworking
+ of messages with content that differs from US-ASCII text. In this
+ section, we specify the requirements for such conformance.
+
+
+
+
+
+
+
+Freed & Borenstein Standards Track [Page 2]
+\f
+RFC 2049 MIME Conformance November 1996
+
+
+ A mail user agent that is MIME-conformant MUST:
+
+ (1) Always generate a "MIME-Version: 1.0" header field in
+ any message it creates.
+
+ (2) Recognize the Content-Transfer-Encoding header field
+ and decode all received data encoded by either quoted-
+ printable or base64 implementations. The identity
+ transformations 7bit, 8bit, and binary must also be
+ recognized.
+
+ Any non-7bit data that is sent without encoding must be
+ properly labelled with a content-transfer-encoding of
+ 8bit or binary, as appropriate. If the underlying
+ transport does not support 8bit or binary (as SMTP
+ [RFC-821] does not), the sender is required to both
+ encode and label data using an appropriate Content-
+ Transfer-Encoding such as quoted-printable or base64.
+
+ (3) Must treat any unrecognized Content-Transfer-Encoding
+ as if it had a Content-Type of "application/octet-
+ stream", regardless of whether or not the actual
+ Content-Type is recognized.
+
+ (4) Recognize and interpret the Content-Type header field,
+ and avoid showing users raw data with a Content-Type
+ field other than text. Implementations must be able
+ to send at least text/plain messages, with the
+ character set specified with the charset parameter if
+ it is not US-ASCII.
+
+ (5) Ignore any content type parameters whose names they do
+ not recognize.
+
+ (6) Explicitly handle the following media type values, to
+ at least the following extents:
+
+ Text:
+
+ -- Recognize and display "text" mail with the
+ character set "US-ASCII."
+
+ -- Recognize other character sets at least to the
+ extent of being able to inform the user about what
+ character set the message uses.
+
+
+
+
+
+
+Freed & Borenstein Standards Track [Page 3]
+\f
+RFC 2049 MIME Conformance November 1996
+
+
+ -- Recognize the "ISO-8859-*" character sets to the
+ extent of being able to display those characters that
+ are common to ISO-8859-* and US-ASCII, namely all
+ characters represented by octet values 1-127.
+
+ -- For unrecognized subtypes in a known character
+ set, show or offer to show the user the "raw" version
+ of the data after conversion of the content from
+ canonical form to local form.
+
+ -- Treat material in an unknown character set as if
+ it were "application/octet-stream".
+
+ Image, audio, and video:
+
+ -- At a minumum provide facilities to treat any
+ unrecognized subtypes as if they were
+ "application/octet-stream".
+
+ Application:
+
+ -- Offer the ability to remove either of the quoted-
+ printable or base64 encodings defined in this
+ document if they were used and put the resulting
+ information in a user file.
+
+ Multipart:
+
+ -- Recognize the mixed subtype. Display all relevant
+ information on the message level and the body part
+ header level and then display or offer to display
+ each of the body parts individually.
+
+ -- Recognize the "alternative" subtype, and avoid
+ showing the user redundant parts of
+ multipart/alternative mail.
+
+ -- Recognize the "multipart/digest" subtype,
+ specifically using "message/rfc822" rather than
+ "text/plain" as the default media type for body parts
+ inside "multipart/digest" entities.
+
+ -- Treat any unrecognized subtypes as if they were
+ "mixed".
+
+
+
+
+
+
+
+Freed & Borenstein Standards Track [Page 4]
+\f
+RFC 2049 MIME Conformance November 1996
+
+
+ Message:
+
+ -- Recognize and display at least the RFC822 message
+ encapsulation (message/rfc822) in such a way as to
+ preserve any recursive structure, that is, displaying
+ or offering to display the encapsulated data in
+ accordance with its media type.
+
+ -- Treat any unrecognized subtypes as if they were
+ "application/octet-stream".
+
+ (7) Upon encountering any unrecognized Content-Type field,
+ an implementation must treat it as if it had a media
+ type of "application/octet-stream" with no parameter
+ sub-arguments. How such data are handled is up to an
+ implementation, but likely options for handling such
+ unrecognized data include offering the user to write it
+ into a file (decoded from its mail transport format) or
+ offering the user to name a program to which the
+ decoded data should be passed as input.
+
+ (8) Conformant user agents are required, if they provide
+ non-standard support for non-MIME messages employing
+ character sets other than US-ASCII, to do so on
+ received messages only. Conforming user agents must not
+ send non-MIME messages containing anything other than
+ US-ASCII text.
+
+ In particular, the use of non-US-ASCII text in mail
+ messages without a MIME-Version field is strongly
+ discouraged as it impedes interoperability when sending
+ messages between regions with different localization
+ conventions. Conforming user agents MUST include proper
+ MIME labelling when sending anything other than plain
+ text in the US-ASCII character set.
+
+ In addition, non-MIME user agents should be upgraded if
+ at all possible to include appropriate MIME header
+ information in the messages they send even if nothing
+ else in MIME is supported. This upgrade will have
+ little, if any, effect on non-MIME recipients and will
+ aid MIME in correctly displaying such messages. It
+ also provides a smooth transition path to eventual
+ adoption of other MIME capabilities.
+
+ (9) Conforming user agents must ensure that any string of
+ non-white-space printable US-ASCII characters within a
+ "*text" or "*ctext" that begins with "=?" and ends with
+
+
+
+Freed & Borenstein Standards Track [Page 5]
+\f
+RFC 2049 MIME Conformance November 1996
+
+
+ "?=" be a valid encoded-word. ("begins" means: At the
+ start of the field-body or immediately following
+ linear-white-space; "ends" means: At the end of the
+ field-body or immediately preceding linear-white-
+ space.) In addition, any "word" within a "phrase" that
+ begins with "=?" and ends with "?=" must be a valid
+ encoded-word.
+
+ (10) Conforming user agents must be able to distinguish
+ encoded-words from "text", "ctext", or "word"s,
+ according to the rules in section 4, anytime they
+ appear in appropriate places in message headers. It
+ must support both the "B" and "Q" encodings for any
+ character set which it supports. The program must be
+ able to display the unencoded text if the character set
+ is "US-ASCII". For the ISO-8859-* character sets, the
+ mail reading program must at least be able to display
+ the characters which are also in the US-ASCII set.
+
+ A user agent that meets the above conditions is said to be MIME-
+ conformant. The meaning of this phrase is that it is assumed to be
+ "safe" to send virtually any kind of properly-marked data to users of
+ such mail systems, because such systems will at least be able to
+ treat the data as undifferentiated binary, and will not simply splash
+ it onto the screen of unsuspecting users.
+
+ There is another sense in which it is always "safe" to send data in a
+ format that is MIME-conformant, which is that such data will not
+ break or be broken by any known systems that are conformant with RFC
+ 821 and RFC 822. User agents that are MIME-conformant have the
+ additional guarantee that the user will not be shown data that were
+ never intended to be viewed as text.
+
+3. Guidelines for Sending Email Data
+
+ Internet email is not a perfect, homogeneous system. Mail may become
+ corrupted at several stages in its travel to a final destination.
+ Specifically, email sent throughout the Internet may travel across
+ many networking technologies. Many networking and mail technologies
+ do not support the full functionality possible in the SMTP transport
+ environment. Mail traversing these systems is likely to be modified
+ in order that it can be transported.
+
+ There exist many widely-deployed non-conformant MTAs in the Internet.
+ These MTAs, speaking the SMTP protocol, alter messages on the fly to
+ take advantage of the internal data structure of the hosts they are
+ implemented on, or are just plain broken.
+
+
+
+
+Freed & Borenstein Standards Track [Page 6]
+\f
+RFC 2049 MIME Conformance November 1996
+
+
+ The following guidelines may be useful to anyone devising a data
+ format (media type) that is supposed to survive the widest range of
+ networking technologies and known broken MTAs unscathed. Note that
+ anything encoded in the base64 encoding will satisfy these rules, but
+ that some well-known mechanisms, notably the UNIX uuencode facility,
+ will not. Note also that anything encoded in the Quoted-Printable
+ encoding will survive most gateways intact, but possibly not some
+ gateways to systems that use the EBCDIC character set.
+
+ (1) Under some circumstances the encoding used for data may
+ change as part of normal gateway or user agent
+ operation. In particular, conversion from base64 to
+ quoted-printable and vice versa may be necessary. This
+ may result in the confusion of CRLF sequences with line
+ breaks in text bodies. As such, the persistence of
+ CRLF as something other than a line break must not be
+ relied on.
+
+ (2) Many systems may elect to represent and store text data
+ using local newline conventions. Local newline
+ conventions may not match the RFC822 CRLF convention --
+ systems are known that use plain CR, plain LF, CRLF, or
+ counted records. The result is that isolated CR and LF
+ characters are not well tolerated in general; they may
+ be lost or converted to delimiters on some systems, and
+ hence must not be relied on.
+
+ (3) The transmission of NULs (US-ASCII value 0) is
+ problematic in Internet mail. (This is largely the
+ result of NULs being used as a termination character by
+ many of the standard runtime library routines in the C
+ programming language.) The practice of using NULs as
+ termination characters is so entrenched now that
+ messages should not rely on them being preserved.
+
+ (4) TAB (HT) characters may be misinterpreted or may be
+ automatically converted to variable numbers of spaces.
+ This is unavoidable in some environments, notably those
+ not based on the US-ASCII character set. Such
+ conversion is STRONGLY DISCOURAGED, but it may occur,
+ and mail formats must not rely on the persistence of
+ TAB (HT) characters.
+
+ (5) Lines longer than 76 characters may be wrapped or
+ truncated in some environments. Line wrapping or line
+ truncation imposed by mail transports is STRONGLY
+ DISCOURAGED, but unavoidable in some cases.
+ Applications which require long lines must somehow
+
+
+
+Freed & Borenstein Standards Track [Page 7]
+\f
+RFC 2049 MIME Conformance November 1996
+
+
+ differentiate between soft and hard line breaks. (A
+ simple way to do this is to use the quoted-printable
+ encoding.)
+
+ (6) Trailing "white space" characters (SPACE, TAB (HT)) on
+ a line may be discarded by some transport agents, while
+ other transport agents may pad lines with these
+ characters so that all lines in a mail file are of
+ equal length. The persistence of trailing white space,
+ therefore, must not be relied on.
+
+ (7) Many mail domains use variations on the US-ASCII
+ character set, or use character sets such as EBCDIC
+ which contain most but not all of the US-ASCII
+ characters. The correct translation of characters not
+ in the "invariant" set cannot be depended on across
+ character converting gateways. For example, this
+ situation is a problem when sending uuencoded
+ information across BITNET, an EBCDIC system. Similar
+ problems can occur without crossing a gateway, since
+ many Internet hosts use character sets other than US-
+ ASCII internally. The definition of Printable Strings
+ in X.400 adds further restrictions in certain special
+ cases. In particular, the only characters that are
+ known to be consistent across all gateways are the 73
+ characters that correspond to the upper and lower case
+ letters A-Z and a-z, the 10 digits 0-9, and the
+ following eleven special characters:
+
+ "'" (US-ASCII decimal value 39)
+ "(" (US-ASCII decimal value 40)
+ ")" (US-ASCII decimal value 41)
+ "+" (US-ASCII decimal value 43)
+ "," (US-ASCII decimal value 44)
+ "-" (US-ASCII decimal value 45)
+ "." (US-ASCII decimal value 46)
+ "/" (US-ASCII decimal value 47)
+ ":" (US-ASCII decimal value 58)
+ "=" (US-ASCII decimal value 61)
+ "?" (US-ASCII decimal value 63)
+
+ A maximally portable mail representation will confine
+ itself to relatively short lines of text in which the
+ only meaningful characters are taken from this set of
+ 73 characters. The base64 encoding follows this rule.
+
+ (8) Some mail transport agents will corrupt data that
+ includes certain literal strings. In particular, a
+
+
+
+Freed & Borenstein Standards Track [Page 8]
+\f
+RFC 2049 MIME Conformance November 1996
+
+
+ period (".") alone on a line is known to be corrupted
+ by some (incorrect) SMTP implementations, and a line
+ that starts with the five characters "From " (the fifth
+ character is a SPACE) are commonly corrupted as well.
+ A careful composition agent can prevent these
+ corruptions by encoding the data (e.g., in the quoted-
+ printable encoding using "=46rom " in place of "From "
+ at the start of a line, and "=2E" in place of "." alone
+ on a line).
+
+ Please note that the above list is NOT a list of recommended
+ practices for MTAs. RFC 821 MTAs are prohibited from altering the
+ character of white space or wrapping long lines. These BAD and
+ invalid practices are known to occur on established networks, and
+ implementations should be robust in dealing with the bad effects they
+ can cause.
+
+4. Canonical Encoding Model
+
+ There was some confusion, in earlier versions of these documents,
+ regarding the model for when email data was to be converted to
+ canonical form and encoded, and in particular how this process would
+ affect the treatment of CRLFs, given that the representation of
+ newlines varies greatly from system to system. For this reason, a
+ canonical model for encoding is presented below.
+
+ The process of composing a MIME entity can be modeled as being done
+ in a number of steps. Note that these steps are roughly similar to
+ those steps used in PEM [RFC-1421] and are performed for each
+ "innermost level" body:
+
+ (1) Creation of local form.
+
+ The body to be transmitted is created in the system's
+ native format. The native character set is used and,
+ where appropriate, local end of line conventions are
+ used as well. The body may be a UNIX-style text file,
+ or a Sun raster image, or a VMS indexed file, or audio
+ data in a system-dependent format stored only in
+ memory, or anything else that corresponds to the local
+ model for the representation of some form of
+ information. Fundamentally, the data is created in the
+ "native" form that corresponds to the type specified by
+ the media type.
+
+
+
+
+
+
+
+Freed & Borenstein Standards Track [Page 9]
+\f
+RFC 2049 MIME Conformance November 1996
+
+
+ (2) Conversion to canonical form.
+
+ The entire body, including "out-of-band" information
+ such as record lengths and possibly file attribute
+ information, is converted to a universal canonical
+ form. The specific media type of the body as well as
+ its associated attributes dictate the nature of the
+ canonical form that is used. Conversion to the proper
+ canonical form may involve character set conversion,
+ transformation of audio data, compression, or various
+ other operations specific to the various media types.
+ If character set conversion is involved, however, care
+ must be taken to understand the semantics of the media
+ type, which may have strong implications for any
+ character set conversion, e.g. with regard to
+ syntactically meaningful characters in a text subtype
+ other than "plain".
+
+ For example, in the case of text/plain data, the text
+ must be converted to a supported character set and
+ lines must be delimited with CRLF delimiters in
+ accordance with RFC 822. Note that the restriction on
+ line lengths implied by RFC 822 is eliminated if the
+ next step employs either quoted-printable or base64
+ encoding.
+
+ (3) Apply transfer encoding.
+
+ A Content-Transfer-Encoding appropriate for this body
+ is applied. Note that there is no fixed relationship
+ between the media type and the transfer encoding. In
+ particular, it may be appropriate to base the choice of
+ base64 or quoted-printable on character frequency
+ counts which are specific to a given instance of a
+ body.
+
+ (4) Insertion into entity.
+
+ The encoded body is inserted into a MIME entity with
+ appropriate headers. The entity is then inserted into
+ the body of a higher-level entity (message or
+ multipart) as needed.
+
+ Conversion from entity form to local form is accomplished by
+ reversing these steps. Note that reversal of these steps may produce
+ differing results since there is no guarantee that the original and
+ final local forms are the same.
+
+
+
+
+Freed & Borenstein Standards Track [Page 10]
+\f
+RFC 2049 MIME Conformance November 1996
+
+
+ It is vital to note that these steps are only a model; they are
+ specifically NOT a blueprint for how an actual system would be built.
+ In particular, the model fails to account for two common designs:
+
+ (1) In many cases the conversion to a canonical form prior
+ to encoding will be subsumed into the encoder itself,
+ which understands local formats directly. For example,
+ the local newline convention for text bodies might be
+ carried through to the encoder itself along with
+ knowledge of what that format is.
+
+ (2) The output of the encoders may have to pass through one
+ or more additional steps prior to being transmitted as
+ a message. As such, the output of the encoder may not
+ be conformant with the formats specified by RFC 822.
+ In particular, once again it may be appropriate for the
+ converter's output to be expressed using local newline
+ conventions rather than using the standard RFC 822 CRLF
+ delimiters.
+
+ Other implementation variations are conceivable as well. The vital
+ aspect of this discussion is that, in spite of any optimizations,
+ collapsings of required steps, or insertion of additional processing,
+ the resulting messages must be consistent with those produced by the
+ model described here. For example, a message with the following
+ header fields:
+
+ Content-type: text/foo; charset=bar
+ Content-Transfer-Encoding: base64
+
+ must be first represented in the text/foo form, then (if necessary)
+ represented in the "bar" character set, and finally transformed via
+ the base64 algorithm into a mail-safe form.
+
+ NOTE: Some confusion has been caused by systems that represent
+ messages in a format which uses local newline conventions which
+ differ from the RFC822 CRLF convention. It is important to note that
+ these formats are not canonical RFC822/MIME. These formats are
+ instead *encodings* of RFC822, where CRLF sequences in the canonical
+ representation of the message are encoded as the local newline
+ convention. Note that formats which encode CRLF sequences as, for
+ example, LF are not capable of representing MIME messages containing
+ binary data which contains LF octets not part of CRLF line separation
+ sequences.
+
+
+
+
+
+
+
+Freed & Borenstein Standards Track [Page 11]
+\f
+RFC 2049 MIME Conformance November 1996
+
+
+5. Summary
+
+ This document defines what is meant by MIME Conformance. It also
+ details various problems known to exist in the Internet email system
+ and how to use MIME to overcome them. Finally, it describes MIME's
+ canonical encoding model.
+
+6. Security Considerations
+
+ Security issues are discussed in the second document in this set, RFC
+ 2046.
+
+7. Authors' Addresses
+
+ For more information, the authors of this document are best contacted
+ via Internet mail:
+
+ Ned Freed
+ Innosoft International, Inc.
+ 1050 East Garvey Avenue South
+ West Covina, CA 91790
+ USA
+
+ Phone: +1 818 919 3600
+ Fax: +1 818 919 3614
+ EMail: ned@innosoft.com
+
+ Nathaniel S. Borenstein
+ First Virtual Holdings
+ 25 Washington Avenue
+ Morristown, NJ 07960
+ USA
+
+ Phone: +1 201 540 8967
+ Fax: +1 201 993 3032
+ EMail: nsb@nsb.fv.com
+
+ MIME is a result of the work of the Internet Engineering Task Force
+ Working Group on RFC 822 Extensions. The chairman of that group,
+ Greg Vaudreuil, may be reached at:
+
+ Gregory M. Vaudreuil
+ Octel Network Services
+ 17080 Dallas Parkway
+ Dallas, TX 75248-1905
+ USA
+
+ EMail: Greg.Vaudreuil@Octel.Com
+
+
+
+Freed & Borenstein Standards Track [Page 12]
+\f
+RFC 2049 MIME Conformance November 1996
+
+
+8. Acknowledgements
+
+ This document is the result of the collective effort of a large
+ number of people, at several IETF meetings, on the IETF-SMTP and
+ IETF-822 mailing lists, and elsewhere. Although any enumeration
+ seems doomed to suffer from egregious omissions, the following are
+ among the many contributors to this effort:
+
+ Harald Tveit Alvestrand Marc Andreessen
+ Randall Atkinson Bob Braden
+ Philippe Brandon Brian Capouch
+ Kevin Carosso Uhhyung Choi
+ Peter Clitherow Dave Collier-Brown
+ Cristian Constantinof John Coonrod
+ Mark Crispin Dave Crocker
+ Stephen Crocker Terry Crowley
+ Walt Daniels Jim Davis
+ Frank Dawson Axel Deininger
+ Hitoshi Doi Kevin Donnelly
+ Steve Dorner Keith Edwards
+ Chris Eich Dana S. Emery
+ Johnny Eriksson Craig Everhart
+ Patrik Faltstrom Erik E. Fair
+ Roger Fajman Alain Fontaine
+ Martin Forssen James M. Galvin
+ Stephen Gildea Philip Gladstone
+ Thomas Gordon Keld Simonsen
+ Terry Gray Phill Gross
+ James Hamilton David Herron
+ Mark Horton Bruce Howard
+ Bill Janssen Olle Jarnefors
+ Risto Kankkunen Phil Karn
+ Alan Katz Tim Kehres
+ Neil Katin Steve Kille
+ Kyuho Kim Anders Klemets
+ John Klensin Valdis Kletniek
+ Jim Knowles Stev Knowles
+ Bob Kummerfeld Pekka Kytolaakso
+ Stellan Lagerstrom Vincent Lau
+ Timo Lehtinen Donald Lindsay
+ Warner Losh Carlyn Lowery
+ Laurence Lundblade Charles Lynn
+ John R. MacMillan Larry Masinter
+ Rick McGowan Michael J. McInerny
+ Leo Mclaughlin Goli Montaser-Kohsari
+ Tom Moore John Gardiner Myers
+ Erik Naggum Mark Needleman
+ Chris Newman John Noerenberg
+
+
+
+Freed & Borenstein Standards Track [Page 13]
+\f
+RFC 2049 MIME Conformance November 1996
+
+
+ Mats Ohrman Julian Onions
+ Michael Patton David J. Pepper
+ Erik van der Poel Blake C. Ramsdell
+ Christer Romson Luc Rooijakkers
+ Marshall T. Rose Jonathan Rosenberg
+ Guido van Rossum Jan Rynning
+ Harri Salminen Michael Sanderson
+ Yutaka Sato Markku Savela
+ Richard Alan Schafer Masahiro Sekiguchi
+ Mark Sherman Bob Smart
+ Peter Speck Henry Spencer
+ Einar Stefferud Michael Stein
+ Klaus Steinberger Peter Svanberg
+ James Thompson Steve Uhler
+ Stuart Vance Peter Vanderbilt
+ Greg Vaudreuil Ed Vielmetti
+ Larry W. Virden Ryan Waldron
+ Rhys Weatherly Jay Weber
+ Dave Wecker Wally Wedel
+ Sven-Ove Westberg Brian Wideen
+ John Wobus Glenn Wright
+ Rayan Zachariassen David Zimmerman
+
+ The authors apologize for any omissions from this list, which are
+ certainly unintentional.
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+Freed & Borenstein Standards Track [Page 14]
+\f
+RFC 2049 MIME Conformance November 1996
+
+
+Appendix A -- A Complex Multipart Example
+
+ What follows is the outline of a complex multipart message. This
+ message contains five parts that are to be displayed serially: two
+ introductory plain text objects, an embedded multipart message, a
+ text/enriched object, and a closing encapsulated text message in a
+ non-ASCII character set. The embedded multipart message itself
+ contains two objects to be displayed in parallel, a picture and an
+ audio fragment.
+
+ MIME-Version: 1.0
+ From: Nathaniel Borenstein <nsb@nsb.fv.com>
+ To: Ned Freed <ned@innosoft.com>
+ Date: Fri, 07 Oct 1994 16:15:05 -0700 (PDT)
+ Subject: A multipart example
+ Content-Type: multipart/mixed;
+ boundary=unique-boundary-1
+
+ This is the preamble area of a multipart message.
+ Mail readers that understand multipart format
+ should ignore this preamble.
+
+ If you are reading this text, you might want to
+ consider changing to a mail reader that understands
+ how to properly display multipart messages.
+
+ --unique-boundary-1
+
+ ... Some text appears here ...
+
+ [Note that the blank between the boundary and the start
+ of the text in this part means no header fields were
+ given and this is text in the US-ASCII character set.
+ It could have been done with explicit typing as in the
+ next part.]
+
+ --unique-boundary-1
+ Content-type: text/plain; charset=US-ASCII
+
+ This could have been part of the previous part, but
+ illustrates explicit versus implicit typing of body
+ parts.
+
+ --unique-boundary-1
+ Content-Type: multipart/parallel; boundary=unique-boundary-2
+
+ --unique-boundary-2
+ Content-Type: audio/basic
+
+
+
+Freed & Borenstein Standards Track [Page 15]
+\f
+RFC 2049 MIME Conformance November 1996
+
+
+ Content-Transfer-Encoding: base64
+
+ ... base64-encoded 8000 Hz single-channel
+ mu-law-format audio data goes here ...
+
+ --unique-boundary-2
+ Content-Type: image/jpeg
+ Content-Transfer-Encoding: base64
+
+ ... base64-encoded image data goes here ...
+
+ --unique-boundary-2--
+
+ --unique-boundary-1
+ Content-type: text/enriched
+
+ This is <bold><italic>enriched.</italic></bold>
+ <smaller>as defined in RFC 1896</smaller>
+
+ Isn't it
+ <bigger><bigger>cool?</bigger></bigger>
+
+ --unique-boundary-1
+ Content-Type: message/rfc822
+
+ From: (mailbox in US-ASCII)
+ To: (address in US-ASCII)
+ Subject: (subject in US-ASCII)
+ Content-Type: Text/plain; charset=ISO-8859-1
+ Content-Transfer-Encoding: Quoted-printable
+
+ ... Additional text in ISO-8859-1 goes here ...
+
+ --unique-boundary-1--
+
+Appendix B -- Changes from RFC 1521, 1522, and 1590
+
+ These documents are a revision of RFC 1521, 1522, and 1590. For the
+ convenience of those familiar with the earlier documents, the changes
+ from those documents are summarized in this appendix. For further
+ history, note that Appendix H in RFC 1521 specified how that document
+ differed from its predecessor, RFC 1341.
+
+ (1) This document has been completely reformatted and split
+ into multiple documents. This was done to improve the
+ quality of the plain text version of this document,
+ which is required to be the reference copy.
+
+
+
+
+Freed & Borenstein Standards Track [Page 16]
+\f
+RFC 2049 MIME Conformance November 1996
+
+
+ (2) BNF describing the overall structure of MIME object
+ headers has been added. This is a documentation change
+ only -- the underlying syntax has not changed in any
+ way.
+
+ (3) The specific BNF for the seven media types in MIME has
+ been removed. This BNF was incorrect, incomplete, amd
+ inconsistent with the type-indendependent BNF. And
+ since the type-independent BNF already fully specifies
+ the syntax of the various MIME headers, the type-
+ specific BNF was, in the final analysis, completely
+ unnecessary and caused more problems than it solved.
+
+ (4) The more specific "US-ASCII" character set name has
+ replaced the use of the informal term ASCII in many
+ parts of these documents.
+
+ (5) The informal concept of a primary subtype has been
+ removed.
+
+ (6) The term "object" was being used inconsistently. The
+ definition of this term has been clarified, along with
+ the related terms "body", "body part", and "entity",
+ and usage has been corrected where appropriate.
+
+ (7) The BNF for the multipart media type has been
+ rearranged to make it clear that the CRLF preceeding
+ the boundary marker is actually part of the marker
+ itself rather than the preceeding body part.
+
+ (8) The prose and BNF describing the multipart media type
+ have been changed to make it clear that the body parts
+ within a multipart object MUST NOT contain any lines
+ beginning with the boundary parameter string.
+
+ (9) In the rules on reassembling "message/partial" MIME
+ entities, "Subject" is added to the list of headers to
+ take from the inner message, and the example is
+ modified to clarify this point.
+
+ (10) "Message/partial" fragmenters are restricted to
+ splitting MIME objects only at line boundaries.
+
+ (11) In the discussion of the application/postscript type,
+ an additional paragraph has been added warning about
+ possible interoperability problems caused by embedding
+ of binary data inside a PostScript MIME entity.
+
+
+
+
+Freed & Borenstein Standards Track [Page 17]
+\f
+RFC 2049 MIME Conformance November 1996
+
+
+ (12) Added a clarifying note to the basic syntax rules for
+ the Content-Type header field to make it clear that the
+ following two forms:
+
+ Content-type: text/plain; charset=us-ascii (comment)
+
+ Content-type: text/plain; charset="us-ascii"
+
+ are completely equivalent.
+
+ (13) The following sentence has been removed from the
+ discussion of the MIME-Version header: "However,
+ conformant software is encouraged to check the version
+ number and at least warn the user if an unrecognized
+ MIME-version is encountered."
+
+ (14) A typo was fixed that said "application/external-body"
+ instead of "message/external-body".
+
+ (15) The definition of a character set has been reorganized
+ to make the requirements clearer.
+
+ (16) The definition of the "image/gif" media type has been
+ moved to a separate document. This change was made
+ because of potential conflicts with IETF rules
+ governing the standardization of patented technology.
+
+ (17) The definitions of "7bit" and "8bit" have been
+ tightened so that use of bare CR, LF can only be used
+ as end-of-line sequences. The document also no longer
+ requires that NUL characters be preserved, which brings
+ MIME into alignment with real-world implementations.
+
+ (18) The definition of canonical text in MIME has been
+ tightened so that line breaks must be represented by a
+ CRLF sequence. CR and LF characters are not allowed
+ outside of this usage. The definition of quoted-
+ printable encoding has been altered accordingly.
+
+ (19) The definition of the quoted-printable encoding now
+ includes a number of suggestions for how quoted-
+ printable encoders might best handle improperly encoded
+ material.
+
+ (20) Prose was added to clarify the use of the "7bit",
+ "8bit", and "binary" transfer-encodings on multipart or
+ message entities encapsulating "8bit" or "binary" data.
+
+
+
+
+Freed & Borenstein Standards Track [Page 18]
+\f
+RFC 2049 MIME Conformance November 1996
+
+
+ (21) In the section on MIME Conformance, "multipart/digest"
+ support was added to the list of requirements for
+ minimal MIME conformance. Also, the requirement for
+ "message/rfc822" support were strengthened to clarify
+ the importance of recognizing recursive structure.
+
+ (22) The various restrictions on subtypes of "message" are
+ now specified entirely on a subtype by subtype basis.
+
+ (23) The definition of "message/rfc822" was changed to
+ indicate that at least one of the "From", "Subject", or
+ "Date" headers must be present.
+
+ (24) The required handling of unrecognized subtypes as
+ "application/octet-stream" has been made more explicit
+ in both the type definitions sections and the
+ conformance guidelines.
+
+ (25) Examples using text/richtext were changed to
+ text/enriched.
+
+ (26) The BNF definition of subtype has been changed to make
+ it clear that either an IANA registered subtype or a
+ nonstandard "X-" subtype must be used in a Content-Type
+ header field.
+
+ (27) MIME media types that are simply registered for use and
+ those that are standardized by the IETF are now
+ distinguished in the MIME BNF.
+
+ (28) All of the various MIME registration procedures have
+ been extensively revised. IANA registration procedures
+ for character sets have been moved to a separate
+ document that is no included in this set of documents.
+
+ (29) The use of escape and shift mechanisms in the US-ASCII
+ and ISO-8859-X character sets these documents define
+ have been clarified: Such mechanisms should never be
+ used in conjunction with these character sets and their
+ effect if they are used is undefined.
+
+ (30) The definition of the AFS access-type for
+ message/external-body has been removed.
+
+ (31) The handling of the combination of
+ multipart/alternative and message/external-body is now
+ specifically addressed.
+
+
+
+
+Freed & Borenstein Standards Track [Page 19]
+\f
+RFC 2049 MIME Conformance November 1996
+
+
+ (32) Security issues specific to message/external-body are
+ now discussed in some detail.
+
+Appendix C -- References
+
+ [ATK]
+ Borenstein, Nathaniel S., Multimedia Applications
+ Development with the Andrew Toolkit, Prentice-Hall, 1990.
+
+ [ISO-2022]
+ International Standard -- Information Processing --
+ Character Code Structure and Extension Techniques,
+ ISO/IEC 2022:1994, 4th ed.
+
+ [ISO-8859]
+ International Standard -- Information Processing -- 8-bit
+ Single-Byte Coded Graphic Character Sets
+ - Part 1: Latin Alphabet No. 1, ISO 8859-1:1987, 1st ed.
+ - Part 2: Latin Alphabet No. 2, ISO 8859-2:1987, 1st ed.
+ - Part 3: Latin Alphabet No. 3, ISO 8859-3:1988, 1st ed.
+ - Part 4: Latin Alphabet No. 4, ISO 8859-4:1988, 1st ed.
+ - Part 5: Latin/Cyrillic Alphabet, ISO 8859-5:1988, 1st
+ ed.
+ - Part 6: Latin/Arabic Alphabet, ISO 8859-6:1987, 1st ed.
+ - Part 7: Latin/Greek Alphabet, ISO 8859-7:1987, 1st ed.
+ - Part 8: Latin/Hebrew Alphabet, ISO 8859-8:1988, 1st ed.
+ - Part 9: Latin Alphabet No. 5, ISO/IEC 8859-9:1989, 1st
+ ed.
+ International Standard -- Information Technology -- 8-bit
+ Single-Byte Coded Graphic Character Sets
+ - Part 10: Latin Alphabet No. 6, ISO/IEC 8859-10:1992,
+ 1st ed.
+
+ [ISO-646]
+ International Standard -- Information Technology -- ISO
+ 7-bit Coded Character Set for Information Interchange,
+ ISO 646:1991, 3rd ed..
+
+ [JPEG]
+ JPEG Draft Standard ISO 10918-1 CD.
+
+ [MPEG]
+ Video Coding Draft Standard ISO 11172 CD, ISO
+ IEC/JTC1/SC2/WG11 (Motion Picture Experts Group), May,
+ 1991.
+
+
+
+
+
+
+Freed & Borenstein Standards Track [Page 20]
+\f
+RFC 2049 MIME Conformance November 1996
+
+
+ [PCM]
+ CCITT, Fascicle III.4 - Recommendation G.711, "Pulse Code
+ Modulation (PCM) of Voice Frequencies", Geneva, 1972.
+
+ [POSTSCRIPT]
+ Adobe Systems, Inc., PostScript Language Reference
+ Manual, Addison-Wesley, 1985.
+
+ [POSTSCRIPT2]
+ Adobe Systems, Inc., PostScript Language Reference
+ Manual, Addison-Wesley, Second Ed., 1990.
+
+ [RFC-783]
+ Sollins, K.R., "TFTP Protocol (revision 2)", RFC-783,
+ MIT, June 1981.
+
+ [RFC-821]
+ Postel, J.B., "Simple Mail Transfer Protocol", STD 10,
+ RFC 821, USC/Information Sciences Institute, August 1982.
+
+ [RFC-822]
+ Crocker, D., "Standard for the Format of ARPA Internet
+ Text Messages", STD 11, RFC 822, UDEL, August 1982.
+
+ [RFC-934]
+ Rose, M. and E. Stefferud, "Proposed Standard for Message
+ Encapsulation", RFC 934, Delaware and NMA, January 1985.
+
+ [RFC-959]
+ Postel, J. and J. Reynolds, "File Transfer Protocol", STD
+ 9, RFC 959, USC/Information Sciences Institute, October
+ 1985.
+
+ [RFC-1049]
+ Sirbu, M., "Content-Type Header Field for Internet
+ Messages", RFC 1049, CMU, March 1988.
+
+ [RFC-1154]
+ Robinson, D., and R. Ullmann, "Encoding Header Field for
+ Internet Messages", RFC 1154, Prime Computer, Inc., April
+ 1990.
+
+ [RFC-1341]
+ Borenstein, N., and N. Freed, "MIME (Multipurpose
+ Internet Mail Extensions): Mechanisms for Specifying and
+ Describing the Format of Internet Message Bodies", RFC
+ 1341, Bellcore, Innosoft, June 1992.
+
+
+
+
+Freed & Borenstein Standards Track [Page 21]
+\f
+RFC 2049 MIME Conformance November 1996
+
+
+ [RFC-1342]
+ Moore, K., "Representation of Non-Ascii Text in Internet
+ Message Headers", RFC 1342, University of Tennessee, June
+ 1992.
+
+ [RFC-1344]
+ Borenstein, N., "Implications of MIME for Internet Mail
+ Gateways", RFC 1344, Bellcore, June 1992.
+
+ [RFC-1345]
+ Simonsen, K., "Character Mnemonics & Character Sets", RFC
+ 1345, Rationel Almen Planlaegning, June 1992.
+
+ [RFC-1421]
+ Linn, J., "Privacy Enhancement for Internet Electronic
+ Mail: Part I -- Message Encryption and Authentication
+ Procedures", RFC 1421, IAB IRTF PSRG, IETF PEM WG,
+ February 1993.
+
+ [RFC-1422]
+ Kent, S., "Privacy Enhancement for Internet Electronic
+ Mail: Part II -- Certificate-Based Key Management", RFC
+ 1422, IAB IRTF PSRG, IETF PEM WG, February 1993.
+
+ [RFC-1423]
+ Balenson, D., "Privacy Enhancement for Internet
+ Electronic Mail: Part III -- Algorithms, Modes, and
+ Identifiers", IAB IRTF PSRG, IETF PEM WG, February 1993.
+
+ [RFC-1424]
+ Kaliski, B., "Privacy Enhancement for Internet Electronic
+ Mail: Part IV -- Key Certification and Related
+ Services", IAB IRTF PSRG, IETF PEM WG, February 1993.
+
+ [RFC-1521]
+ Borenstein, N., and Freed, N., "MIME (Multipurpose
+ Internet Mail Extensions): Mechanisms for Specifying and
+ Describing the Format of Internet Message Bodies", RFC
+ 1521, Bellcore, Innosoft, September, 1993.
+
+ [RFC-1522]
+ Moore, K., "Representation of Non-ASCII Text in Internet
+ Message Headers", RFC 1522, University of Tennessee,
+ September 1993.
+
+
+
+
+
+
+
+Freed & Borenstein Standards Track [Page 22]
+\f
+RFC 2049 MIME Conformance November 1996
+
+
+ [RFC-1524]
+ Borenstein, N., "A User Agent Configuration Mechanism for
+ Multimedia Mail Format Information", RFC 1524, Bellcore,
+ September 1993.
+
+ [RFC-1543]
+ Postel, J., "Instructions to RFC Authors", RFC 1543,
+ USC/Information Sciences Institute, October 1993.
+
+ [RFC-1556]
+ Nussbacher, H., "Handling of Bi-directional Texts in
+ MIME", RFC 1556, Israeli Inter-University Computer
+ Center, December 1993.
+
+ [RFC-1590]
+ Postel, J., "Media Type Registration Procedure", RFC
+ 1590, USC/Information Sciences Institute, March 1994.
+
+ [RFC-1602]
+ Internet Architecture Board, Internet Engineering
+ Steering Group, Huitema, C., Gross, P., "The Internet
+ Standards Process -- Revision 2", March 1994.
+
+ [RFC-1652]
+ Klensin, J., (WG Chair), Freed, N., (Editor), Rose, M.,
+ Stefferud, E., and Crocker, D., "SMTP Service Extension
+ for 8bit-MIME transport", RFC 1652, United Nations
+ University, Innosoft, Dover Beach Consulting, Inc.,
+ Network Management Associates, Inc., The Branch Office,
+ March 1994.
+
+ [RFC-1700]
+ Reynolds, J. and J. Postel, "Assigned Numbers", STD 2,
+ RFC 1700, USC/Information Sciences Institute, October
+ 1994.
+
+ [RFC-1741]
+ Faltstrom, P., Crocker, D., and Fair, E., "MIME Content
+ Type for BinHex Encoded Files", December 1994.
+
+ [RFC-1896]
+ Resnick, P., and A. Walker, "The text/enriched MIME
+ Content-type", RFC 1896, February, 1996.
+
+
+
+
+
+
+
+
+Freed & Borenstein Standards Track [Page 23]
+\f
+RFC 2049 MIME Conformance November 1996
+
+
+ [RFC-2045]
+ Freed, N., and and N. Borenstein, "Multipurpose Internet Mail
+ Extensions (MIME) Part One: Format of Internet Message
+ Bodies", RFC 2045, Innosoft, First Virtual Holdings,
+ November 1996.
+
+ [RFC-2046]
+ Freed, N., and N. Borenstein, "Multipurpose Internet Mail
+ Extensions (MIME) Part Two: Media Types", RFC 2046,
+ Innosoft, First Virtual Holdings, November 1996.
+
+ [RFC-2047]
+ Moore, K., "Multipurpose Internet Mail Extensions (MIME)
+ Part Three: Representation of Non-ASCII Text in Internet
+ Message Headers", RFC 2047, University of
+ Tennessee, November 1996.
+
+ [RFC-2048]
+ Freed, N., Klensin, J., and J. Postel, "Multipurpose
+ Internet Mail Extensions (MIME) Part Four: MIME
+ Registration Procedures", RFC 2048, Innosoft, MCI,
+ ISI, November 1996.
+
+ [RFC-2049]
+ Freed, N. and N. Borenstein, "Multipurpose Internet Mail
+ Extensions (MIME) Part Five: Conformance Criteria and
+ Examples", RFC 2049 (this document), Innosoft, First
+ Virtual Holdings, November 1996.
+
+ [US-ASCII]
+ Coded Character Set -- 7-Bit American Standard Code for
+ Information Interchange, ANSI X3.4-1986.
+
+ [X400]
+ Schicker, Pietro, "Message Handling Systems, X.400",
+ Message Handling Systems and Distributed Applications, E.
+ Stefferud, O-j. Jacobsen, and P. Schicker, eds., North-
+ Holland, 1989, pp. 3-41.
+
+
+
+
+
+
+
+
+
+
+
+
+
+Freed & Borenstein Standards Track [Page 24]
+\f
--- /dev/null
+
+
+
+
+
+
+Network Working Group N. Freed
+Request for Comments: 2231 Innosoft
+Updates: 2045, 2047, 2183 K. Moore
+Obsoletes: 2184 University of Tennessee
+Category: Standards Track November 1997
+
+
+ MIME Parameter Value and Encoded Word Extensions:
+ Character Sets, Languages, and Continuations
+
+
+Status of this Memo
+
+ This document specifies an Internet standards track protocol for the
+ Internet community, and requests discussion and suggestions for
+ improvements. Please refer to the current edition of the "Internet
+ Official Protocol Standards" (STD 1) for the standardization state
+ and status of this protocol. Distribution of this memo is unlimited.
+
+Copyright Notice
+
+ Copyright (C) The Internet Society (1997). All Rights Reserved.
+
+1. Abstract
+
+ This memo defines extensions to the RFC 2045 media type and RFC 2183
+ disposition parameter value mechanisms to provide
+
+ (1) a means to specify parameter values in character sets
+ other than US-ASCII,
+
+ (2) to specify the language to be used should the value be
+ displayed, and
+
+ (3) a continuation mechanism for long parameter values to
+ avoid problems with header line wrapping.
+
+ This memo also defines an extension to the encoded words defined in
+ RFC 2047 to allow the specification of the language to be used for
+ display as well as the character set.
+
+2. Introduction
+
+ The Multipurpose Internet Mail Extensions, or MIME [RFC-2045, RFC-
+ 2046, RFC-2047, RFC-2048, RFC-2049], define a message format that
+ allows for:
+
+
+
+
+
+Freed & Moore Standards Track [Page 1]
+\f
+RFC 2231 MIME Value and Encoded Word Extensions November 1997
+
+
+ (1) textual message bodies in character sets other than
+ US-ASCII,
+
+ (2) non-textual message bodies,
+
+ (3) multi-part message bodies, and
+
+ (4) textual header information in character sets other than
+ US-ASCII.
+
+ MIME is now widely deployed and is used by a variety of Internet
+ protocols, including, of course, Internet email. However, MIME's
+ success has resulted in the need for additional mechanisms that were
+ not provided in the original protocol specification.
+
+ In particular, existing MIME mechanisms provide for named media type
+ (content-type field) parameters as well as named disposition
+ (content-disposition field). A MIME media type may specify any
+ number of parameters associated with all of its subtypes, and any
+ specific subtype may specify additional parameters for its own use. A
+ MIME disposition value may specify any number of associated
+ parameters, the most important of which is probably the attachment
+ disposition's filename parameter.
+
+ These parameter names and values end up appearing in the content-type
+ and content-disposition header fields in Internet email. This
+ inherently imposes three crucial limitations:
+
+ (1) Lines in Internet email header fields are folded
+ according to RFC 822 folding rules. This makes long
+ parameter values problematic.
+
+ (2) MIME headers, like the RFC 822 headers they often
+ appear in, are limited to 7bit US-ASCII, and the
+ encoded-word mechanisms of RFC 2047 are not available
+ to parameter values. This makes it impossible to have
+ parameter values in character sets other than US-ASCII
+ without specifying some sort of private per-parameter
+ encoding.
+
+ (3) It has recently become clear that character set
+ information is not sufficient to properly display some
+ sorts of information -- language information is also
+ needed [RFC-2130]. For example, support for
+ handicapped users may require reading text string
+
+
+
+
+
+
+Freed & Moore Standards Track [Page 2]
+\f
+RFC 2231 MIME Value and Encoded Word Extensions November 1997
+
+
+ aloud. The language the text is written in is needed
+ for this to be done correctly. Some parameter values
+ may need to be displayed, hence there is a need to
+ allow for the inclusion of language information.
+
+ The last problem on this list is also an issue for the encoded words
+ defined by RFC 2047, as encoded words are intended primarily for
+ display purposes.
+
+ This document defines extensions that address all of these
+ limitations. All of these extensions are implemented in a fashion
+ that is completely compatible at a syntactic level with existing MIME
+ implementations. In addition, the extensions are designed to have as
+ little impact as possible on existing uses of MIME.
+
+ IMPORTANT NOTE: These mechanisms end up being somewhat gibbous when
+ they actually are used. As such, these mechanisms should not be used
+ lightly; they should be reserved for situations where a real need for
+ them exists.
+
+2.1. Requirements notation
+
+ This document occasionally uses terms that appear in capital letters.
+ When the terms "MUST", "SHOULD", "MUST NOT", "SHOULD NOT", and "MAY"
+ appear capitalized, they are being used to indicate particular
+ requirements of this specification. A discussion of the meanings of
+ these terms appears in [RFC- 2119].
+
+3. Parameter Value Continuations
+
+ Long MIME media type or disposition parameter values do not interact
+ well with header line wrapping conventions. In particular, proper
+ header line wrapping depends on there being places where linear
+ whitespace (LWSP) is allowed, which may or may not be present in a
+ parameter value, and even if present may not be recognizable as such
+ since specific knowledge of parameter value syntax may not be
+ available to the agent doing the line wrapping. The result is that
+ long parameter values may end up getting truncated or otherwise
+ damaged by incorrect line wrapping implementations.
+
+ A mechanism is therefore needed to break up parameter values into
+ smaller units that are amenable to line wrapping. Any such mechanism
+ MUST be compatible with existing MIME processors. This means that
+
+ (1) the mechanism MUST NOT change the syntax of MIME media
+ type and disposition lines, and
+
+
+
+
+
+Freed & Moore Standards Track [Page 3]
+\f
+RFC 2231 MIME Value and Encoded Word Extensions November 1997
+
+
+ (2) the mechanism MUST NOT depend on parameter ordering
+ since MIME states that parameters are not order
+ sensitive. Note that while MIME does prohibit
+ modification of MIME headers during transport, it is
+ still possible that parameters will be reordered when
+ user agent level processing is done.
+
+ The obvious solution, then, is to use multiple parameters to contain
+ a single parameter value and to use some kind of distinguished name
+ to indicate when this is being done. And this obvious solution is
+ exactly what is specified here: The asterisk character ("*") followed
+ by a decimal count is employed to indicate that multiple parameters
+ are being used to encapsulate a single parameter value. The count
+ starts at 0 and increments by 1 for each subsequent section of the
+ parameter value. Decimal values are used and neither leading zeroes
+ nor gaps in the sequence are allowed.
+
+ The original parameter value is recovered by concatenating the
+ various sections of the parameter, in order. For example, the
+ content-type field
+
+ Content-Type: message/external-body; access-type=URL;
+ URL*0="ftp://";
+ URL*1="cs.utk.edu/pub/moore/bulk-mailer/bulk-mailer.tar"
+
+ is semantically identical to
+
+ Content-Type: message/external-body; access-type=URL;
+ URL="ftp://cs.utk.edu/pub/moore/bulk-mailer/bulk-mailer.tar"
+
+ Note that quotes around parameter values are part of the value
+ syntax; they are NOT part of the value itself. Furthermore, it is
+ explicitly permitted to have a mixture of quoted and unquoted
+ continuation fields.
+
+4. Parameter Value Character Set and Language Information
+
+ Some parameter values may need to be qualified with character set or
+ language information. It is clear that a distinguished parameter
+ name is needed to identify when this information is present along
+ with a specific syntax for the information in the value itself. In
+ addition, a lightweight encoding mechanism is needed to accommodate 8
+ bit information in parameter values.
+
+
+
+
+
+
+
+
+Freed & Moore Standards Track [Page 4]
+\f
+RFC 2231 MIME Value and Encoded Word Extensions November 1997
+
+
+ Asterisks ("*") are reused to provide the indicator that language and
+ character set information is present and encoding is being used. A
+ single quote ("'") is used to delimit the character set and language
+ information at the beginning of the parameter value. Percent signs
+ ("%") are used as the encoding flag, which agrees with RFC 2047.
+
+ Specifically, an asterisk at the end of a parameter name acts as an
+ indicator that character set and language information may appear at
+ the beginning of the parameter value. A single quote is used to
+ separate the character set, language, and actual value information in
+ the parameter value string, and an percent sign is used to flag
+ octets encoded in hexadecimal. For example:
+
+ Content-Type: application/x-stuff;
+ title*=us-ascii'en-us'This%20is%20%2A%2A%2Afun%2A%2A%2A
+
+ Note that it is perfectly permissible to leave either the character
+ set or language field blank. Note also that the single quote
+ delimiters MUST be present even when one of the field values is
+ omitted. This is done when either character set, language, or both
+ are not relevant to the parameter value at hand. This MUST NOT be
+ done in order to indicate a default character set or language --
+ parameter field definitions MUST NOT assign a default character set
+ or language.
+
+4.1. Combining Character Set, Language, and Parameter Continuations
+
+ Character set and language information may be combined with the
+ parameter continuation mechanism. For example:
+
+ Content-Type: application/x-stuff
+ title*0*=us-ascii'en'This%20is%20even%20more%20
+ title*1*=%2A%2A%2Afun%2A%2A%2A%20
+ title*2="isn't it!"
+
+ Note that:
+
+ (1) Language and character set information only appear at
+ the beginning of a given parameter value.
+
+ (2) Continuations do not provide a facility for using more
+ than one character set or language in the same
+ parameter value.
+
+ (3) A value presented using multiple continuations may
+ contain a mixture of encoded and unencoded segments.
+
+
+
+
+
+Freed & Moore Standards Track [Page 5]
+\f
+RFC 2231 MIME Value and Encoded Word Extensions November 1997
+
+
+ (4) The first segment of a continuation MUST be encoded if
+ language and character set information are given.
+
+ (5) If the first segment of a continued parameter value is
+ encoded the language and character set field delimiters
+ MUST be present even when the fields are left blank.
+
+5. Language specification in Encoded Words
+
+ RFC 2047 provides support for non-US-ASCII character sets in RFC 822
+ message header comments, phrases, and any unstructured text field.
+ This is done by defining an encoded word construct which can appear
+ in any of these places. Given that these are fields intended for
+ display, it is sometimes necessary to associate language information
+ with encoded words as well as just the character set. This
+ specification extends the definition of an encoded word to allow the
+ inclusion of such information. This is simply done by suffixing the
+ character set specification with an asterisk followed by the language
+ tag. For example:
+
+ From: =?US-ASCII*EN?Q?Keith_Moore?= <moore@cs.utk.edu>
+
+6. IMAP4 Handling of Parameter Values
+
+ IMAP4 [RFC-2060] servers SHOULD decode parameter value continuations
+ when generating the BODY and BODYSTRUCTURE fetch attributes.
+
+7. Modifications to MIME ABNF
+
+ The ABNF for MIME parameter values given in RFC 2045 is:
+
+ parameter := attribute "=" value
+
+ attribute := token
+ ; Matching of attributes
+ ; is ALWAYS case-insensitive.
+
+ This specification changes this ABNF to:
+
+ parameter := regular-parameter / extended-parameter
+
+ regular-parameter := regular-parameter-name "=" value
+
+ regular-parameter-name := attribute [section]
+
+ attribute := 1*attribute-char
+
+
+
+
+
+Freed & Moore Standards Track [Page 6]
+\f
+RFC 2231 MIME Value and Encoded Word Extensions November 1997
+
+
+ attribute-char := <any (US-ASCII) CHAR except SPACE, CTLs,
+ "*", "'", "%", or tspecials>
+
+ section := initial-section / other-sections
+
+ initial-section := "*0"
+
+ other-sections := "*" ("1" / "2" / "3" / "4" / "5" /
+ "6" / "7" / "8" / "9") *DIGIT)
+
+ extended-parameter := (extended-initial-name "="
+ extended-value) /
+ (extended-other-names "="
+ extended-other-values)
+
+ extended-initial-name := attribute [initial-section] "*"
+
+ extended-other-names := attribute other-sections "*"
+
+ extended-initial-value := [charset] "'" [language] "'"
+ extended-other-values
+
+ extended-other-values := *(ext-octet / attribute-char)
+
+ ext-octet := "%" 2(DIGIT / "A" / "B" / "C" / "D" / "E" / "F")
+
+ charset := <registered character set name>
+
+ language := <registered language tag [RFC-1766]>
+
+ The ABNF given in RFC 2047 for encoded-words is:
+
+ encoded-word := "=?" charset "?" encoding "?" encoded-text "?="
+
+ This specification changes this ABNF to:
+
+ encoded-word := "=?" charset ["*" language] "?" encoded-text "?="
+
+8. Character sets which allow specification of language
+
+ In the future it is likely that some character sets will provide
+ facilities for inline language labeling. Such facilities are
+ inherently more flexible than those defined here as they allow for
+ language switching in the middle of a string.
+
+
+
+
+
+
+
+Freed & Moore Standards Track [Page 7]
+\f
+RFC 2231 MIME Value and Encoded Word Extensions November 1997
+
+
+ If and when such facilities are developed they SHOULD be used in
+ preference to the language labeling facilities specified here. Note
+ that all the mechanisms defined here allow for the omission of
+ language labels so as to be able to accommodate this possible future
+ usage.
+
+9. Security Considerations
+
+ This RFC does not discuss security issues and is not believed to
+ raise any security issues not already endemic in electronic mail and
+ present in fully conforming implementations of MIME.
+
+10. References
+
+ [RFC-822]
+ Crocker, D., "Standard for the Format of ARPA Internet
+ Text Messages", STD 11, RFC 822 August 1982.
+
+ [RFC-1766]
+ Alvestrand, H., "Tags for the Identification of
+ Languages", RFC 1766, March 1995.
+
+ [RFC-2045]
+ Freed, N., and N. Borenstein, "Multipurpose Internet Mail
+ Extensions (MIME) Part One: Format of Internet Message
+ Bodies", RFC 2045, December 1996.
+
+ [RFC-2046]
+ Freed, N. and N. Borenstein, "Multipurpose Internet Mail
+ Extensions (MIME) Part Two: Media Types", RFC 2046,
+ December 1996.
+
+ [RFC-2047]
+ Moore, K., "Multipurpose Internet Mail Extensions (MIME)
+ Part Three: Representation of Non-ASCII Text in Internet
+ Message Headers", RFC 2047, December 1996.
+
+ [RFC-2048]
+ Freed, N., Klensin, J. and J. Postel, "Multipurpose
+ Internet Mail Extensions (MIME) Part Four: MIME
+ Registration Procedures", RFC 2048, December 1996.
+
+ [RFC-2049]
+ Freed, N. and N. Borenstein, "Multipurpose Internet Mail
+ Extensions (MIME) Part Five: Conformance Criteria and
+ Examples", RFC 2049, December 1996.
+
+
+
+
+
+Freed & Moore Standards Track [Page 8]
+\f
+RFC 2231 MIME Value and Encoded Word Extensions November 1997
+
+
+ [RFC-2060]
+ Crispin, M., "Internet Message Access Protocol - Version
+ 4rev1", RFC 2060, December 1996.
+
+ [RFC-2119]
+ Bradner, S., "Key words for use in RFCs to Indicate
+ Requirement Levels", RFC 2119, March 1997.
+
+ [RFC-2130]
+ Weider, C., Preston, C., Simonsen, K., Alvestrand, H.,
+ Atkinson, R., Crispin, M., and P. Svanberg, "Report from the
+ IAB Character Set Workshop", RFC 2130, April 1997.
+
+ [RFC-2183]
+ Troost, R., Dorner, S. and K. Moore, "Communicating
+ Presentation Information in Internet Messages: The
+ Content-Disposition Header", RFC 2183, August 1997.
+
+11. Authors' Addresses
+
+ Ned Freed
+ Innosoft International, Inc.
+ 1050 Lakes Drive
+ West Covina, CA 91790
+ USA
+
+ Phone: +1 626 919 3600
+ Fax: +1 626 919 3614
+ EMail: ned.freed@innosoft.com
+
+
+ Keith Moore
+ Computer Science Dept.
+ University of Tennessee
+ 107 Ayres Hall
+ Knoxville, TN 37996-1301
+ USA
+
+ EMail: moore@cs.utk.edu
+
+
+
+
+
+
+
+
+
+
+
+
+Freed & Moore Standards Track [Page 9]
+\f
+RFC 2231 MIME Value and Encoded Word Extensions November 1997
+
+
+12. Full Copyright Statement
+
+ Copyright (C) The Internet Society (1997). All Rights Reserved.
+
+ This document and translations of it may be copied and furnished to
+ others, and derivative works that comment on or otherwise explain it
+ or assist in its implementation may be prepared, copied, published
+ and distributed, in whole or in part, without restriction of any
+ kind, provided that the above copyright notice and this paragraph are
+ included on all such copies and derivative works. However, this
+ document itself may not be modified in any way, such as by removing
+ the copyright notice or references to the Internet Society or other
+ Internet organizations, except as needed for the purpose of
+ developing Internet standards in which case the procedures for
+ copyrights defined in the Internet Standards process must be
+ followed, or as required to translate it into languages other than
+ English.
+
+ The limited permissions granted above are perpetual and will not be
+ revoked by the Internet Society or its successors or assigns.
+
+ This document and the information contained herein is provided on an
+ "AS IS" basis and THE INTERNET SOCIETY AND THE INTERNET ENGINEERING
+ TASK FORCE DISCLAIMS ALL WARRANTIES, EXPRESS OR IMPLIED, INCLUDING
+ BUT NOT LIMITED TO ANY WARRANTY THAT THE USE OF THE INFORMATION
+ HEREIN WILL NOT INFRINGE ANY RIGHTS OR ANY IMPLIED WARRANTIES OF
+ MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE.
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+Freed & Moore Standards Track [Page 10]
+\f
--- /dev/null
+
+
+
+
+
+
+Network Working Group L. Masinter
+Request for Comments: 2388 Xerox Corporation
+Category: Standards Track August 1998
+
+
+ Returning Values from Forms: multipart/form-data
+
+Status of this Memo
+
+ This document specifies an Internet standards track protocol for the
+ Internet community, and requests discussion and suggestions for
+ improvements. Please refer to the current edition of the "Internet
+ Official Protocol Standards" (STD 1) for the standardization state
+ and status of this protocol. Distribution of this memo is unlimited.
+
+Copyright Notice
+
+ Copyright (C) The Internet Society (1998). All Rights Reserved.
+
+1. Abstract
+
+ This specification defines an Internet Media Type, multipart/form-
+ data, which can be used by a wide variety of applications and
+ transported by a wide variety of protocols as a way of returning a
+ set of values as the result of a user filling out a form.
+
+2. Introduction
+
+ In many applications, it is possible for a user to be presented with
+ a form. The user will fill out the form, including information that
+ is typed, generated by user input, or included from files that the
+ user has selected. When the form is filled out, the data from the
+ form is sent from the user to the receiving application.
+
+ The definition of MultiPart/Form-Data is derived from one of those
+ applications, originally set out in [RFC1867] and subsequently
+ incorporated into [HTML40], where forms are expressed in HTML, and in
+ which the form values are sent via HTTP or electronic mail. This
+ representation is widely implemented in numerous web browsers and web
+ servers.
+
+ However, multipart/form-data can be used for forms that are presented
+ using representations other than HTML (spreadsheets, Portable
+ Document Format, etc), and for transport using other means than
+ electronic mail or HTTP. This document defines the representation of
+ form values independently of the application for which it is used.
+
+
+
+
+
+Masinter Standards Track [Page 1]
+\f
+RFC 2388 multipart/form-data August 1998
+
+
+3. Definition of multipart/form-data
+
+ The media-type multipart/form-data follows the rules of all multipart
+ MIME data streams as outlined in [RFC 2046]. In forms, there are a
+ series of fields to be supplied by the user who fills out the form.
+ Each field has a name. Within a given form, the names are unique.
+
+ "multipart/form-data" contains a series of parts. Each part is
+ expected to contain a content-disposition header [RFC 2183] where the
+ disposition type is "form-data", and where the disposition contains
+ an (additional) parameter of "name", where the value of that
+ parameter is the original field name in the form. For example, a part
+ might contain a header:
+
+ Content-Disposition: form-data; name="user"
+
+ with the value corresponding to the entry of the "user" field.
+
+ Field names originally in non-ASCII character sets may be encoded
+ within the value of the "name" parameter using the standard method
+ described in RFC 2047.
+
+ As with all multipart MIME types, each part has an optional
+ "Content-Type", which defaults to text/plain. If the contents of a
+ file are returned via filling out a form, then the file input is
+ identified as the appropriate media type, if known, or
+ "application/octet-stream". If multiple files are to be returned as
+ the result of a single form entry, they should be represented as a
+ "multipart/mixed" part embedded within the "multipart/form-data".
+
+ Each part may be encoded and the "content-transfer-encoding" header
+ supplied if the value of that part does not conform to the default
+ encoding.
+
+4. Use of multipart/form-data
+
+4.1 Boundary
+
+ As with other multipart types, a boundary is selected that does not
+ occur in any of the data. Each field of the form is sent, in the
+ order defined by the sending appliction and form, as a part of the
+ multipart stream. Each part identifies the INPUT name within the
+ original form. Each part should be labelled with an appropriate
+ content-type if the media type is known (e.g., inferred from the file
+ extension or operating system typing information) or as
+ "application/octet-stream".
+
+
+
+
+
+Masinter Standards Track [Page 2]
+\f
+RFC 2388 multipart/form-data August 1998
+
+
+4.2 Sets of files
+
+ If the value of a form field is a set of files rather than a single
+ file, that value can be transferred together using the
+ "multipart/mixed" format.
+
+4.3 Encoding
+
+ While the HTTP protocol can transport arbitrary binary data, the
+ default for mail transport is the 7BIT encoding. The value supplied
+ for a part may need to be encoded and the "content-transfer-encoding"
+ header supplied if the value does not conform to the default
+ encoding. [See section 5 of RFC 2046 for more details.]
+
+4.4 Other attributes
+
+ Forms may request file inputs from the user; the form software may
+ include the file name and other file attributes, as specified in [RFC
+ 2184].
+
+ The original local file name may be supplied as well, either as a
+ "filename" parameter either of the "content-disposition: form-data"
+ header or, in the case of multiple files, in a "content-disposition:
+ file" header of the subpart. The sending application MAY supply a
+ file name; if the file name of the sender's operating system is not
+ in US-ASCII, the file name might be approximated, or encoded using
+ the method of RFC 2231.
+
+ This is a convenience for those cases where the files supplied by the
+ form might contain references to each other, e.g., a TeX file and its
+ .sty auxiliary style description.
+
+4.5 Charset of text in form data
+
+ Each part of a multipart/form-data is supposed to have a content-
+ type. In the case where a field element is text, the charset
+ parameter for the text indicates the character encoding used.
+
+ For example, a form with a text field in which a user typed 'Joe owes
+ <eu>100' where <eu> is the Euro symbol might have form data returned
+ as:
+
+ --AaB03x
+ content-disposition: form-data; name="field1"
+ content-type: text/plain;charset=windows-1250
+ content-transfer-encoding: quoted-printable
+
+
+
+
+
+Masinter Standards Track [Page 3]
+\f
+RFC 2388 multipart/form-data August 1998
+
+
+ Joe owes =80100.
+ --AaB03x
+
+5. Operability considerations
+
+5.1 Compression, encryption
+
+ Some of the data in forms may be compressed or encrypted, using other
+ MIME mechanisms. This is a function of the application that is
+ generating the form-data.
+
+5.2 Other data encodings rather than multipart
+
+ Various people have suggested using new mime top-level type
+ "aggregate", e.g., aggregate/mixed or a content-transfer-encoding of
+ "packet" to express indeterminate-length binary data, rather than
+ relying on the multipart-style boundaries. While this would be
+ useful, the "multipart" mechanisms are well established, simple to
+ implement on both the sending client and receiving server, and as
+ efficient as other methods of dealing with multiple combinations of
+ binary data.
+
+ The multipart/form-data encoding has a high overhead and performance
+ impact if there are many fields with short values. However, in
+ practice, for the forms in use, for example, in HTML, the average
+ overhead is not significant.
+
+5.3 Remote files with third-party transfer
+
+ In some scenarios, the user operating the form software might want to
+ specify a URL for remote data rather than a local file. In this case,
+ is there a way to allow the browser to send to the client a pointer
+ to the external data rather than the entire contents? This capability
+ could be implemented, for example, by having the client send to the
+ server data of type "message/external-body" with "access-type" set
+ to, say, "uri", and the URL of the remote data in the body of the
+ message.
+
+5.4 Non-ASCII field names
+
+ Note that MIME headers are generally required to consist only of 7-
+ bit data in the US-ASCII character set. Hence field names should be
+ encoded according to the method in RFC 2047 if they contain
+ characters outside of that set.
+
+
+
+
+
+
+
+Masinter Standards Track [Page 4]
+\f
+RFC 2388 multipart/form-data August 1998
+
+
+5.5 Ordered fields and duplicated field names
+
+ The relationship of the ordering of fields within a form and the
+ ordering of returned values within "multipart/form-data" is not
+ defined by this specification, nor is the handling of the case where
+ a form has multiple fields with the same name. While HTML-based forms
+ may send back results in the order received, and intermediaries
+ should not reorder the results, there are some systems which might
+ not define a natural order for form fields.
+
+5.6 Interoperability with web applications
+
+ Many web applications use the "application/x-url-encoded" method for
+ returning data from forms. This format is quite compact, e.g.:
+
+ name=Xavier+Xantico&verdict=Yes&colour=Blue&happy=sad&Utf%F6r=Send
+
+ however, there is no opportunity to label the enclosed data with
+ content type, apply a charset, or use other encoding mechanisms.
+
+ Many form-interpreting programs (primarly web browsers) now implement
+ and generate multipart/form-data, but an existing application might
+ need to optionally support both the application/x-url-encoded format
+ as well.
+
+5.7 Correlating form data with the original form
+
+ This specification provides no specific mechanism by which
+ multipart/form-data can be associated with the form that caused it to
+ be transmitted. This separation is intentional; many different forms
+ might be used for transmitting the same data. In practice,
+ applications may supply a specific form processing resource (in HTML,
+ the ACTION attribute in a FORM tag) for each different form.
+ Alternatively, data about the form might be encoded in a "hidden
+ field" (a field which is part of the form but which has a fixed value
+ to be transmitted back to the form-data processor.)
+
+6. Security Considerations
+
+ The data format described in this document introduces no new security
+ considerations outside of those introduced by the protocols that use
+ it and of the component elements. It is important when interpreting
+ content-disposition to not overwrite files in the recipients address
+ space inadvertently.
+
+ User applications that request form information from users must be
+ careful not to cause a user to send information to the requestor or a
+ third party unwillingly or unwittingly. For example, a form might
+
+
+
+Masinter Standards Track [Page 5]
+\f
+RFC 2388 multipart/form-data August 1998
+
+
+ request 'spam' information to be sent to an unintended third party,
+ or private information to be sent to someone that the user might not
+ actually intend. While this is primarily an issue for the
+ representation and interpretation of forms themselves, rather than
+ the data representation of the result of form transmission, the
+ transportation of private information must be done in a way that does
+ not expose it to unwanted prying.
+
+ With the introduction of form-data that can reasonably send back the
+ content of files from user's file space, the possibility that a user
+ might be sent an automated script that fills out a form and then
+ sends the user's local file to another address arises. Thus,
+ additional caution is required when executing automated scripting
+ where form-data might include user's files.
+
+7. Author's Address
+
+ Larry Masinter
+ Xerox Palo Alto Research Center
+ 3333 Coyote Hill Road
+ Palo Alto, CA 94304
+
+ Fax: +1 650 812 4333
+ EMail: masinter@parc.xerox.com
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+Masinter Standards Track [Page 6]
+\f
+RFC 2388 multipart/form-data August 1998
+
+
+Appendix A. Media type registration for multipart/form-data
+
+ Media Type name:
+ multipart
+
+ Media subtype name:
+ form-data
+
+ Required parameters:
+ none
+
+ Optional parameters:
+ none
+
+ Encoding considerations:
+ No additional considerations other than as for other multipart
+ types.
+
+ Security Considerations
+ Applications which receive forms and process them must be careful
+ not to supply data back to the requesting form processing site that
+ was not intended to be sent by the recipient. This is a
+ consideration for any application that generates a multipart/form-
+ data.
+
+ The multipart/form-data type introduces no new security
+ considerations for recipients beyond what might occur with any of
+ the enclosed parts.
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+Masinter Standards Track [Page 7]
+\f
+RFC 2388 multipart/form-data August 1998
+
+
+References
+
+ [RFC 2046] Freed, N., and N. Borenstein, "Multipurpose Internet Mail
+ Extensions (MIME) Part Two: Media Types", RFC 2046,
+ November 1996.
+
+ [RFC 2047] Moore, K., "MIME (Multipurpose Internet Mail Extensions)
+ Part Three: Message Header Extensions for Non-ASCII Text",
+ RFC 2047, November 1996.
+
+ [RFC 2231] Freed, N., and K. Moore, "MIME Parameter Value and Encoded
+ Word Extensions: Character Sets, Languages, and
+ Continuations", RFC 2231, November 1997.
+
+ [RFC 1806] Troost, R., and S. Dorner, "Communicating Presentation
+ Information in Internet Messages: The Content-Disposition
+ Header", RFC 1806, June 1995.
+
+ [RFC 1867] Nebel, E., and L. Masinter, "Form-based File Upload in
+ HTML", RFC 1867, November 1995.
+
+ [RFC 2183] Troost, R., Dorner, S., and K. Moore, "Communicating
+ Presentation Information in Internet Messages: The
+ Content-Disposition Header Field", RFC 2183, August 1997.
+
+ [RFC 2184] Freed, N., and K. Moore, "MIME Parameter Value and Encoded
+ Word Extensions: Character Sets, Languages, and
+ Continuations", RFC 2184, August 1997.
+
+ [HTML40] D. Raggett, A. Le Hors, I. Jacobs. "HTML 4.0
+ Specification", World Wide Web Consortium Technical Report
+ "REC-html40", December, 1997. <http://www.w3.org/TR/REC-
+ html40/>
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+Masinter Standards Track [Page 8]
+\f
+RFC 2388 multipart/form-data August 1998
+
+
+Full Copyright Statement
+
+ Copyright (C) The Internet Society (1998). All Rights Reserved.
+
+ This document and translations of it may be copied and furnished to
+ others, and derivative works that comment on or otherwise explain it
+ or assist in its implementation may be prepared, copied, published
+ and distributed, in whole or in part, without restriction of any
+ kind, provided that the above copyright notice and this paragraph are
+ included on all such copies and derivative works. However, this
+ document itself may not be modified in any way, such as by removing
+ the copyright notice or references to the Internet Society or other
+ Internet organizations, except as needed for the purpose of
+ developing Internet standards in which case the procedures for
+ copyrights defined in the Internet Standards process must be
+ followed, or as required to translate it into languages other than
+ English.
+
+ The limited permissions granted above are perpetual and will not be
+ revoked by the Internet Society or its successors or assigns.
+
+ This document and the information contained herein is provided on an
+ "AS IS" basis and THE INTERNET SOCIETY AND THE INTERNET ENGINEERING
+ TASK FORCE DISCLAIMS ALL WARRANTIES, EXPRESS OR IMPLIED, INCLUDING
+ BUT NOT LIMITED TO ANY WARRANTY THAT THE USE OF THE INFORMATION
+ HEREIN WILL NOT INFRINGE ANY RIGHTS OR ANY IMPLIED WARRANTIES OF
+ MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE.
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+Masinter Standards Track [Page 9]
+\f
--- /dev/null
+;; -*- lisp -*-
+
+(defsystem :rfc2388-binary
+ :components ((:static-file "rfc2388-binary.asd")
+ (:module "source"
+ :components ((:file "packages")
+ (:file "utils" :depends-on ("packages"))
+ (:file "api" :depends-on ("packages" "utils"))
+ (:file "parsing" :depends-on ("packages" "utils" "api"))))))
+
+(defsystem :rfc2388-binary/test
+ :components ((:module "test"
+ :components ((:file "packages")
+ (:file "test" :depends-on ("packages")))))
+ :depends-on (:arnesi
+ :fiveam
+ :rfc2388-binary))
+
+
+;;;; * Parsing rfc2888 formatted data
+
+;;;; This library provides code for parsing multipart/form-data data
+;;;; streams.
+
+;;;; The main entry-point is the function READ-MIME. Due the various
+;;;; application specific ways in which the content should be treated
+;;;; our parser uses application supplied calbacks to deal with the
+;;;; actual data.
+
+;;;; The function PARSE-MIME is provided as a convenient wrapper
+;;;; around READ-MIME which assumse that all data can fit in memory
+;;;; and that it can be converted using nothing more that #'code-char.
+
+;;;;@include "source/packages.lisp"
+
+;;;;@include "source/rfc2388.lisp"
+
+;;;; * Known Issues
+
+;;;; ** Non US-ASCII field names
+
+;;;; Currently we assume that the names of all form fields are
+;;;; US-ASCII characters. Should a developer create a form whose name
+;;;; is "π" (greek small letter pi) it is
+;;;; browser+server+implementation specific how this will be
+;;;; translated by this code.
+
+;; Copyright (c) 2003 Janis Dzerins
+;; Copyright (c) 2005 Edward Marco Baringer
+;;
+;; 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 BY THE AUTHOR ``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 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.
--- /dev/null
+;; -*- lisp -*-
+
+#+xcvb
+(module
+ (:depends-on ("source/packages")))
+
+(in-package :rfc2388-binary)
+
+;;;; ** Public Interface
+
+(defgeneric read-mime (source boundary callback)
+ (:documentation
+ "Parses the MIME entites in SOURCE.
+
+SOURCE is either a vector of (unsigned-byte 8) or a stream whose
+element-type is (unsigned-byte 8). BOUNDARY is either a string of
+US-ASCII encodeable characters or a byte vector. CALLBACK is a
+function which will be passed one argument, a MIME-PART
+containing the headers of the mime part and must return the following
+values:
+
+- a byte-handler function. This is a one argument function which
+ will be passed every byte in the mime part's content.
+
+- a termination function. This is a function without arguments
+ and will be called when the operation finishes without errors.
+ It must return whatever is to be returned from read-mime.
+
+- an optional abort function. This is a function without arguments
+ and will be called when the operation is aborted due to an error.
+
+READ-MIME consumes bytes from SOURCE and returns a list of the
+whatever the various termination functions returned.
+
+Example:
+
+ (read-mime #<a binary stream> \"123\"
+ (lambda (mime-part)
+ (values (lambda (byte) (collect-byte-somewhere byte))
+ (lambda () mime-part))))
+
+ This call would return a list of mime-part objects passing each
+byte to collect-byte-somewhere.
+
+You may also want to look at UCW for a real-world example."))
+
+(defclass mime-part ()
+ ((content :accessor content :initform nil)
+ (content-length :accessor content-length :initform nil)
+ (content-type :accessor content-type :initform nil)
+ (content-charset :accessor content-charset :initform nil)
+ (headers :accessor headers :initform '())))
+
+(defgeneric mime-part-p (object)
+ (:method ((object mime-part)) t)
+ (:method ((object t)) nil))
+
+(defun print-mime-part (part &optional (stream *trace-output*))
+ (check-type part mime-part)
+ (format stream "Headers:~%")
+ (dolist (header (headers part))
+ (format stream "~S: ~S~:{; ~S=~S~}~%"
+ (header-name header) (header-value header)
+ (mapcar (lambda (attribute)
+ (list (car attribute) (cdr attribute)))
+ (header-attributes header))))
+ (format stream "~%Content:~%")
+ (princ (content part) stream)
+ (format stream "~%"))
+
+(defgeneric get-header (part header-name)
+ (:documentation "Returns the mime-header object for the header named HEADER-NAME (a string)."))
+
+(defmethod get-header ((part mime-part) (header-name string))
+ (find header-name (headers part)
+ :key #'header-name
+ :test #'string=))
+
+(defclass mime-header ()
+ ((name :accessor header-name
+ :initarg :name)
+ (value :accessor header-value
+ :initarg :value)
+ (attributes :accessor header-attributes
+ :initarg :attributes)))
+
+(defgeneric get-header-attribute (header name)
+ (:documentation "Returns the value of the attribute named NAME
+ in the header HEADER."))
+
+(defmethod get-header-attribute ((header mime-header) (name string))
+ (cdr (assoc name (header-attributes header) :test #'string-equal)))
+
+(defun parse-mime (source boundary
+ &key write-content-to-file
+ (byte-encoder #'code-char))
+ "Parses MIME entities, returning them as a list.
+
+Each element in the list is of form: (body headers), where BODY is the
+contents of MIME part, and HEADERS are all headers for that part.
+BOUNDARY is a string used to separate MIME entities.
+
+This is the convenience interface to READ-MIME, all data is read
+into memory or a file and we assume that every byte in the data
+corresponds to exactly one character.
+
+The SOURCE and BOUNDARY arguments are passed unchanged to
+READ-MIME. See READ-MIME's documentation for details."
+ (check-type write-content-to-file (or null string pathname))
+ (read-mime source boundary
+ (if write-content-to-file
+ (make-mime-file-writer write-content-to-file
+ :byte-encoder byte-encoder)
+ (make-mime-buffer-writer :byte-encoder byte-encoder))))
+
+;; Copyright (c) 2003 Janis Dzerins
+;; Modifications for TBNL Copyright (c) 2004 Michael Weber and Dr. Edmund Weitz
+;; Copyright (c) 2005 Edward Marco Baringer
+;;
+;; 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 BY THE AUTHOR ``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 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.
--- /dev/null
+;; -*- lisp -*-
+
+#+xcvb
+(module
+ (:description "package declaration for rfc2388"))
+
+(in-package :cl-user)
+
+(defpackage :rfc2388-binary
+ (:use :common-lisp)
+ (:export
+
+ #:parse-mime
+ #:read-mime
+
+ #:mime-part
+ #:mime-part-p
+ #:content
+ #:content-type
+ #:content-length
+ #:content-charset
+ #:headers
+ #:get-header
+ #:header-name
+ #:header-value
+ #:header-attributes
+ #:get-header-attribute
+ #:print-mime-part
+
+ #:parse-header-value))
+
+;; Copyright (c) 2003 Janis Dzerins
+;; Copyright (c) 2005 Edward Marco Baringer
+;;
+;; 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 BY THE AUTHOR ``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 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.
--- /dev/null
+;; -*- lisp -*-
+
+#+xcvb
+(module
+ (:depends-on ("source/packages"
+ "source/utils")))
+
+(in-package :rfc2388-binary)
+
+(defmethod read-mime ((source string) boundary callback-factory)
+ (with-input-from-string (source source)
+ (read-mime source boundary callback-factory)))
+
+(defmethod read-mime ((source stream) (boundary string) callback-factory)
+ (read-mime source (ascii-string-to-boundary-array boundary) callback-factory))
+
+(defmethod read-mime ((source stream) (boundary array) callback-factory)
+ (declare (optimize speed))
+ (unless (functionp callback-factory)
+ (setf callback-factory (fdefinition callback-factory)))
+ ;; read up to the first part
+ (read-until-next-boundary source boundary #'identity :assume-first-boundary t)
+ ;; read headers and boundries until we're done
+ (loop
+ with keep-on = t
+ with parts = '() ;; hold all the parts in this list
+ while keep-on
+ for part = (make-instance 'mime-part) ;; each iteration around
+ ;; this loop creates a
+ ;; part, unless we get a
+ ;; multipart/mixed
+ do (progn
+ ;; read in the headers
+ (loop named read-headers
+ do (multiple-value-bind (found-header name value)
+ (read-next-header source)
+ (if found-header
+ (multiple-value-bind (value attributes)
+ (parse-header-value value)
+ (let ((header (make-instance 'mime-header
+ :name name
+ :value value
+ :attributes attributes)))
+ (push header (headers part))
+ (cond
+ ((string-equal "Content-Type" name)
+ (setf (content-type part) value)
+ (when (get-header-attribute header "charset")
+ (setf (content-charset part) (get-header-attribute header "charset"))))
+ ((string-equal "Content-Length" name)
+ (setf (content-length part) value)))))
+ (progn
+ (setf (headers part) (nreverse (headers part)))
+ (return-from read-headers)))))
+ ;; read in the body
+ (if (string= "multipart/mixed" (content-type part))
+ (progn
+ (dolist (nested-part (read-mime source
+ (get-header-attribute (get-header part "Content-Type") "boundary")
+ callback-factory))
+ (push nested-part parts))
+ (setf keep-on (read-until-next-boundary source boundary
+ (lambda (byte)
+ (declare (ignore byte))
+ (error "Bad data in mime stream."))
+ :assume-first-boundary t)))
+ (multiple-value-bind (byte-handler finish-callback abort-callback)
+ (funcall callback-factory part)
+ (declare (type function byte-handler finish-callback)
+ (type (or null function) abort-callback))
+ (let ((ok nil))
+ (unwind-protect
+ (progn
+ (setf keep-on (read-until-next-boundary source boundary byte-handler))
+ (setf ok t))
+ (if ok
+ (push (funcall finish-callback) parts)
+ (when abort-callback
+ (funcall abort-callback))))))))
+ finally (return (nreverse parts))))
+
+(defun read-until-next-boundary (stream boundary data-handler &key assume-first-boundary)
+ "Reads from STREAM up to the next boundary. For every byte of
+data in stream we call DATA-HANDLER passing it the byte. Returns
+T if there's more data to be read, NIL otherwise.
+
+The ASSUME-FIRST-BOUNDARY parameter should T if we're reading the
+first part of a MIME message, where there is no leading CR LF
+sequence."
+ ;; Read until CR|LF|-|-|boundary|-|-|transport-padding|CR|LF
+ ;; States: 0 1 2 3 4 5 6 7 8
+ ;; States 6 and 7 are optional
+ (declare (optimize (speed 3) (safety 0) (debug 0))
+ (type (simple-array (unsigned-byte 8) (*)) boundary)
+ (type (function ((unsigned-byte 8)) t) data-handler))
+ (let* ((queue (make-array 80 :element-type '(unsigned-byte 8)))
+ (queue-pos 0)
+ (boundary-pos 0)
+ (boundary-length (length boundary))
+ (state (if assume-first-boundary 2 0))
+ (more-data t))
+ (declare (type (simple-array (unsigned-byte 8) (80)) queue)
+ (type fixnum queue-pos boundary-pos boundary-length state)
+ (type boolean more-data))
+ (labels ((flush-queue (next-byte)
+ (declare (type (unsigned-byte 8) next-byte))
+ (let ((old-queue-pos queue-pos))
+ (setf boundary-pos 0
+ queue-pos 0
+ more-data t
+ state 0)
+ (funcall data-handler (elt queue 0))
+ (loop :for i :from 1 :below old-queue-pos
+ :do (handle-byte (elt queue i))))
+ (handle-byte next-byte)
+ (values))
+ (enqueue-byte (byte)
+ (declare (type (unsigned-byte 8) byte))
+ (setf (elt queue queue-pos) byte)
+ (incf queue-pos)
+ (values))
+ (handle-byte (byte)
+ (declare (type (unsigned-byte 8) byte))
+ (ecase state
+ (0 (cond ((= byte #.(char-code #\return))
+ (enqueue-byte byte)
+ (incf state))
+ (t
+ (funcall data-handler byte))))
+ (1 (cond ((= byte #.(char-code #\newline))
+ (enqueue-byte byte)
+ (incf state))
+ (t
+ (flush-queue byte))))
+ ((2 3) (cond ((= byte #.(char-code #\-))
+ (enqueue-byte byte)
+ (incf state))
+ (t
+ (flush-queue byte))))
+ (4 (cond ((= boundary-pos boundary-length)
+ (incf state)
+ (handle-byte byte))
+ ((= byte (elt boundary boundary-pos))
+ (enqueue-byte byte)
+ (incf boundary-pos))
+ (t
+ (flush-queue byte))))
+ (5 (cond ((= byte #.(char-code #\-))
+ (enqueue-byte byte)
+ (incf state))
+ ((linear-whitespace-byte? byte)
+ (enqueue-byte byte)
+ (setf state 7))
+ ((= byte #.(char-code #\return))
+ (enqueue-byte byte)
+ (setf state 8))
+ (t
+ (flush-queue byte))))
+ (6 (cond ((= byte #.(char-code #\-))
+ (enqueue-byte byte)
+ (incf state)
+ (setf more-data nil))
+ (t
+ (flush-queue byte))))
+ (7 (cond ((linear-whitespace-byte? byte)
+ (enqueue-byte byte))
+ ((= byte #.(char-code #\return))
+ (enqueue-byte byte)
+ (incf state))
+ (t
+ (flush-queue byte))))
+ (8 (cond ((= byte #.(char-code #\newline))
+ (return-from read-until-next-boundary more-data))
+ (t
+ (flush-queue byte)))))
+ (values)))
+ (loop (handle-byte (read-byte stream))))))
+
+(defun read-next-header (stream)
+ "Reads the next header from STREAM. Returns, as the first
+ value, T if a header was found and NIL otherwise. When a header
+ is found two more values are returned: the header name (a
+ string) and the header value (also a string). Headers are
+ assumed to be encoded in 7bit ASCII.
+
+The returned strings may actually be displaced arrays."
+ ;; another state machine:
+ ;; |header-name|:|whitespace|header-value|CR|LF|
+ ;; 0 1 2 3
+ ;; |CR|LF
+ ;; 0 4
+ ;; If we find a CR LF sequence there's no header.
+ #-allegro (declare (optimize (speed 3) (safety 0) (debug 0)))
+ #+allegro (declare (optimize (speed 3) (debug 0)))
+ (let ((state 0)
+ (byte 0)
+ (header-name (make-array 256 :element-type 'character :adjustable t :fill-pointer 0))
+ (header-value (make-array 256 :element-type 'character :adjustable t :fill-pointer 0)))
+ (declare (type (integer 0 4) state)
+ (type (unsigned-byte 8) byte)
+ (type (array character (*)) header-name header-value))
+ (labels ((extend (array)
+ (vector-push-extend (as-ascii-char byte) array)))
+ (loop
+ (debug-message "READ-NEXT-HEADER State: ~S;~%" state)
+ (setf byte (read-byte stream))
+ (debug-message " Byte: ~D (~C) ==> " byte (code-char byte))
+ (case byte
+ (13 ;; Carriage-Return
+ (ecase state
+ (0 ;; found a CR. no header
+ (setf state 4))
+ (2 ;; end of header-value
+ (setf state 3))))
+ (10 ;; Line-Feed
+ (debug-message "Term.~%")
+ (ecase state
+ (4 ;; all done. no header
+ (return-from read-next-header (values nil nil nil)))
+ (3 ;; all done. found header
+ (return-from read-next-header (values t header-name header-value)))))
+ (58 ;; #\:
+ (ecase state
+ (0 ;; done reading header-name
+ (setf state 1))
+ (2 ;; colon in header-value
+ (extend header-value))))
+ ((32 9) ;; #\Space or #\Tab
+ (ecase state
+ (1 ;; whitespace after colon.
+ nil)
+ (2 ;; whitespace in header-value
+ (extend header-value))))
+ (t
+ (ecase state
+ (0 ;; character in header-name
+ (extend header-name))
+ (1 ;; end of whitespace after colon (there may be no whitespace)
+ (extend header-value)
+ (setf state 2))
+ (2 ;; character in header-value
+ (extend header-value)))))
+ (debug-message "~S;~%" state)))))
+
+(defun parse-key-values (key-value-string)
+ "Returns an alist of the keys and values in KEY-VALUE-STRING.
+
+KEY-VALUE-STRING is of the form: (\w+=\"\w+\";)*"
+ (declare (optimize (speed 3) (safety 0) (debug 0))
+ (type string key-value-string))
+ (flet ((make-adjustable-string (&optional (default-size 20))
+ (make-array default-size
+ :element-type 'character
+ :adjustable t
+ :fill-pointer 0)))
+ (let ((key (make-adjustable-string))
+ (value (make-adjustable-string))
+ (keys-and-values '()))
+ (declare (type (array character (*)) key value))
+ (loop
+ with state = :pre-key
+ for char across key-value-string
+ do (flet ((extend (string) (vector-push-extend char string))
+ (finish-value ()
+ (setf state :pre-key)
+ (push (cons key value) keys-and-values)
+ (setf key (make-adjustable-string)
+ value (make-adjustable-string))))
+ (case char
+ (#\=
+ (ecase state
+ ((:in-double-quote :in-value)
+ (extend value))
+ (:in-key
+ (setf state :in-value))))
+ (#\;
+ (ecase state
+ (:in-double-quote
+ (extend value))
+ ((:in-value :post-value)
+ (finish-value))))
+ (#\"
+ (ecase state
+ (:in-double-quote
+ (setf state :post-value))
+ (:in-value
+ (setf state :in-double-quote))))
+ ((#\Space #\Tab)
+ (ecase state
+ (:in-value
+ (setf state :post-value))
+ ((:pre-key :post-value)
+ nil)
+ (:in-double-quote
+ (extend value))))
+ (t
+ (ecase state
+ ((:in-double-quote :in-value)
+ (extend value))
+ (:pre-key
+ (extend key)
+ (setf state :in-key))
+ (:in-key
+ (extend key))))))
+ finally (unless (string= "" key)
+ (push (cons key value) keys-and-values)))
+ (nreverse keys-and-values))))
+
+;; TODO rewrite using labels
+(defun parse-header-value (header-value-string)
+ "Returns the value in header-value-string and any associated
+ attributes."
+ (declare (optimize (speed 3) (safety 0) (debug 0))
+ (type string header-value-string))
+ (loop
+ with value of-type (array character (*)) = (make-array (length header-value-string)
+ :element-type 'character
+ :adjustable t
+ :fill-pointer 0)
+ with state = :pre-value
+ for offset fixnum upfrom 0
+ for char across header-value-string
+ do (flet ((extend ()
+ (vector-push-extend char value)))
+ (case char
+ ((#\Space #\Tab)
+ (ecase state
+ (:pre-value nil)
+ (:post-value nil)))
+ (#\;
+ ;; done with value.
+ (return-from parse-header-value
+ (values value (parse-key-values (make-array (- (length header-value-string) 1 offset)
+ :element-type (array-element-type header-value-string)
+ :displaced-to header-value-string
+ :displaced-index-offset (1+ offset))))))
+ (t
+ (ecase state
+ (:pre-value
+ (setf state :in-value)
+ (extend))
+ (:in-value
+ (extend))))))
+ ;; if we get here then there's a value but no #\; and no attributes.
+ finally (return-from parse-header-value
+ (values value '()))))
+
+;; Copyright (c) 2003 Janis Dzerins
+;; Modifications for TBNL Copyright (c) 2004 Michael Weber and Dr. Edmund Weitz
+;; Copyright (c) 2005 Edward Marco Baringer
+;;
+;; 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 BY THE AUTHOR ``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 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.
--- /dev/null
+;; -*- lisp -*-
+
+#+xcvb
+(module
+ (:depends-on ("source/packages")))
+
+(in-package :rfc2388-binary)
+
+(declaim (inline linear-whitespace-byte? as-ascii-char))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defparameter *debug* nil
+ "When T we compile the code with some logging statements built in."))
+
+(defmacro debug-message (message &rest message-control)
+ (when *debug*
+ `(format *debug-io* ,message ,@message-control)))
+
+(defun linear-whitespace-byte? (byte)
+ "In short: is it a space or a tab?"
+ (or (= 32 byte)
+ (= 9 byte)))
+
+(defun as-ascii-char (byte)
+ "Assuming BYTE is an ASCII coded character retun the corresponding character."
+ (cond
+ ((eq 32 byte) #\Space)
+ ((eq 9 byte) #\Tab)
+ ((or (> byte 127)
+ (< byte 33))
+ ;; FIXME implement rfc2231. meanwhile we simply get rid of non-ascii characters...
+ (debug-message "Non-ascii chars found in request, filename may be incorrect.~%")
+ #\X)
+ (t
+ ;; here we only have bytes from the ASCII range, so CODE-CHAR does the right thing
+ (code-char byte))))
+
+(defun ascii-string-to-boundary-array (string)
+ (map-into (make-array (length string)
+ :element-type '(unsigned-byte 8)
+ :adjustable nil)
+ (lambda (char)
+ (if (< (char-code char) 128)
+ (char-code char)
+ (error "Bad character ~C in a MIME boundary ~S" char string)))
+ string))
+
+(defun mime-part-headers-to-alist (mime-part content)
+ (list content
+ (append
+ (when (content-length mime-part)
+ (list (cons "Content-Length" (content-length mime-part))))
+ (when (content-type mime-part)
+ (list (cons "Content-Type"
+ (if (content-charset mime-part)
+ (format nil "~A; charset=\"~A\""
+ (content-type mime-part)
+ (content-charset mime-part))
+ (content-type mime-part)))))
+ (headers mime-part))))
+
+(defun make-mime-file-writer (file-name &key (byte-encoder #'code-char))
+ (lambda (partial-mime-part)
+ (let ((file (open file-name :direction :output :element-type 'character)))
+ (setf (content partial-mime-part) file-name)
+ (values
+ (lambda (byte)
+ (write-byte (funcall byte-encoder byte) file))
+ (lambda ()
+ (mime-part-headers-to-alist partial-mime-part file-name))
+ (lambda ()
+ (close file)
+ (delete-file file-name))))))
+
+(defun make-mime-buffer-writer (&key (byte-encoder #'code-char))
+ (lambda (partial-mime-part)
+ (setf (content partial-mime-part)
+ (make-array (or (content-length partial-mime-part)
+ 100)
+ :element-type 'character
+ :adjustable t
+ :fill-pointer 0))
+ (values
+ (lambda (byte)
+ (vector-push-extend (funcall byte-encoder byte)
+ (content partial-mime-part)))
+ (lambda ()
+ (mime-part-headers-to-alist partial-mime-part
+ (content partial-mime-part))))))
+
+;; Copyright (c) 2003 Janis Dzerins
+;; Modifications for TBNL Copyright (c) 2004 Michael Weber and Dr. Edmund Weitz
+;; Copyright (c) 2005 Edward Marco Baringer
+;;
+;; 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 BY THE AUTHOR ``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 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.
--- /dev/null
+foo: bar\r
+\r
--- /dev/null
+\r
+--12345678\r
--- /dev/null
+abc\r
+--123456\r
+--12345678\r
--- /dev/null
+abc\r
+--123456\r
+--12345678-- \r
--- /dev/null
+\r
+--12345678--\r
--- /dev/null
+hello, world!\r
+--12345678\r
--- /dev/null
+\r
+--12345678\r
+\r
+hello, world!\r
+--12345678--\r
--- /dev/null
+----AaB03x\r
+Content-Disposition: form-data; name="submit-name"\r
+\r
+Larry\r
+----AaB03x\r
+Content-Disposition: form-data; name="files"; filename="file1.txt"\r
+Content-Type: text/plain\r
+\r
+file1.txt\r
+----AaB03x--\r
--- /dev/null
+--AaB03x\r
+Content-Disposition: form-data; name="files"\r
+Content-Type: multipart/mixed; boundary=BbC04y\r
+\r
+--BbC04y\r
+Content-Disposition: file; filename="file1.txt"\r
+Content-Type: text/plain\r
+\r
+file1.txt\r
+--BbC04y\r
+Content-Disposition: file; filename="file2.gif"\r
+Content-Type: image/gif\r
+Content-Transfer-Encoding: binary\r
+\r
+file2.gif\r
+--BbC04y--\r
+--AaB03x\r
+Content-Disposition: form-data; name="submit-name"\r
+\r
+Larry\r
+--AaB03x--\r
--- /dev/null
+--AaB03x\r
+Content-Disposition: form-data; name="files"\r
+\r
+----AaB03\r
+--AaB03x--\r
--- /dev/null
+;; -*- lisp -*-
+
+(in-package :cl-user)
+
+(defpackage :rfc2388-binary/test
+ (:use :common-lisp
+ :5am
+ :rfc2388-binary
+ :arnesi))
+
+;; Copyright (c) 2003 Janis Dzerins
+;; Copyright (c) 2005 Edward Marco Baringer
+;;
+;; 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 BY THE AUTHOR ``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 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.
--- /dev/null
+;; -*- lisp -*-
+
+(in-package :rfc2388-binary/test)
+
+(def-suite :rfc2388-binary)
+
+(in-suite :rfc2388-binary)
+
+(defparameter *test-data-dir*
+ (asdf:system-relative-pathname :rfc2388-binary/test "test/data/"))
+
+(defun data-file (filename)
+ (merge-pathnames filename *test-data-dir*))
+
+(test parse-key-values
+ (macrolet ((test-key-values (bind string &body body)
+ `(destructuring-bind ,bind
+ (rfc2388-binary::parse-key-values ,string)
+ ,@body)))
+ (test-key-values ((foo . bar)) "foo=bar"
+ (is (string= "foo" foo))
+ (is (string= "bar" bar)))
+
+ (test-key-values ((one . two) (three . four))
+ "one=two;three=four"
+ (is (string= "one" one))
+ (is (string= "two" two))
+ (is (string= "three" three))
+ (is (string= "four" four)))
+
+ (test-key-values ((k1 . v1) (k2 . v2) (k3 . v3) (k4 . v4))
+ "1=\"2\";1=2 ;1=2 ; 1=2"
+ (is-true (every (lambda (key)
+ (string= "1" key))
+ (list k1 k2 k3 k4)))
+ (is-true (every (lambda (value)
+ (string= "2" value))
+ (list v1 v2 v3 v4))))))
+
+(test parse-header-value
+ (multiple-value-bind (form-data attributes)
+ (rfc2388-binary::parse-header-value "form-data")
+ (is (string= "form-data" form-data))
+ (is (null attributes)))
+ (multiple-value-bind (form-data attributes)
+ (rfc2388-binary::parse-header-value "form-data;")
+ (is (string= "form-data" form-data))
+ (is (null attributes)))
+ (multiple-value-bind (form-data attributes)
+ (rfc2388-binary::parse-header-value "form-data; a=b")
+ (is (string= "form-data" form-data))
+ (is (string= "a" (caar attributes)))
+ (is (string= "b" (cdar attributes))))
+ (multiple-value-bind (form-data attributes)
+ (rfc2388-binary::parse-header-value "form-data; a=b ; c=\"d\"")
+ (is (string= "form-data" form-data))
+ (destructuring-bind ((a . b) (c . d))
+ attributes
+ (is (string= "a" a))
+ (is (string= "b" b))
+ (is (string= "c" c))
+ (is (string= "d" d)))))
+
+(test as-ascii-char
+ (is (char= #\Space (rfc2388-binary::as-ascii-char 32)))
+ (is (char= #\Tab (rfc2388-binary::as-ascii-char 9)))
+ (is (char= #\! (rfc2388-binary::as-ascii-char 33)))
+ (is (char= #\: (rfc2388-binary::as-ascii-char 58)))
+ (is (char= #\a (rfc2388-binary::as-ascii-char 97)))
+ (is (char= #\A (rfc2388-binary::as-ascii-char 65))))
+
+(test empty-data
+ (with-input-from-file (mime (data-file "mime1") :element-type '(unsigned-byte 8))
+ (is-true
+ (rfc2388-binary::read-until-next-boundary mime
+ (rfc2388-binary::ascii-string-to-boundary-array "12345678")
+ (lambda (byte)
+ (declare (ignore byte))
+ (fail)))))
+ (with-input-from-file (mime (data-file "mime2") :element-type '(unsigned-byte 8))
+ (is-false
+ (rfc2388-binary::read-until-next-boundary mime
+ (rfc2388-binary::ascii-string-to-boundary-array "12345678")
+ (lambda (byte)
+ (fail "Read char byte ~D (~C), why?" byte (code-char byte)))))))
+
+(test hello-world
+ (with-output-to-string (hello-world)
+ (with-input-from-file (mime (data-file "mime3") :element-type '(unsigned-byte 8))
+ (is-true
+ (rfc2388-binary::read-until-next-boundary mime
+ (rfc2388-binary::ascii-string-to-boundary-array "12345678")
+ (lambda (byte)
+ (write-char (code-char byte) hello-world))))
+ (is (string= "hello, world!" (get-output-stream-string hello-world)))))
+ (with-output-to-string (hello-world)
+ (with-input-from-file (mime (data-file "mime4") :element-type '(unsigned-byte 8))
+ (is-true
+ (rfc2388-binary::read-until-next-boundary mime
+ (rfc2388-binary::ascii-string-to-boundary-array "12345678")
+ (lambda (byte)
+ (declare (ignore byte))
+ (fail))))
+ (is-false
+ (rfc2388-binary::read-until-next-boundary mime
+ (rfc2388-binary::ascii-string-to-boundary-array "12345678")
+ (lambda (byte)
+ (write-char (code-char byte) hello-world))))
+ (is (string= "\r
+hello, world!" (get-output-stream-string hello-world))))))
+
+(test parse-header
+ (with-input-from-file (header (data-file "header1")
+ :element-type '(unsigned-byte 8))
+ (multiple-value-bind (found-header header-name header-value)
+ (rfc2388-binary::read-next-header header)
+ (is-true found-header)
+ (is (string= "foo" header-name))
+ (is (string= "bar" header-value)))
+ (is-false (rfc2388-binary::read-next-header header))))
+
+(defun simple-test-callback (partial-mime-part)
+ (setf (content partial-mime-part)
+ (make-array 10
+ :element-type '(unsigned-byte 8)
+ :adjustable t
+ :fill-pointer 0))
+ (values
+ (lambda (byte)
+ (vector-push-extend byte (content partial-mime-part)))
+ (lambda (mime-part)
+ mime-part)))
+
+(defun string-to-vector (string)
+ (map 'vector #'char-code string))
+
+(test read-mime
+ (with-input-from-file (mime (data-file "mime5") :element-type '(unsigned-byte 8))
+ (read-mime mime "--AaB03x" #'simple-test-callback)
+ (pass))
+ (with-input-from-file (mime (data-file "mime5") :element-type '(unsigned-byte 8))
+ (let ((parts (read-mime mime "--AaB03x" #'simple-test-callback)))
+ (let ((larry (first parts)))
+ (is (equalp (content larry) (string-to-vector "Larry"))))
+ (let ((file1 (second parts)))
+ (is (equalp (content file1) (string-to-vector "file1.txt")))
+ (is (string= "text/plain" (content-type (second parts)))))
+ (is (= 2 (length parts))))))
+
+(defun test-read-until-boundary (file)
+ (let ((more-data nil))
+ (values
+ (with-output-to-string (out)
+ (with-input-from-file (mime (data-file file) :element-type '(unsigned-byte 8))
+ (setf more-data
+ (rfc2388::read-until-next-boundary mime (rfc2388::ascii-string-to-boundary-array "12345678")
+ (lambda (byte) (write-char (code-char byte) out))))))
+ more-data)))
+
+(test read-until-next-boundary
+ (multiple-value-bind (content more-data) (test-read-until-boundary "mime10")
+ (if (and (string= content (format nil "abc~A~A--123456" #\return #\newline))
+ more-data)
+ (pass)
+ (fail))))
+
+(test read-until-next-boundary2
+ (multiple-value-bind (content more-data) (test-read-until-boundary "mime11")
+ (if (and (string= content (format nil "abc~A~A--123456" #\return #\newline))
+ (not more-data))
+ (pass)
+ (fail))))
+
+(test read-mime-multipart
+ (with-input-from-file (mime (data-file "mime6") :element-type '(unsigned-byte 8))
+ (read-mime mime "AaB03x" #'simple-test-callback)
+ (pass))
+ (with-input-from-file (mime (data-file "mime6") :element-type '(unsigned-byte 8))
+ (let ((parts (read-mime mime "AaB03x" #'simple-test-callback)))
+ (is (= 3 (length parts)))
+ (destructuring-bind (file1 file2 larry)
+ parts
+ (is (equalp (content larry) (string-to-vector "Larry")))
+ (is (string= "form-data" (header-value (get-header larry "Content-Disposition"))))
+ (is (equalp (content file1) (string-to-vector "file1.txt")))
+ (is (equalp (content file2) (string-to-vector "file2.gif")))))))
+
+(test read-mime-multipart2
+ (with-input-from-file (mime (data-file "mime7") :element-type '(unsigned-byte 8))
+ (let ((parts (read-mime mime "AaB03x" #'simple-test-callback)))
+ (is (= 1 (length parts)))
+ (destructuring-bind (files)
+ parts
+ (is (string= "form-data" (header-value (get-header files "Content-Disposition"))))
+ (is (equalp (content files) (string-to-vector "----AaB03")))))))
+
+(test read-binary
+ (with-input-from-file (mime (data-file "mime8") :element-type '(unsigned-byte 8))
+ (let ((parts (read-mime mime "----------hUrrH2HCA6fHrlQsvCv5qD" #'simple-test-callback)))
+ (is (= 4 (length parts)))
+ (destructuring-bind (s f a file) parts
+ (is (equalp (string-to-vector "wTWkJQflmGAAAtiuGQjZfdliukKmDMrVxzXziwGq") (content s)))
+ (is (equalp (string-to-vector "NkPeoCRHHdAUgcTAWYkw") (content f)))
+ (is (equalp (string-to-vector "xovkAWwneq") (content a))) ; Won't do harm, might be useful.
+ (is (string= "form-data" (header-value (get-header file "Content-Disposition"))))
+ (is (string= "application/x-macbinary" (header-value (get-header file "Content-Type"))))
+ (is (equalp (content file)
+ (make-array 512 :element-type '(unsigned-byte 8)
+ :initial-contents (nconc (loop for x from 0 to 255 collecting x)
+ (loop for x from 255 downto 0 collecting x)))))))))
+
+(test random-junk
+ (for-all ((random-byte-buffer (gen-buffer :length (gen-integer :min (expt 2 0) :max (expt 2 4))
+ :elements (gen-one-element
+ (char-code #\-)
+ 10
+ 13
+ (char-code #\Space)))
+ (not (search "----------hUrrH2HCA6fHrlQsvCv5qD"
+ random-byte-buffer))))
+ (with-output-to-file (mime (data-file "mime9")
+ :element-type '(unsigned-byte 8)
+ :if-exists :supersede)
+ (flet ((%line (data)
+ (write-sequence (string-to-vector data) mime)
+ (write-byte 13 mime)
+ (write-byte 10 mime)))
+ (%line "------------hUrrH2HCA6fHrlQsvCv5qD")
+ (%line "Content-Disposition: form-data; name=\"IujzYaQDEj\"; filename=\"foo.bin\"") ;
+ (%line "Content-Type: application/octet-stream")
+ (%line "")
+ (write-sequence random-byte-buffer mime)
+ (write-byte 13 mime)
+ (write-byte 10 mime)
+ (%line "------------hUrrH2HCA6fHrlQsvCv5qD--")))
+ (with-input-from-file (mime (data-file "mime9") :element-type '(unsigned-byte 8))
+ (let ((parts (read-mime mime "----------hUrrH2HCA6fHrlQsvCv5qD" #'simple-test-callback)))
+ (is (= 1 (length parts)))
+ (destructuring-bind (file) parts
+ (is (= (length random-byte-buffer) (length (content file)))
+ "Wrote ~D bytes, got ~D back." (length random-byte-buffer) (length (content file)))
+ (loop
+ for index upfrom 0 below (min (length random-byte-buffer)
+ (length (content file)))
+ do (when (/= (aref random-byte-buffer index)
+ (aref (content file) index))
+ (fail
+ "Bytes at offset ~D differ (length: ~D; on-disk: ~D; returned: ~D)"
+ index
+ (length random-byte-buffer)
+ (aref random-byte-buffer index)
+ (aref (content file) index))))
+ (is (string= "form-data" (header-value (get-header file "Content-Disposition"))))
+ (is (string= "application/octet-stream" (header-value (get-header file "Content-Type")))))))))
+
+;; Copyright (c) 2003 Janis Dzerins
+;; Copyright (c) 2005 Edward Marco Baringer
+;;
+;; 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 BY THE AUTHOR ``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 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.
--- /dev/null
+SPLIT-SEQUENCE
+==============
+
+[SPLIT-SEQUENCE](http://cliki.net/split-sequence) is a member of the
+[Common Lisp Utilities](http://cliki.net/Common%20Lisp%20Utilities)
+family of programs, designed by community consensus.
+
+
+_Function_ __SPLIT-SEQUENCE, SPLIT-SEQUENCE-IF, SPLIT-SEQUENCE-IF-NOT__
+
+
+__Syntax:__
+
+__split-sequence__ _delimiter sequence `&key` count
+remove-empty-subseqs from-end start end test test-not key ⇒ list,
+index_
+
+__split-sequence-if__ _predicate sequence `&key` count
+remove-empty-subseqs from-end start end key ⇒ list, index_
+
+__split-sequence-if-not__ _predicate sequence `&key` count
+remove-empty-subseqs from-end start end key ⇒ list, index_
+
+
+__Arguments and Values:__
+
+_delimiter_—an _object_.
+
+_predicate_—a designator for a _function_ of one _argument_ that
+returns a _generalized boolean_.
+
+_sequence_—a _proper sequence_.
+
+_count_—an _integer_ or __nil__. The default is __nil__.
+
+_remove-empty-subseqs_—a _generalized boolean_. The default is
+_false_.
+
+_from-end_—a _generalized boolean_. The default is _false_.
+
+_start, end_—_bounding index designators_ of _sequence_. The
+defaults for _start_ and _end_ are __0__ and __nil__, respectively.
+
+_test_—a _designator_ for a _function_ of two _arguments_ that
+returns a _generalized boolean_.
+
+_test-not_—a _designator_ for a _function_ of two _arguments_
+that returns a _generalized boolean_.
+
+_key_—a _designator_ for a _function_ of one _argument_, or
+__nil__.
+
+_list_—a _proper sequence_.
+
+_index_—an _integer_ greater than or equal to zero, and less
+than or equal to the _length_ of the _sequence_.
+
+
+__Description:__
+
+Splits _sequence_ into a list of subsequences delimited by objects
+_satisfying the test_.
+
+_List_ is a list of sequences of the same kind as _sequence_ that has
+elements consisting of subsequences of _sequence_ that were delimited
+in the argument by elements _satisfying the test_. Index is an index
+into _sequence_ indicating the unprocessed region, suitable as an
+argument to
+[subseq](http://www.lispworks.com/documentation/HyperSpec/Body/f_subseq.htm)
+to continue processing in the same manner if desired.
+
+The _count_ argument, if supplied, limits the number of subsequences
+in the first return value; if more than _count_ delimited subsequences
+exist in _sequence_, the _count_ leftmost delimited subsequences will
+be in order in the first return value, and the second return value
+will be the index into _sequence_ at which processing stopped.
+
+If _from-end_ is non-null, _sequence_ is conceptually processed from
+right to left, accumulating the subsequences in reverse order;
+_from-end_ only makes a difference in the case of a non-null _count_
+argument. In the presence of _from-end_, the _count_ rightmost
+delimited subsequences will be in the order that they are in
+_sequence_ in the first return value, and the second is the index
+indicating the end of the unprocessed region.
+
+The _start_ and _end_ keyword arguments permit a certain subsequence
+of the _sequence_ to be processed without the need for a copying
+stage; their use is conceptually equivalent to partitioning the
+subsequence delimited by _start_ and _end_, only without the need for
+copying.
+
+If _remove-empty-subseqs_ is null (the default), then empty
+subsequences will be included in the result.
+
+In all cases, the subsequences in the first return value will be in
+the order that they appeared in _sequence_.
+
+
+__Examples:__
+
+<pre>
+SPLIT-SEQUENCE> (split-sequence #\Space "A stitch in time saves nine.")
+⇒ ("A" "stitch" "in" "time" "saves" "nine.")
+⇒ 28
+
+SPLIT-SEQUENCE> (split-sequence #\, "foo,bar ,baz, foobar , barbaz,")
+⇒ ("foo" "bar " "baz" " foobar " " barbaz" "")
+⇒ 30
+</pre>
--- /dev/null
+;;; -*- Lisp -*-
+
+(defsystem :split-sequence
+ :author "Arthur Lemmens <alemmens@xs4all.nl>"
+ :maintainer "Sharp Lispers <sharplispers@googlegroups.com>"
+ :description "Splits a sequence into a list of subsequences
+ delimited by objects satisfying a test."
+ :license "public domain"
+ :version (:read-file-form "version.sexp")
+ :components ((:static-file "version.sexp")
+ (:file "split-sequence"))
+ :in-order-to ((asdf:test-op (asdf:load-op :split-sequence-tests)))
+ :perform (asdf:test-op :after (op c)
+ (funcall (intern (symbol-name '#:run!) '#:5am) :split-sequence)))
+
+(defsystem :split-sequence-tests
+ :author "Arthur Lemmens <alemmens@xs4all.nl>"
+ :maintainer "Sharp Lispers <sharplispers@googlegroups.com>"
+ :description "Split-Sequence test suite"
+ :license "public domain"
+ :depends-on (:split-sequence :fiveam)
+ :components ((:file "tests")))
--- /dev/null
+;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
+;;;
+;;; SPLIT-SEQUENCE
+;;;
+;;; This code was based on Arthur Lemmens' in
+;;; <URL:http://groups.google.com/groups?as_umsgid=39F36F1A.B8F19D20%40simplex.nl>;
+;;;
+;;; changes include:
+;;;
+;;; * altering the behaviour of the :from-end keyword argument to
+;;; return the subsequences in original order, for consistency with
+;;; CL:REMOVE, CL:SUBSTITUTE et al. (:from-end being non-NIL only
+;;; affects the answer if :count is less than the number of
+;;; subsequences, by analogy with the above-referenced functions).
+;;;
+;;; * changing the :maximum keyword argument to :count, by analogy
+;;; with CL:REMOVE, CL:SUBSTITUTE, and so on.
+;;;
+;;; * naming the function SPLIT-SEQUENCE rather than PARTITION rather
+;;; than SPLIT.
+;;;
+;;; * adding SPLIT-SEQUENCE-IF and SPLIT-SEQUENCE-IF-NOT.
+;;;
+;;; * The second return value is now an index rather than a copy of a
+;;; portion of the sequence; this index is the `right' one to feed to
+;;; CL:SUBSEQ for continued processing.
+
+;;; There's a certain amount of code duplication here, which is kept
+;;; to illustrate the relationship between the SPLIT-SEQUENCE
+;;; functions and the CL:POSITION functions.
+
+(defpackage :split-sequence
+ (:use :common-lisp)
+ (:export #:split-sequence
+ #:split-sequence-if
+ #:split-sequence-if-not))
+
+(in-package :split-sequence)
+
+(deftype array-index (&optional (length array-dimension-limit))
+ `(integer 0 (,length)))
+
+(declaim (ftype (function (&rest t) (values list integer))
+ split-sequence split-sequence-if split-sequence-if-not))
+
+(declaim (ftype (function (function sequence array-index
+ (or null array-index) (or null array-index) boolean)
+ (values list integer))
+ split-from-start split-from-end))
+
+(macrolet ((check-bounds (sequence start end)
+ (let ((length (gensym (string '#:length))))
+ `(let ((,length (length ,sequence)))
+ (check-type ,start unsigned-byte "a non-negative integer")
+ (when ,end (check-type ,end unsigned-byte "a non-negative integer or NIL"))
+ (unless ,end
+ (setf ,end ,length))
+ (unless (<= ,start ,end ,length)
+ (error "Wrong sequence bounds. start: ~S end: ~S" ,start ,end))))))
+
+ (defun split-sequence (delimiter sequence &key (start 0) (end nil) (from-end nil)
+ (count nil) (remove-empty-subseqs nil)
+ (test #'eql) (test-not nil) (key #'identity))
+ "Return a list of subsequences in seq delimited by delimiter.
+
+If :remove-empty-subseqs is NIL, empty subsequences will be included
+in the result; otherwise they will be discarded. All other keywords
+work analogously to those for CL:SUBSTITUTE. In particular, the
+behaviour of :from-end is possibly different from other versions of
+this function; :from-end values of NIL and T are equivalent unless
+:count is supplied. The second return value is an index suitable as an
+argument to CL:SUBSEQ into the sequence indicating where processing
+stopped."
+ (check-bounds sequence start end)
+ (cond
+ ((and (not from-end) (null test-not))
+ (split-from-start (lambda (sequence start)
+ (position delimiter sequence :start start :key key :test test))
+ sequence start end count remove-empty-subseqs))
+ ((and (not from-end) test-not)
+ (split-from-start (lambda (sequence start)
+ (position delimiter sequence :start start :key key :test-not test-not))
+ sequence start end count remove-empty-subseqs))
+ ((and from-end (null test-not))
+ (split-from-end (lambda (sequence end)
+ (position delimiter sequence :end end :from-end t :key key :test test))
+ sequence start end count remove-empty-subseqs))
+ (t
+ (split-from-end (lambda (sequence end)
+ (position delimiter sequence :end end :from-end t :key key :test-not test-not))
+ sequence start end count remove-empty-subseqs))))
+
+ (defun split-sequence-if (predicate sequence &key (start 0) (end nil) (from-end nil)
+ (count nil) (remove-empty-subseqs nil) (key #'identity))
+ "Return a list of subsequences in seq delimited by items satisfying
+predicate.
+
+If :remove-empty-subseqs is NIL, empty subsequences will be included
+in the result; otherwise they will be discarded. All other keywords
+work analogously to those for CL:SUBSTITUTE-IF. In particular, the
+behaviour of :from-end is possibly different from other versions of
+this function; :from-end values of NIL and T are equivalent unless
+:count is supplied. The second return value is an index suitable as an
+argument to CL:SUBSEQ into the sequence indicating where processing
+stopped."
+ (check-bounds sequence start end)
+ (if from-end
+ (split-from-end (lambda (sequence end)
+ (position-if predicate sequence :end end :from-end t :key key))
+ sequence start end count remove-empty-subseqs)
+ (split-from-start (lambda (sequence start)
+ (position-if predicate sequence :start start :key key))
+ sequence start end count remove-empty-subseqs)))
+
+ (defun split-sequence-if-not (predicate sequence &key (count nil) (remove-empty-subseqs nil)
+ (from-end nil) (start 0) (end nil) (key #'identity))
+ "Return a list of subsequences in seq delimited by items satisfying
+\(CL:COMPLEMENT predicate).
+
+If :remove-empty-subseqs is NIL, empty subsequences will be included
+in the result; otherwise they will be discarded. All other keywords
+work analogously to those for CL:SUBSTITUTE-IF-NOT. In particular,
+the behaviour of :from-end is possibly different from other versions
+of this function; :from-end values of NIL and T are equivalent unless
+:count is supplied. The second return value is an index suitable as an
+argument to CL:SUBSEQ into the sequence indicating where processing
+stopped."
+ (check-bounds sequence start end)
+ (if from-end
+ (split-from-end (lambda (sequence end)
+ (position-if-not predicate sequence :end end :from-end t :key key))
+ sequence start end count remove-empty-subseqs)
+ (split-from-start (lambda (sequence start)
+ (position-if-not predicate sequence :start start :key key))
+ sequence start end count remove-empty-subseqs))))
+
+(defun split-from-end (position-fn sequence start end count remove-empty-subseqs)
+ (declare (optimize (speed 3) (debug 0)))
+ (loop
+ :for right := end :then left
+ :for left := (max (or (funcall position-fn sequence right) -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 sequence (1+ left) right) into subseqs
+ :and :sum 1 :into nr-elts
+ :until (< left start)
+ :finally (return (values (nreverse subseqs) (1+ left)))))
+
+(defun split-from-start (position-fn sequence start end count remove-empty-subseqs)
+ (declare (optimize (speed 3) (debug 0)))
+ (let ((length (length sequence)))
+ (loop
+ :for left := start :then (+ right 1)
+ :for right := (min (or (funcall position-fn sequence left) length)
+ 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 sequence left right) :into subseqs
+ :and :sum 1 :into nr-elts
+ :until (>= right end)
+ :finally (return (values subseqs right)))))
+
+(pushnew :split-sequence *features*)
--- /dev/null
+;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
+
+(defpackage :split-sequence-tests
+ (:use :common-lisp :split-sequence :fiveam))
+
+(in-package :split-sequence-tests)
+
+(in-suite* :split-sequence)
+
+;;;; SPLIT-SEQUENCE
+
+(test (split-sequence.1 :compile-at :definition-time)
+ (is (equalp (split-sequence #\; "a;;b;c")
+ (values '("a" "" "b" "c") 6))))
+
+(test (split-sequence.2 :compile-at :definition-time)
+ (is (equalp (split-sequence #\; "a;;b;c" :from-end t)
+ (values '("a" "" "b" "c") 0))))
+
+(test (split-sequence.3 :compile-at :definition-time)
+ (is (equalp (split-sequence #\; "a;;b;c" :from-end t :count 1)
+ (values '("c") 4))))
+
+(test (split-sequence.4 :compile-at :definition-time)
+ (is (equalp (split-sequence #\; "a;;b;c" :remove-empty-subseqs t)
+ (values '("a" "b" "c") 6))))
+
+(test (split-sequence.5 :compile-at :definition-time)
+ (is (equalp (split-sequence #\; ";oo;bar;ba;" :start 1 :end 9)
+ (values '("oo" "bar" "b") 9))))
+
+(test (split-sequence-if.1 :compile-at :definition-time)
+ (is (equalp (split-sequence-if (lambda (x) (member x '(#\a #\b))) "abracadabra")
+ (values '("" "" "r" "c" "d" "" "r" "") 11))))
+
+(test (split-sequence-if-not.1 :compile-at :definition-time)
+ (is (equalp (split-sequence-if-not (lambda (x) (member x '(#\a #\b))) "abracadabra")
+ (values '("ab" "a" "a" "ab" "a") 11))))
--- /dev/null
+;; -*- lisp -*-
+"1.4"
--- /dev/null
+ Copyright (c) 2005 David Lichteblau
+ Copyright (c) 2013 Anton Vodonosov <avodonosov@yandex.ru>
+
+ Permission is hereby granted, free of charge, to any person
+ obtaining a copy of this software and associated documentation files
+ (the "Software"), to deal in the Software without restriction,
+ including without limitation the rights to use, copy, modify, merge,
+ publish, distribute, sublicense, and/or sell copies of the Software,
+ and to permit persons to whom the Software is furnished to do so,
+ subject to the following conditions:
+
+ The above copyright notice and this permission notice shall be
+ included in all copies or substantial portions of the Software.
+
+ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
+ BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
+ ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
+ CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+ SOFTWARE.
--- /dev/null
+.PHONY: clean
+clean:
+ rm -f *.fasl *.x86f *.fas *.ufsl *.lib *.pfsl
--- /dev/null
+trivial-gray-streams
+====================
+
+Gray streams is an interface proposed for inclusion with ANSI CL
+by David N. Gray in Issue STREAM-DEFINITION-BY-USER
+(http://www.nhplace.com/kent/CL/Issues/stream-definition-by-user.html).
+The proposal did not make it into ANSI CL, but most popular
+CL implementations implement this facility anyway.
+
+This system provides an extremely thin compatibility layer for gray
+streams.
+
+How to use it
+=============
+
+Use the package TRIVIAL-GRAY-STREAMS to refer Gray stream
+classes to inherit from, generic functions to implement.
+
+Extensions
+==========
+
+The Gray proposal was made before the ANCI CL standard was finalized,
+and was based on the Common Lisp The Language book.
+
+The book does not have cl:file-position, cl:read-sequence, cl:write-sequence
+functions. That's why (we think) the Gray proposal does not specify
+their counterparts: stream-file-position, stream-read-sequence, stream-write-sequence.
+
+trivial-gray-streams supports these functions:
+
+Generic function STREAM-READ-SEQUENCE (stream sequence start end &key)
+Generic function STREAM-WRITE-SEQUENCE (stream sequence start end &key)
+
+ Notice that we use two required arguments and allow additional
+ keyword arguments. Your methods on these function should have
+ compliant lambda lists:
+ (stream sequence start end &key)
+
+Generic function STREAM-FILE-POSITION (stream) => file position
+Generic function (SETF STREAM-FILE-POSITION) (position-spec stream) => successp
--- /dev/null
+#+xcvb
+(module
+ (:fullname "trivial-gray-streams"
+ :depends-on
+ ("package"
+ "streams")
+ :supersedes-asdf ("trivial-gray-streams")))
--- /dev/null
+#+xcvb (module ())
+
+(in-package :cl-user)
+
+#+:abcl
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (require :gray-streams))
+
+#+cmu
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (require :gray-streams))
+
+#+allegro
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (unless (fboundp 'excl:stream-write-string)
+ (require "streamc.fasl")))
+
+#+ecl
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (gray::redefine-cl-functions))
+
+(macrolet
+ ((frob ()
+ (let ((gray-class-symbols
+ '(#:fundamental-stream
+ #:fundamental-input-stream #:fundamental-output-stream
+ #:fundamental-character-stream #:fundamental-binary-stream
+ #:fundamental-character-input-stream #:fundamental-character-output-stream
+ #:fundamental-binary-input-stream #:fundamental-binary-output-stream))
+ (gray-function-symbols
+ '(#:stream-read-char
+ #:stream-unread-char #:stream-read-char-no-hang
+ #:stream-peek-char #:stream-listen #:stream-read-line
+ #:stream-clear-input #:stream-write-char #:stream-line-column
+ #:stream-start-line-p #:stream-write-string #:stream-terpri
+ #:stream-fresh-line #:stream-finish-output #:stream-force-output
+ #:stream-clear-output #:stream-advance-to-column
+ #:stream-read-byte #:stream-write-byte)))
+ `(progn
+
+ (defpackage impl-specific-gray
+ (:use :cl)
+ (:import-from
+ #+sbcl :sb-gray
+ #+allegro :excl
+ #+cmu :ext
+ #+(or clisp ecl mocl) :gray
+ #+openmcl :ccl
+ #+lispworks :stream
+ #+abcl :gray-streams
+ #-(or sbcl allegro cmu clisp openmcl lispworks ecl abcl mocl) ...
+ ,@gray-class-symbols
+ ,@gray-function-symbols)
+ (:export
+ ,@gray-class-symbols
+ ,@gray-function-symbols))
+
+ (defpackage :trivial-gray-streams
+ (:use :cl)
+ (:import-from #:impl-specific-gray
+ ;; We import and re-export only
+ ;; function symbols;
+ ;; But we define our own classes
+ ;; mirroring the gray class hierarchy
+ ;; of the lisp implementation (this
+ ;; is necessary to define our methods
+ ;; for particular generic functions)
+ ,@gray-function-symbols)
+ (:export ,@gray-class-symbols
+ ,@gray-function-symbols
+ ;; extension functions
+ #:stream-read-sequence
+ #:stream-write-sequence
+ #:stream-file-position
+ ;; deprecated
+ #:trivial-gray-stream-mixin))))))
+ (frob))
--- /dev/null
+#+xcvb (module (:depends-on ("package")))
+
+(in-package :trivial-gray-streams)
+
+(defclass fundamental-stream (impl-specific-gray:fundamental-stream) ())
+(defclass fundamental-input-stream
+ (fundamental-stream impl-specific-gray:fundamental-input-stream) ())
+(defclass fundamental-output-stream
+ (fundamental-stream impl-specific-gray:fundamental-output-stream) ())
+(defclass fundamental-character-stream
+ (fundamental-stream impl-specific-gray:fundamental-character-stream) ())
+(defclass fundamental-binary-stream
+ (fundamental-stream impl-specific-gray:fundamental-binary-stream) ())
+(defclass fundamental-character-input-stream
+ (fundamental-input-stream fundamental-character-stream
+ impl-specific-gray:fundamental-character-input-stream) ())
+(defclass fundamental-character-output-stream
+ (fundamental-output-stream fundamental-character-stream
+ impl-specific-gray:fundamental-character-output-stream) ())
+(defclass fundamental-binary-input-stream
+ (fundamental-input-stream fundamental-binary-stream
+ impl-specific-gray:fundamental-binary-input-stream) ())
+(defclass fundamental-binary-output-stream
+ (fundamental-output-stream fundamental-binary-stream
+ impl-specific-gray:fundamental-binary-output-stream) ())
+
+(defgeneric stream-read-sequence
+ (stream sequence start end &key &allow-other-keys))
+(defgeneric stream-write-sequence
+ (stream sequence start end &key &allow-other-keys))
+
+(defgeneric stream-file-position (stream))
+(defgeneric (setf stream-file-position) (newval stream))
+
+;;; Default methods for stream-read/write-sequence.
+;;;
+;;; It would be nice to implement default methods
+;;; in trivial gray streams, maybe borrowing the code
+;;; from some of CL implementations. But now, for
+;;; simplicity we will fallback to default implementation
+;;; of the implementation-specific analogue function which calls us.
+
+(defmethod stream-read-sequence ((stream fundamental-input-stream) seq start end &key)
+ (declare (ignore seq start end))
+ 'fallback)
+
+(defmethod stream-write-sequence ((stream fundamental-output-stream) seq start end &key)
+ (declare (ignore seq start end))
+ 'fallback)
+
+(defmacro or-fallback (&body body)
+ `(let ((result ,@body))
+ (if (eq result (quote fallback))
+ (call-next-method)
+ result)))
+
+;; Implementations should provide this default method, I believe, but
+;; at least sbcl and allegro don't.
+(defmethod stream-terpri ((stream fundamental-output-stream))
+ (write-char #\newline stream))
+
+;; stream-file-position could be specialized to
+;; fundamental-stream, but to support backward
+;; compatibility with flexi-streams, we specialize
+;; it on T. The reason: flexi-streams calls stream-file-position
+;; for non-gray stream:
+;; https://github.com/edicl/flexi-streams/issues/4
+(defmethod stream-file-position ((stream t))
+ nil)
+
+(defmethod (setf stream-file-position) (newval (stream t))
+ (declare (ignore newval))
+ nil)
+
+#+abcl
+(progn
+ (defmethod gray-streams:stream-read-sequence
+ ((s fundamental-input-stream) seq &optional start end)
+ (or-fallback (stream-read-sequence s seq (or start 0) (or end (length seq)))))
+
+ (defmethod gray-streams:stream-write-sequence
+ ((s fundamental-output-stream) seq &optional start end)
+ (or-fallback (stream-write-sequence s seq (or start 0) (or end (length seq)))))
+
+ (defmethod gray-streams:stream-write-string
+ ((stream xp::xp-structure) string &optional (start 0) (end (length string)))
+ (xp::write-string+ string stream start end))
+
+ #+#.(cl:if (cl:and (cl:find-package :gray-streams)
+ (cl:find-symbol "STREAM-FILE-POSITION" :gray-streams))
+ '(:and)
+ '(:or))
+ (defmethod gray-streams:stream-file-position
+ ((s fundamental-stream) &optional position)
+ (if position
+ (setf (stream-file-position s) position)
+ (stream-file-position s))))
+
+#+allegro
+(progn
+ (defmethod excl:stream-read-sequence
+ ((s fundamental-input-stream) seq &optional start end)
+ (or-fallback (stream-read-sequence s seq (or start 0) (or end (length seq)))))
+
+ (defmethod excl:stream-write-sequence
+ ((s fundamental-output-stream) seq &optional start end)
+ (or-fallback (stream-write-sequence s seq (or start 0) (or end (length seq)))))
+
+ (defmethod excl::stream-file-position
+ ((stream fundamental-stream) &optional position)
+ (if position
+ (setf (stream-file-position stream) position)
+ (stream-file-position stream))))
+
+;; Untill 2014-08-09 CMUCL did not have stream-file-position:
+;; http://trac.common-lisp.net/cmucl/ticket/100
+#+cmu
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (when (find-symbol (string '#:stream-file-position) '#:ext)
+ (pushnew :cmu-has-stream-file-position *features*)))
+
+#+cmu
+(progn
+ (defmethod ext:stream-read-sequence
+ ((s fundamental-input-stream) seq &optional start end)
+ (or-fallback (stream-read-sequence s seq (or start 0) (or end (length seq)))))
+ (defmethod ext:stream-write-sequence
+ ((s fundamental-output-stream) seq &optional start end)
+ (or-fallback (stream-write-sequence s seq (or start 0) (or end (length seq)))))
+
+ #+cmu-has-stream-file-position
+ (defmethod ext:stream-file-position ((stream fundamental-stream))
+ (stream-file-position stream))
+
+ #+cmu-has-stream-file-position
+ (defmethod (setf ext:stream-file-position) (position (stream fundamental-stream))
+ (setf (stream-file-position stream) position)))
+
+#+lispworks
+(progn
+ (defmethod stream:stream-read-sequence
+ ((s fundamental-input-stream) seq start end)
+ (or-fallback (stream-read-sequence s seq start end)))
+ (defmethod stream:stream-write-sequence
+ ((s fundamental-output-stream) seq start end)
+ (or-fallback (stream-write-sequence s seq start end)))
+
+ (defmethod stream:stream-file-position ((stream fundamental-stream))
+ (stream-file-position stream))
+ (defmethod (setf stream:stream-file-position)
+ (newval (stream fundamental-stream))
+ (setf (stream-file-position stream) newval)))
+
+#+openmcl
+(progn
+ (defmethod ccl:stream-read-vector
+ ((s fundamental-input-stream) seq start end)
+ (or-fallback (stream-read-sequence s seq start end)))
+ (defmethod ccl:stream-write-vector
+ ((s fundamental-output-stream) seq start end)
+ (or-fallback (stream-write-sequence s seq start end)))
+
+ (defmethod ccl:stream-read-list ((s fundamental-input-stream) list count)
+ (or-fallback (stream-read-sequence s list 0 count)))
+ (defmethod ccl:stream-write-list ((s fundamental-output-stream) list count)
+ (or-fallback (stream-write-sequence s list 0 count)))
+
+ (defmethod ccl::stream-position ((stream fundamental-stream) &optional new-position)
+ (if new-position
+ (setf (stream-file-position stream) new-position)
+ (stream-file-position stream))))
+
+;; up to version 2.43 there were no
+;; stream-read-sequence, stream-write-sequence
+;; functions in CLISP
+#+clisp
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (when (find-symbol (string '#:stream-read-sequence) '#:gray)
+ (pushnew :clisp-has-stream-read/write-sequence *features*)))
+
+#+clisp
+(progn
+
+ #+clisp-has-stream-read/write-sequence
+ (defmethod gray:stream-read-sequence
+ (seq (s fundamental-input-stream) &key start end)
+ (or-fallback (stream-read-sequence s seq (or start 0) (or end (length seq)))))
+
+ #+clisp-has-stream-read/write-sequence
+ (defmethod gray:stream-write-sequence
+ (seq (s fundamental-output-stream) &key start end)
+ (or-fallback (stream-write-sequence s seq (or start 0) (or end (length seq)))))
+
+ ;;; for old CLISP
+ (defmethod gray:stream-read-byte-sequence
+ ((s fundamental-input-stream)
+ seq
+ &optional start end no-hang interactive)
+ (when no-hang
+ (error "this stream does not support the NO-HANG argument"))
+ (when interactive
+ (error "this stream does not support the INTERACTIVE argument"))
+ (or-fallback (stream-read-sequence s seq start end)))
+
+ (defmethod gray:stream-write-byte-sequence
+ ((s fundamental-output-stream)
+ seq
+ &optional start end no-hang interactive)
+ (when no-hang
+ (error "this stream does not support the NO-HANG argument"))
+ (when interactive
+ (error "this stream does not support the INTERACTIVE argument"))
+ (or-fallback (stream-write-sequence s seq start end)))
+
+ (defmethod gray:stream-read-char-sequence
+ ((s fundamental-input-stream) seq &optional start end)
+ (or-fallback (stream-read-sequence s seq start end)))
+
+ (defmethod gray:stream-write-char-sequence
+ ((s fundamental-output-stream) seq &optional start end)
+ (or-fallback (stream-write-sequence s seq start end)))
+
+ ;;; end of old CLISP read/write-sequence support
+
+ (defmethod gray:stream-position ((stream fundamental-stream) position)
+ (if position
+ (setf (stream-file-position stream) position)
+ (stream-file-position stream))))
+
+#+sbcl
+(progn
+ (defmethod sb-gray:stream-read-sequence
+ ((s fundamental-input-stream) seq &optional start end)
+ (or-fallback (stream-read-sequence s seq (or start 0) (or end (length seq)))))
+ (defmethod sb-gray:stream-write-sequence
+ ((s fundamental-output-stream) seq &optional start end)
+ (or-fallback (stream-write-sequence s seq (or start 0) (or end (length seq)))))
+ (defmethod sb-gray:stream-file-position
+ ((stream fundamental-stream) &optional position)
+ (if position
+ (setf (stream-file-position stream) position)
+ (stream-file-position stream)))
+ ;; SBCL extension:
+ (defmethod sb-gray:stream-line-length ((stream fundamental-stream))
+ 80))
+
+#+ecl
+(progn
+ (defmethod gray::stream-file-position
+ ((stream fundamental-stream) &optional position)
+ (if position
+ (setf (stream-file-position stream) position)
+ (stream-file-position stream)))
+ (defmethod gray:stream-read-sequence
+ ((s fundamental-input-stream) seq &optional start end)
+ (or-fallback (stream-read-sequence s seq (or start 0) (or end (length seq)))))
+ (defmethod gray:stream-write-sequence
+ ((s fundamental-output-stream) seq &optional start end)
+ (or-fallback (stream-write-sequence s seq (or start 0) (or end (length seq))))))
+
+#+mocl
+(progn
+ (defmethod gray:stream-read-sequence
+ ((s fundamental-input-stream) seq &optional start end)
+ (or-fallback (stream-read-sequence s seq (or start 0) (or end (length seq)))))
+ (defmethod gray:stream-write-sequence
+ ((s fundamental-output-stream) seq &optional start end)
+ (or-fallback (stream-write-sequence s seq (or start 0) (or end (length seq)))))
+ (defmethod gray:stream-file-position
+ ((stream fundamental-stream) &optional position)
+ (if position
+ (setf (stream-file-position stream) position)
+ (stream-file-position stream))))
+
+;; deprecated
+(defclass trivial-gray-stream-mixin () ())
+
--- /dev/null
+(defpackage trivial-gray-streams-test \r
+ (:use :cl #:trivial-gray-streams)\r
+ (:shadow #:method)\r
+ (:export #:run-tests\r
+ #:failed-test-names))\r
+\r
--- /dev/null
+(ql:quickload :trivial-gray-streams)\r
+(ql:quickload :test-grid-agent)\r
+(ql:quickload :cl-fad)\r
+(in-package :cl-user)\r
+\r
+(defparameter *abcl* (make-instance 'lisp-exe:abcl\r
+ :java-exe-path "C:\\Program Files\\Java\\jdk1.6.0_26\\bin\\java"\r
+ :abcl-jar-path "C:\\Users\\anton\\unpacked\\abcl\\abcl-bin-1.1.0\\abcl.jar"))\r
+(defparameter *clisp* (make-instance 'lisp-exe:clisp :exe-path "clisp"))\r
+(defparameter *ccl-1.8-x86* (make-instance 'lisp-exe:ccl\r
+ :exe-path "C:\\Users\\anton\\unpacked\\ccl\\ccl-1.8-windows\\wx86cl.exe"))\r
+(defparameter *ccl-1.8-x86-64* (make-instance 'lisp-exe:ccl\r
+ :exe-path "C:\\Users\\anton\\unpacked\\ccl\\ccl-1.8-windows\\wx86cl64.exe"))\r
+(defparameter *sbcl-1.1.0.45* (make-instance 'lisp-exe:sbcl :exe-path "C:\\Program Files (x86)\\Steel Bank Common Lisp\\1.1.0.45\\run.bat"))\r
+(defparameter *sbcl-win-branch-64* (make-instance 'lisp-exe:sbcl :exe-path "C:\\Program Files\\Steel Bank Common Lisp\\1.1.0.36.mswinmt.1201-284e340\\run.bat"))\r
+(defparameter *sbcl-win-branch-32* (make-instance 'lisp-exe:sbcl :exe-path "C:\\Program Files (x86)\\Steel Bank Common Lisp\\1.1.0.36.mswinmt.1201-284e340\\run.bat"))\r
+(defparameter *ecl-bytecode* (make-instance 'lisp-exe:ecl\r
+ :exe-path "C:\\Users\\anton\\projects\\ecl\\bin\\ecl.exe"\r
+ :compiler :bytecode))\r
+(defparameter *ecl-lisp-to-c* (make-instance 'lisp-exe:ecl\r
+ :exe-path "C:\\Users\\anton\\projects\\ecl\\bin\\ecl.exe"\r
+ :compiler :lisp-to-c))\r
+(defparameter *acl* (make-instance 'lisp-exe:acl :exe-path "C:\\Program Files (x86)\\acl90express\\alisp.exe"))\r
+\r
+(defun run-on-many-lisps (run-description test-run-dir quicklisp-dir lisps)\r
+ (ensure-directories-exist test-run-dir)\r
+ (let ((fasl-root (merge-pathnames "fasl/" test-run-dir)))\r
+ (labels ((log-name (lisp)\r
+ (substitute #\- #\.\r
+ ;; Substitute dots by hypens if our main process is CCL, it \r
+ ;; prepends the > symbol before dots;\r
+ ;; for example: 1.1.0.36.mswinmt.1201-284e340 => 1>.1>.0>.36>.mswinmt.1201-284e340\r
+ ;; When we pass such a pathname to another lisps, they can't handle it.\r
+ (string-downcase (tg-agent::implementation-identifier lisp))))\r
+ (fasl-dir (lisp)\r
+ (merge-pathnames (format nil "~A/" (log-name lisp))\r
+ fasl-root))\r
+ (run (lisp)\r
+ (let* ((lib-result (tg-agent::proc-run-libtest lisp\r
+ :trivial-gray-streams\r
+ run-description\r
+ (merge-pathnames (log-name lisp) test-run-dir)\r
+ quicklisp-dir\r
+ (fasl-dir lisp)))\r
+ (status (getf lib-result :status)))\r
+ (if (listp status)\r
+ (getf status :failed-tests)\r
+ status))))\r
+ (let ((results (mapcar (lambda (lisp)\r
+ (list (tg-agent::implementation-identifier lisp)\r
+ (run lisp)))\r
+ lisps)))\r
+ (tg-utils::write-to-file results (merge-pathnames "resutls.lisp" test-run-dir))\r
+ (cl-fad:delete-directory-and-files fasl-root)\r
+ results))))\r
+\r
+(run-on-many-lisps '(:lib-world "quicklisp 2013-02-17 + trivial-gray-streams.head"\r
+ :contact-email "avodonosov@yandex.ru")\r
+ "C:\\Users\\anton\\projects\\trivial-gray-streams\\test\\"\r
+ (merge-pathnames "quicklisp/" (user-homedir-pathname))\r
+ (list *sbcl-1.1.0.45* *sbcl-win-branch-64* *sbcl-win-branch-32*\r
+ *abcl*\r
+ *clisp*\r
+ *ccl-1.8-x86* *ccl-1.8-x86-64* \r
+ *ecl-bytecode* *ecl-lisp-to-c*\r
+ *acl*))\r
--- /dev/null
+(in-package :trivial-gray-streams-test)\r
+\r
+;;; test framework\r
+\r
+#|\r
+ Used like this:\r
+\r
+ (list (test (add) (assert (= 5 (+ 2 2))))\r
+ (test (mul) (assert (= 4 (* 2 2))))\r
+ (test (subst) (assert (= 3 (- 4 2)))))\r
+\r
+ => ;; list of test results, 2 failed 1 passed\r
+ (#<TEST-RESULT ADD :FAIL The assertion (= 5 (+ 2 2)) failed.>\r
+ #<TEST-RESULT MUL :OK>\r
+ #<TEST-RESULT SUBST :FAIL The assertion (= 3 (- 4 2)) failed.>)\r
+\r
+|#\r
+\r
+(defclass test-result ()\r
+ ((name :type symbol\r
+ :initarg :name\r
+ :initform (error ":name is requierd")\r
+ :accessor name)\r
+ (status :type (or (eql :ok) (eql :fail))\r
+ :initform :ok\r
+ :initarg :status\r
+ :accessor status)\r
+ (cause :type (or null condition)\r
+ :initform nil\r
+ :initarg :cause\r
+ :accessor cause)))\r
+\r
+(defun failed-p (test-result)\r
+ (eq (status test-result) :fail))\r
+\r
+(defmethod print-object ((r test-result) stream)\r
+ (print-unreadable-object (r stream :type t)\r
+ (format stream "~S ~S~@[ ~A~]" (name r) (status r) (cause r))))\r
+\r
+(defparameter *allow-debugger* nil)\r
+\r
+(defun test-impl (name body-fn)\r
+ (flet ((make-result (status &optional cause)\r
+ (make-instance 'test-result :name name :status status :cause cause)))\r
+ (handler-bind ((serious-condition\r
+ (lambda (c)\r
+ (unless *allow-debugger*\r
+ (format t "FAIL: ~A~%" c)\r
+ (let ((result (make-result :fail c)))\r
+ (return-from test-impl result))))))\r
+ (format t "Running test ~S... " name)\r
+ (funcall body-fn)\r
+ (format t "OK~%")\r
+ (make-result :ok))))\r
+\r
+(defmacro test ((name) &body body)\r
+ "If the BODY signals a SERIOUS-CONDITION\r
+this macro returns a failed TEST-RESULT; otherwise\r
+returns a successfull TEST-RESULT."\r
+ `(test-impl (quote ,name) (lambda () ,@body)))\r
--- /dev/null
+(in-package :trivial-gray-streams-test)\r
+\r
+;;; assert-invoked - a tool to check that specified method with parameters has\r
+;;; been invoked during execution of a code body\r
+\r
+(define-condition invoked ()\r
+ ((method :type (or symbol cons) ;; cons is for (setf method)\r
+ :accessor method\r
+ :initarg :method\r
+ :initform (error ":method is required"))\r
+ (args :type list\r
+ :accessor args\r
+ :initarg :args\r
+ :initform nil)))\r
+\r
+(defun assert-invoked-impl (method args body-fn)\r
+ (let ((expected-invocation (cons method args))\r
+ (actual-invocations nil))\r
+ (handler-bind ((invoked (lambda (i)\r
+ (let ((invocation (cons (method i) (args i))))\r
+ (when (equalp invocation expected-invocation)\r
+ (return-from assert-invoked-impl nil))\r
+ (push invocation actual-invocations)))))\r
+ (funcall body-fn))\r
+ (let ((*package* (find-package :keyword))) ; ensures package prefixes are printed\r
+ (error "expected invocation: ~(~S~) actual: ~{~(~S~)~^, ~}"\r
+ expected-invocation (reverse actual-invocations)))))\r
+\r
+(defmacro assert-invoked ((method &rest args) &body body)\r
+ "If during execution of the BODY the specified METHOD with ARGS\r
+hasn't been invoked, signals an ERROR."\r
+ `(assert-invoked-impl (quote ,method) (list ,@args) (lambda () ,@body)))\r
+\r
+(defun invoked (method &rest args)\r
+ (signal 'invoked :method method :args args))\r
+\r
+;;; The tests.\r
+\r
+#|\r
+ We will define a gray stream class, specialise \r
+ the gray generic function methods on it and test that the methods\r
+ are invoked when we call functions from common-lisp package\r
+ on that stream.\r
+\r
+ Some of the gray generic functions are only invoked by default\r
+ methods of other generic functions:\r
+\r
+ cl:format ~t or cl:pprint -> stream-advance-to-column -> stream-line-column\r
+ stream-write-char\r
+ cl:fresh-line -> stream-fresh-line -> stream-start-line-p -> stream-line-column\r
+ stream-terpri\r
+\r
+\r
+ If we define our methods for stream-advance-to-column and stream-fresh-line,\r
+ then stream-start-line-p, stream-terpri, stram-line-column are not invoked.\r
+\r
+ Therefore we define another gray stream class. The first class is used\r
+ for all lower level functions (stream-terpri). The second class\r
+ is used to test methods for higher level functions (stream-fresh-line).\r
+|#\r
+\r
+(defclass test-stream (fundamental-binary-input-stream\r
+ fundamental-binary-output-stream\r
+ fundamental-character-input-stream\r
+ fundamental-character-output-stream)\r
+ ())\r
+\r
+(defclass test-stream2 (test-stream) ())\r
+\r
+(defmethod stream-read-char ((stream test-stream))\r
+ (invoked 'stream-read-char stream))\r
+\r
+(defmethod stream-unread-char ((stream test-stream) char)\r
+ (invoked 'stream-unread-char stream char))\r
+\r
+(defmethod stream-read-char-no-hang ((stream test-stream))\r
+ (invoked 'stream-read-char-no-hang stream))\r
+\r
+(defmethod stream-peek-char ((stream test-stream))\r
+ (invoked 'stream-peek-char stream))\r
+\r
+(defmethod stream-listen ((stream test-stream))\r
+ (invoked 'stream-listen stream))\r
+\r
+(defmethod stream-read-line ((stream test-stream))\r
+ (invoked 'stream-read-line stream))\r
+\r
+(defmethod stream-clear-input ((stream test-stream))\r
+ (invoked 'stream-clear-input stream))\r
+\r
+(defmethod stream-write-char ((stream test-stream) char)\r
+ (invoked 'stream-write-char stream char))\r
+\r
+(defmethod stream-line-column ((stream test-stream))\r
+ (invoked 'stream-line-column stream))\r
+\r
+(defmethod stream-start-line-p ((stream test-stream))\r
+ (invoked 'stream-start-line-p stream))\r
+\r
+(defmethod stream-write-string ((stream test-stream) string &optional start end)\r
+ (invoked 'stream-write-string stream string start end))\r
+\r
+(defmethod stream-terpri ((stream test-stream))\r
+ (invoked 'stream-terpri stream))\r
+\r
+(defmethod stream-fresh-line ((stream test-stream2))\r
+ (invoked 'stream-fresh-line stream))\r
+\r
+(defmethod stream-finish-output ((stream test-stream))\r
+ (invoked 'stream-finish-output stream))\r
+\r
+(defmethod stream-force-output ((stream test-stream))\r
+ (invoked 'stream-force-output stream))\r
+\r
+(defmethod stream-clear-output ((stream test-stream))\r
+ (invoked 'stream-clear-output stream))\r
+\r
+(defmethod stream-advance-to-column ((stream test-stream2) column)\r
+ (invoked 'stream-advance-to-column stream column))\r
+\r
+(defmethod stream-read-byte ((stream test-stream))\r
+ (invoked 'stream-read-byte stream))\r
+\r
+(defmethod stream-write-byte ((stream test-stream) byte)\r
+ (invoked 'stream-write-byte stream byte))\r
+\r
+(defmethod stream-read-sequence ((s test-stream) seq start end &key)\r
+ (invoked 'stream-read-sequence s seq :start start :end end))\r
+\r
+(defmethod stream-write-sequence ((s test-stream) seq start end &key)\r
+ (invoked 'stream-write-sequence s seq :start start :end end))\r
+\r
+(defmethod stream-file-position ((s test-stream))\r
+ (invoked 'stream-file-position s))\r
+\r
+(defmethod (setf stream-file-position) (newval (s test-stream))\r
+ (invoked '(setf stream-file-position) newval s))\r
+\r
+;; Convinience macro, used when we want to name\r
+;; the test case with the same name as of the gray streams method we test.\r
+(defmacro test-invoked ((method &rest args) &body body)\r
+ `(test (,method)\r
+ (assert-invoked (,method ,@args)\r
+ ,@body)))\r
+\r
+(defun run-tests ()\r
+ (let ((s (make-instance 'test-stream))\r
+ (s2 (make-instance 'test-stream2)))\r
+ (list\r
+ (test-invoked (stream-read-char s)\r
+ (read-char s))\r
+ (test-invoked (stream-unread-char s #\a)\r
+ (unread-char #\a s))\r
+ (test-invoked (stream-read-char-no-hang s)\r
+ (read-char-no-hang s))\r
+ (test-invoked (stream-peek-char s)\r
+ (peek-char nil s))\r
+ (test-invoked (stream-listen s)\r
+ (listen s))\r
+ (test-invoked (stream-read-line s)\r
+ (read-line s))\r
+ (test-invoked (stream-clear-input s)\r
+ (clear-input s))\r
+ (test-invoked (stream-write-char s #\b)\r
+ (write-char #\b s))\r
+ (test-invoked (stream-line-column s)\r
+ (format s "~10,t"))\r
+ (test-invoked (stream-start-line-p s)\r
+ (fresh-line s))\r
+ (test-invoked (stream-write-string s "hello" 1 4)\r
+ (write-string "hello" s :start 1 :end 4))\r
+ (test-invoked (stream-terpri s)\r
+ (fresh-line s))\r
+ (test-invoked (stream-fresh-line s2)\r
+ (fresh-line s2))\r
+ (test-invoked (stream-finish-output s)\r
+ (finish-output s))\r
+ (test-invoked (stream-force-output s)\r
+ (force-output s))\r
+ (test-invoked (stream-clear-output s)\r
+ (clear-output s))\r
+ (test-invoked (stream-advance-to-column s2 10)\r
+ (format s2 "~10,t"))\r
+ (test-invoked (stream-read-byte s)\r
+ (read-byte s))\r
+ (test-invoked (stream-write-byte s 1)\r
+ (write-byte 1 s))\r
+ ;;; extensions\r
+ (test-invoked (stream-read-sequence s #(1 2) :start 0 :end 1)\r
+ (read-sequence #(1 2) s :start 0 :end 1))\r
+ (test-invoked (stream-write-sequence s #(1 2) :start 0 :end 1)\r
+ (write-sequence #(1 2) s :start 0 :end 1))\r
+ (test-invoked (stream-file-position s)\r
+ (file-position s))\r
+ (test (setf-stream-file-position)\r
+ (assert-invoked ((setf stream-file-position) 9 s)\r
+ (file-position s 9))))))\r
+\r
+(defun failed-tests (results)\r
+ (remove-if-not #'failed-p results))\r
+\r
+(defun failed-test-names (results)\r
+ (mapcar (lambda (result)\r
+ (string-downcase (name result)))\r
+ (failed-tests results)))\r
+ \r
+#|\r
+(failed-test-names (run-tests))\r
+\r
+(setf *allow-debugger* nil))\r
+\r
+|#
\ No newline at end of file
--- /dev/null
+;;; -*- mode: lisp -*-
+
+(defsystem :trivial-gray-streams-test
+ :version "2.0"
+ :depends-on (:trivial-gray-streams)
+ :pathname #P"test/"
+ :serial t
+ :components ((:file "package")
+ (:file "test-framework")
+ (:file "test")))
--- /dev/null
+;;; -*- mode: lisp -*-
+
+(defsystem :trivial-gray-streams
+ :description "Compatibility layer for Gray Streams (see http://www.cliki.net/Gray%20streams)."
+ :license "MIT"
+ :author "David Lichteblau"
+ :maintainer "Anton Vodonosov <avodonosov@yandex.ru>"
+ :version "2.0"
+ :serial t
+ :components ((:file "package") (:file "streams")))
--- /dev/null
+# Boring file regexps:
+\.hi$
+\.o$
+\.o\.cmd$
+# *.ko files aren't boring by default because they might
+# be Korean translations rather than kernel modules.
+# \.ko$
+\.ko\.cmd$
+\.mod\.c$
+(^|/)\.tmp_versions($|/)
+(^|/)CVS($|/)
+(^|/)RCS($|/)
+~$
+#(^|/)\.[^/]
+(^|/)_darcs($|/)
+\.bak$
+\.BAK$
+\.orig$
+(^|/)vssver\.scc$
+\.swp$
+(^|/)MT($|/)
+(^|/)\{arch\}($|/)
+(^|/).arch-ids($|/)
+(^|/),
+\.class$
+\.prof$
+(^|/)\.DS_Store$
+(^|/)BitKeeper($|/)
+(^|/)ChangeSet($|/)
+(^|/)\.svn($|/)
+\.py[co]$
+\#
+\.cvsignore$
+(^|/)Thumbs\.db$
+(^|/)autom4te\.cache($|/)
+(^|/)scratch($|/)
+(^|/)two words($|/)
+(^|/)test-results($|/)
+\.dribble
--- /dev/null
+# really this is private to my build process
+make/
+common-lisp.net
+.vcs
+GNUmakefile
+init-lisp.lisp
+website/changelog.xml
+
+
+lift.tar.gz
+website/output/
+test-results*/
+lift-local.config
+*.dribble
+*.fasl
--- /dev/null
+Copyright (c) 2006 - 2008 Gary Warren King (gwking@metabang.com)
+
+Permission is hereby granted, free of charge, to any person obtaining a
+copy of this software and associated documentation files (the "Software"),
+to deal in the Software without restriction, including without limitation
+the rights to use, copy, modify, merge, publish, distribute, sublicense,
+and/or sell copies of the Software, and to permit persons to whom the
+Software is furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in
+all copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
+THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+DEALINGS IN THE SOFTWARE.
+
+
+Portions are also under copyright by the following:
+
+;* Author : Alexander Repenning *
+;* Copyright : 2003 (c) AgentSheets Inc. *
+;* http://www.agentsheets.com *
+
+Portions are also under copyright by the following:
+
+;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; KMRCL users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
--- /dev/null
+(in-package #:trivial-shell)
+
+(defun %shell-command (command input)
+ #+unix
+ (with-input (input-stream (or input :none))
+ (let (proc out-string err-string in-string out-stream err-stream in-stream)
+ (setf proc (system:run-program *bourne-compatible-shell* (list "-c" command) :wait nil))
+ (when input-stream
+ (setf in-stream (system:process-input proc))
+ (setf in-string (file-to-string-as-lines input-stream))
+ ;; on all UNIXen the line-ending character is of 1 byte length
+ (write-string in-string in-stream :end (- (length in-string) 1))
+ (close in-stream))
+ (setf out-stream (system:process-output proc))
+ (setf err-stream (system:process-error proc))
+ (setf out-string (file-to-string-as-lines out-stream))
+ (setf err-string (file-to-string-as-lines err-stream))
+ (close out-stream)
+ (close err-stream)
+ (values out-string err-string (system:process-exit-code proc))))
+ #+(not unix)
+ (error 'unsupported-function-error :function 'shell-command))
+
+(defun %os-process-id ()
+ (error 'unsupported-function-error :function 'os-process-id))
+
+(defun %get-env-var (name)
+ (extensions:getenv name))
+
+(defun %exit (code)
+ (extensions:exit :status code))
--- /dev/null
+(in-package #:trivial-shell)
+
+#+(or)
+;; use to find sh
+(defun find-rapper-binary ()
+ (or
+ (excl.osi:find-in-path
+ #+mswindows "rapper.exe"
+ #-mswindows "rapper")
+ (strip-whitespace (smu:shell-command "which rapper"))))
+
+
+(defun %shell-command (command input)
+ (multiple-value-bind (output error status)
+ (excl.osi:command-output
+ command :whole t
+ :input input)
+ (values output error status)))
+
+#+(or)
+(defun %shell-command (command input)
+ (multiple-value-bind (output error status)
+ (excl:run-shell-command
+ command :wait t
+ :input input)
+ (values output error status)))
+
+
+(defun %os-process-id ()
+ (excl.osi:getpid))
+
+(defun %get-env-var (name)
+ (sys:getenv name))
+
+(defun %exit (code)
+ (excl:exit code))
--- /dev/null
+(in-package #:metashell)
+
+(defun %shell-command (command input)
+ (when input
+ (error "This version of trivial-shell does not support the input parameter."))
+ ;; BUG: CLisp doesn't allow output to user-specified stream
+ (values
+ nil
+ nil
+ (ext:run-shell-command command :output :terminal :wait t)))
+
+(defun %os-process-id ()
+ (error 'unsupported-function-error :function 'os-process-id))
+
+(defun %get-env-var (name)
+ (ext:getenv name))
+
+(defun %exit (code)
+ (ext:exit code))
--- /dev/null
+(in-package #:trivial-shell)
+
+(defun %shell-command (command input)
+ (let* ((process (ext:run-program
+ *bourne-compatible-shell*
+ (list "-c" command)
+ :input input :output :stream :error :stream))
+ (output (file-to-string-as-lines (ext::process-output process)))
+ (error (file-to-string-as-lines (ext::process-error process))))
+ (close (ext::process-output process))
+ (close (ext::process-error process))
+
+ (values
+ output
+ error
+ (ext::process-exit-code process))))
+
+(defun %os-process-id ()
+ (error 'unsupported-function-error :function 'os-process-id))
+
+(defun %get-env-var (name)
+ (cdr (assoc (intern (substitute #\_ #\- name)
+ :keyword)
+ ext:*environment-list*)))
+
+(defun %exit (code)
+ (unless (zerop code)
+ (error "CMUCL does not support exit codes."))
+ (ext:quit t))
--- /dev/null
+(in-package #:metashell)
+
+(defparameter *bourne-compatible-shell* "/bin/sh"
+ "The path to a Bourne compatible command shell in
+physical pathname notation.")
+
+(defvar *shell-search-paths* '("/usr/bin/" "/usr/local/bin/"))
--- /dev/null
+(in-package #:trivial-shell)
+
+(defun shell-command (command input)
+ (when input
+ (error "This version of trivial-shell does not support the input parameter."))
+ (ccl:do-shell-script command))
+
+(defun %exit (code)
+ (error 'unsupported-function-error :function 'exit))
--- /dev/null
+(in-package #:trivial-shell)
+
+(defun shell-command (command input)
+ (error 'unsupported-function-error :function 'shell-command))
+
+(defun %os-process-id ()
+ (error 'unsupported-function-error :function 'os-process-id))
+
+(defun %get-env-var (name)
+ (ext:getenv name))
+
+(defun %exit (code)
+ (ext:exit code))
--- /dev/null
+(in-package #:trivial-shell)
+
+(defun %shell-command (command input)
+ (when input
+ (error "This version of trivial-shell does not support the input parameter."))
+ ;; BUG: Lispworks combines output and error streams
+ (let ((output (make-string-output-stream)))
+ (unwind-protect
+ (let ((status
+ (system:call-system-showing-output
+ command
+ :prefix ""
+ :show-cmd nil
+ :output-stream output)))
+ (values (get-output-stream-string output) nil status))
+ (close output))))
+
+(defun %os-process-id ()
+ (error 'unsupported-function-error :function 'os-process-id))
+
+(defun %get-env-var (name)
+ (lw:environment-variable name))
+
+(defun %exit (code)
+ (lw:quit :status code))
--- /dev/null
+(in-package #:trivial-shell)
+
+;; whatever...
+(defmacro with-gensyms (syms &body body)
+ `(let ,(mapcar #'(lambda (s)
+ `(,s (gensym)))
+ syms)
+ ,@body))
+
+(defmacro with-stream-from-specifier ((stream stream-specifier direction
+ &rest args)
+ &body body)
+ (with-gensyms (s close? result)
+ `(let ((,close? t)
+ ,s
+ ,result)
+ (unwind-protect
+ (setf ,result
+ (multiple-value-list
+ (let (,stream)
+ (setf (values ,s ,close?)
+ (make-stream-from-specifier
+ ,stream-specifier ,direction ,@args))
+ (setf ,stream ,s)
+ ,@body)))
+ (when (and ,close? ,s)
+ (let ((it (close-stream-specifier ,s)))
+ (when it
+ (setf (first ,result) it)))))
+ (values-list ,result))))
+
+(defmacro with-input ((var source &rest args) &body body)
+ "Create an input stream from source and bind it to var within the body of the with-input form. The stream will be closed if necessary on exit."
+ `(with-stream-from-specifier (,var ,source :input ,@args)
+ ,@body))
+
+(defmacro with-output ((var destination &rest args) &body body)
+ "Create an output stream from source and bind it to var within the body of the with-output form. The stream will be closed if necessary on exit."
+ `(with-stream-from-specifier (,var ,destination :output ,@args)
+ ,@body))
+
+(defgeneric make-stream-from-specifier (specifier direction &rest args)
+ (:documentation "Create and return a stream from specifier, direction and any other argsuments"))
+
+(defgeneric close-stream-specifier (steam)
+ (:documentation "Close a stream and handle other bookkeeping as appropriate."))
+
+(defmethod make-stream-from-specifier ((stream-specifier stream)
+ (direction symbol) &rest args)
+ (declare (ignore args))
+ (values stream-specifier nil))
+
+(defmethod make-stream-from-specifier ((stream-specifier (eql t))
+ (direction symbol) &rest args)
+ (declare (ignore args))
+ (values *standard-output* nil))
+
+(defmethod make-stream-from-specifier ((stream-specifier (eql nil))
+ (direction symbol) &rest args)
+ (declare (ignore args))
+ (values (make-string-output-stream) t))
+
+(defmethod make-stream-from-specifier ((stream-specifier (eql :none))
+ (direction symbol) &rest args)
+ (declare (ignore args))
+ (values nil nil))
+
+(defmethod make-stream-from-specifier ((stream-specifier pathname)
+ (direction symbol) &rest args)
+ (values (apply #'open stream-specifier :direction direction args)
+ t))
+
+(defmethod make-stream-from-specifier ((stream-specifier string)
+ (direction symbol) &rest args)
+ (let ((start (getf args :start 0))
+ (end (getf args :end)))
+ (values (make-string-input-stream stream-specifier start end) nil)))
+
+(defmethod make-stream-from-specifier ((stream-specifier string)
+ (direction (eql :output)) &rest args)
+ (let ((if-does-not-exist (getf args :if-does-not-exist :create)))
+ (remf args :if-does-not-exist)
+ (values (apply #'open stream-specifier
+ :direction direction :if-does-not-exist if-does-not-exist args)
+ t)))
+
+(defmethod close-stream-specifier (s)
+ (close s)
+ (values nil))
+
+(defmethod close-stream-specifier ((s string-stream))
+ (prog1
+ (values (get-output-stream-string s))
+ (close s)))
--- /dev/null
+;;; -*- Mode: LISP; Syntax: Common-lisp; Package: ccl; Base: 10 -*-
+;******************************************************************
+;* *
+;* PROGRAM E V A L A P P L E S C R I P T *
+;* *
+;******************************************************************
+;* Author : Alexander Repenning *
+;* Copyright : 2003 (c) AgentSheets Inc. *
+;* http://www.agentsheets.com *
+;* Filename : eval-apple-script.lisp *
+;* Last Update : 03/01/05 *
+;* Version *
+;* 1.0 : 11/05/03 *
+;* 1.1 : 02/11/04 finder-file-comment *
+;* 1.1.1 : 03/01/05 export i-chat-.. functions *
+;* HW/SW : G4, OS X 10.3.8, MCL 5 *
+;* Abstract : Run Apple Scripts *
+;* *
+;******************************************************************
+
+(in-package :ccl)
+
+(export '(eval-apple-script i-chat-send-message i-chat-set-status-message
+ *applescript-host* do-shell-script))
+
+(require "appleevent-toolkit")
+
+
+
+(defun EVAL-APPLE-SCRIPT (Script) "
+ in: Script string;
+ out: Result string, Error nil or errorCode;
+ Compile and run an AppleScript."
+ ;; Peter Desain <Desain@nici.kun.nl>
+ (let ((Gscriptingcomponent
+ (#_OpenDefaultComponent #$kOSAComponentType #$kOSAGenericScriptingComponentSubtype)))
+ (with-aedescs (source result err-mess)
+ (%stack-block ((ptr (1+ (length script))))
+ (%put-cstring ptr script)
+ (ae-error (#_aecreatedesc #$typechar ptr (length script) source))
+ (let ((Myoserror
+ (#_OSADoScript gScriptingComponent
+ source
+ #$kOSANullScript
+ #$typeChar
+ (logior #$kOSAModeNull #$kOSAModeDisplayForHumans)
+ result)))
+ (case myOSError
+ (#.#$noErr ;; no error: extract result
+ (values
+ (let ((Datahandle (rref result :aedesc.datahandle)))
+ (with-dereferenced-handles ((ptr1 datahandle))
+ (%str-from-ptr-in-script ptr1 (#_GetHandleSize datahandle))))
+ nil))
+ (t ;; error: return error message
+ (values
+ (progn
+ (#_OSAScriptError gScriptingComponent #$kOSAErrorMessage #$typeChar err-mess)
+ (format nil "AppleScript error: ~A, code: ~A"
+ (let ((Datahandle (rref err-mess :aedesc.datahandle)))
+ (with-dereferenced-handles ((ptr1 datahandle))
+ (%str-from-ptr-in-script ptr1 (#_GetHandleSize datahandle))))
+ myOSError))
+ myOSError))))))))
+
+;_______________________________
+; iChat AppleScripts |
+;_______________________________
+
+(defun I-CHAT-SET-STATUS-MESSAGE (String)
+ (eval-apple-script
+ (format nil "tell application \"iChat\" to set status message to \"~A\"" String)))
+
+
+(defun I-CHAT-SEND-MESSAGE (Message Receiver)
+ (eval-apple-script
+ (format nil
+"tell application \"iChat\"
+ repeat with a in (first account where id is \"~A\")
+ send \"~A\" to a
+ end repeat
+end tell"
+ Receiver Message)))
+
+
+;_______________________________
+; Finder AppleScripts |
+;_______________________________
+
+(defun FINDER-FILE-COMMENT (Pathname) "
+ in: Pathname pathname;
+ out: Comment string, error code;
+ Get the comment string from the Finder Get Info panel."
+ (eval-apple-script
+ (format nil
+"tell application \"Finder\"
+ get comment of file \"~A\"
+ end tell"
+ (mac-namestring Pathname))))
+
+
+;;; ---------------------------------------------------------------------------
+;;; simple shell script support
+;;; ---------------------------------------------------------------------------
+
+(defvar *applescript-host* "System Events")
+
+(defun do-shell-script (script)
+ (let ((command (format nil
+ "tell application \"~A\" ~
+ ~%do shell script \"~A\" ~
+ ~%end tell"
+ *applescript-host* script)))
+ (eval-apple-script command)))
+
+#+Test
+(do-shell-script "cd ~/documents; ls")
+
+
+#| Examples:
+
+(dotimes (i 10)
+ (i-chat-set-status-message ";-)")
+ (sleep 1.0)
+ (i-chat-set-status-message ":-)")
+ (sleep 1.0)
+ (i-chat-set-status-message ":-D")
+ (sleep 1.0))
+
+(i-chat-send-message "ciao bello" "AIM:mrvetro")
+
+;; low level
+
+
+(eval-apple-script "1 / 0")
+
+(eval-apple-script "tell application \"Script Editor\" to activate")
+
+(eval-apple-script "tell application \"iChat\" to activate")
+
+(eval-apple-script "tell application \"iChat\" to set status message to \";-)\"")
+
+
+(eval-apple-script
+ "property message : \"get a live you old bastard\"
+
+tell application \"iChat\"
+ repeat with a in (first account where id is \"AIM:mrvetro\")
+ send message to a
+ end repeat
+end tell")
+
+
+(finder-file-comment (choose-file-dialog))
+
+
+
+(eval-apple-script
+"tell application \"Finder\"
+ tell item \"Ristretto to Go\"
+ tell item \"The Matrix.jpg\"
+ get the comment
+ end tell
+ end tell
+end tell")
+
+
+(eval-apple-script
+"tell application \"Finder\"
+ tell item \"Ristretto to Go:The Matrix.jpg\"
+ get the comment
+ end tell
+end tell")
+
+
+(eval-apple-script
+"tell application \"Finder\"
+get the comment of file \"Ristretto to Go:The Matrix.jpg\"
+end tell")
+
+;; how to set image: http://www.blankreb.com/studiosnips.php?ID=30
+
+
+
+
+|#
+
--- /dev/null
+cygwin shell needs tobesomething like
+c://cygwin//bin//sh
+
+
+what commands belong in here
+
+running a 'shell' command
+
+synchronously or asynchronously
+ with callback at termination
+
+with or without a timeout
+
--- /dev/null
+(in-package #:trivial-shell)
+
+(defun %shell-command (command input)
+ (let* ((process (create-shell-process command t input))
+ (output (file-to-string-as-lines
+ (ccl::external-process-output-stream process)))
+ (error (file-to-string-as-lines
+ (ccl::external-process-error-stream process))))
+ (close (ccl::external-process-output-stream process))
+ (close (ccl::external-process-error-stream process))
+ (values output
+ error
+ (process-exit-code process))))
+
+(defun create-shell-process (command wait &optional input)
+ (with-input (input-stream (or input :none))
+ (ccl:run-program
+ *bourne-compatible-shell*
+ (list "-c" command)
+ :input input-stream :output :stream :error :stream
+ :wait wait)))
+
+(defun process-alive-p (process)
+ (eq (nth-value 0 (ccl:external-process-status process)) :running))
+
+(defun process-exit-code (process)
+ (nth-value 1 (ccl:external-process-status process)))
+
+(defun %os-process-id ()
+ (error 'unsupported-function-error :function 'os-process-id))
+
+(defun %get-env-var (name)
+ (ccl::getenv name))
+
+(defun %exit (code)
+ (ccl:quit code))
--- /dev/null
+(in-package #:common-lisp-user)
+
+(defpackage #:trivial-shell
+ (:use #:common-lisp #:com.metabang.trivial-timeout)
+ (:nicknames #:com.metabang.trivial-shell #:metashell)
+ (:export
+ #:shell-command
+ #:with-timeout
+ #:get-env-var
+ #:exit
+ #:*bourne-compatible-shell*
+ #:*shell-search-paths*
+
+ ;; conditions
+ #:timeout-error
+ #:timeout-error-command))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (import
+ #+allegro
+ '(mp:process-wait-with-timeout)
+ #+clisp
+ '()
+ #+(and cmu mp)
+ '(mp:process-wait-with-timeout)
+ #+(and cmu (not mp))
+ '()
+ #+cormanlisp
+ '()
+ #+digitool
+ '(ccl:process-wait-with-timeout)
+ #+lispworks
+ '(mp:process-wait-with-timeout)
+ #+(or openmcl ccl)
+ '(ccl:process-wait-with-timeout)
+ #+(and sbcl sb-threads)
+ '(sb-threads:make-semaphore
+ sb-threads:signal-semaphore)
+ #+(and sbcl (not sb-threads))
+ '()
+ '#:trivial-shell))
--- /dev/null
+(in-package #:trivial-shell)
+
+#-(or win32 (not sb-thread))
+(defun %shell-command (command input #+(or) output)
+ (with-input (input-stream (or input :none))
+ (let* ((process (sb-ext:run-program
+ *bourne-compatible-shell*
+ (list "-c" command)
+ :wait nil :input input-stream
+ :output :stream
+ :error :stream))
+ (output-thread (sb-thread:make-thread
+ #'(lambda ()
+ (file-to-string-as-lines
+ (sb-impl::process-output process)))))
+ (error-thread (sb-thread:make-thread
+ #'(lambda ()
+ (file-to-string-as-lines
+ (sb-impl::process-error process))))))
+ (let ((error-code
+ (sb-impl::process-exit-code (sb-impl::process-wait process)))
+ (output-string (sb-thread:join-thread output-thread))
+ (error-string (sb-thread:join-thread error-thread)))
+ (close (sb-impl::process-output process))
+ (close (sb-impl::process-error process))
+ (values output-string error-string error-code)))))
+
+#+(or win32 (not sb-thread))
+(defun %shell-command (command input #+(or) output)
+ (%shell-command-using-temporary-file command input))
+
+(defun %shell-command-using-temporary-file (command input)
+ (when input
+ (error "This version of trivial-shell does not support the input parameter."))
+ (let ((output (open-temporary-file))
+ (error (open-temporary-file)))
+ (unwind-protect
+ (let ((process
+ (sb-ext:run-program
+ *bourne-compatible-shell*
+ (list "-c" (format nil "~a > ~a 2> ~a"
+ command
+ (namestring output)
+ (namestring error)))
+ :wait t
+ :input nil
+ :output nil
+ :error nil)))
+ (let ((error-code (sb-impl::process-exit-code
+ (sb-impl::process-wait process)))
+ (output-string (read-temporary-file output))
+ (error-string (read-temporary-file error)))
+ (values output-string error-string error-code)))
+ ;; cleanup
+ (delete-file output)
+ (delete-file error))))
+
+(defun open-temporary-file ()
+ (pathname
+ (loop thereis (open (format nil "TEMP-~D" (random 100000))
+ :direction :probe :if-exists nil
+ :if-does-not-exist :create))))
+
+(defun read-temporary-file (file-stream)
+ (with-open-file (stream file-stream)
+ (let ((buffer (make-array (file-length stream)
+ :element-type 'character)))
+ (subseq buffer 0 (read-sequence buffer stream)))))
+
+
+(defun create-shell-process (command wait)
+ (sb-ext:run-program
+ *bourne-compatible-shell*
+ (list "-c" command)
+ :input nil :output :stream :error :stream :wait wait))
+
+(defun process-alive-p (process)
+ (sb-ext:process-alive-p process))
+
+(defun process-exit-code (process)
+ (sb-ext:process-exit-code process))
+
+(defun %os-process-id ()
+ (error 'unsupported-function-error :function 'os-process-id))
+
+(defun %get-env-var (name)
+ (sb-ext:posix-getenv name))
+
+(defun symbol-if-external (name package)
+ (multiple-value-bind (symbol s) (find-symbol name package)
+ (when (eq s :external)
+ symbol)))
+
+(defun %exit (code)
+ (let ((exit-sym (symbol-if-external "EXIT" "SB-EXT")))
+ (if exit-sym
+ (funcall exit-sym :code code)
+ (let ((quit-sym (symbol-if-external "QUIT" "SB-EXT")))
+ (if quit-sym
+ (funcall quit-sym :unix-status code :recklessly-p t)
+ (error "SBCL version without EXIT or QUIT."))))))
--- /dev/null
+(in-package #:trivial-shell)
+
+(defun %shell-command (command input)
+ (error 'unsupported-function-error :function 'shell-command))
+
+(defun %os-process-id ()
+ (error 'unsupported-function-error :function 'os-process-id))
+
+(defun %get-env-var (name)
+ (cdr (assoc name ext:*environment-list* :test #'string=))
+
+(defun %exit (code)
+ (ext:quit :status code))
--- /dev/null
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+
+(in-package #:metashell)
+
+(defgeneric file-to-string-as-lines (pathname)
+ (:documentation ""))
+
+(defmethod file-to-string-as-lines ((pathname pathname))
+ (with-open-file (stream pathname :direction :input)
+ (file-to-string-as-lines stream)))
+
+(defmethod file-to-string-as-lines ((stream stream))
+ (with-output-to-string (s)
+ (loop for line = (read-line stream nil :eof nil)
+ until (eq line :eof) do
+ (princ line s)
+ (terpri s))))
+
+(defmethod shell-command ((command pathname) &key input)
+ (shell-command (namestring command) :input input))
+
+(defmethod shell-command ((command t) &key input)
+ "Synchronously execute `command` using a Bourne-compatible shell,
+returns (values output error-output exit-status).
+
+The `command` can be a full path to a shell executable binary
+or just its name. In the later case, the variable `*shell-search-paths*`
+will be used to find the executable.
+
+Depending on the implementation, the variable `*bourne-compatible-shell*`
+may be used to find a shell to use in executing `command`."
+ (let* ((pos-/ (position #\/ command))
+ (pos-space (find-command-ending-in-string command))
+ (binary (subseq command 0 (or pos-space)))
+ (args (and pos-space (subseq command pos-space))))
+ (when (or (not pos-/)
+ (and pos-/ pos-space)
+ (and pos-space
+ (< pos-/ pos-space)))
+ ;; no slash in the command portion, try to find the command with
+ ;; our path
+ (setf binary
+ (or (loop for path in *shell-search-paths* do
+ (let ((full-binary (make-pathname :name binary
+ :defaults path)))
+ (when (and (probe-file full-binary)
+ (directory-pathname-p full-binary))
+ (return full-binary))))
+ binary)))
+ (multiple-value-bind (output error status)
+ (%shell-command (format nil "~a~@[ ~a~]" binary args) input)
+ (values output error status))))
+
+(defun find-command-ending-in-string (command)
+ (let ((checking? t))
+ (loop for ch across command
+ for i from 0 do
+ (cond ((and checking? (char= ch #\Space))
+ (return i))
+ ((char= ch #\\)
+ (setf checking? nil))
+ (t
+ (setf checking? t))))))
+
+(defun os-process-id ()
+ "Return the process-id of the currently executing OS process."
+ (%os-process-id))
+
+(defun get-env-var (name)
+ "Return the value of the environment variable `name`."
+ (%get-env-var name))
+
+(defun exit (&optional (code :success))
+ "Exit the process. CODE is either a numeric exit code, or the special values :SUCCESS
+or :FAILURE, which maps to the appropriate exit codes for the operating system."
+ ;; Currently, :SUCCESS always maps to 0 and :FAILURE maps to 1
+ (%exit (cond ((eq code :success) 0)
+ ((eq code :failure) 1)
+ ((integerp code) code)
+ (t (error "Illegal exit code: ~s (should be an integer or the values :SUCCESS or :FAILURE)" code)))))
--- /dev/null
+(in-package #:trivial-shell)
+
+(warn "Trivial-shell is not supported for this Lisp")
--- /dev/null
+(in-package #:com.metabang.trivial-shell)
+
+(defparameter *os-alist*
+ '((:windows :windows :mswindows :win32)
+ (:sun :solaris :sunos)
+ (:osx :macosx :darwin :apple)
+ (:linux :freebsd :netbsd :openbsd :bsd :linux :unix)))
+
+(defun host-os ()
+ (dolist (mapping *os-alist*)
+ (destructuring-bind (os &rest features) mapping
+ (dolist (f features)
+ (when (find f *features*) (return-from host-os os))))))
+
+#+(or)
+(defun os-pathname (pathname &key (os (os)))
+ (namestring pathname))
+
+(defun directory-pathname-p (pathname)
+ "Does `pathname` syntactically represent a directory?
+
+A directory-pathname is a pathname _without_ a filename. The three
+ways that the filename components can be missing are for it to be `nil`,
+`:unspecific` or the empty string.
+"
+ (flet ((check-one (x)
+ (not (null (member x '(nil :unspecific "")
+ :test 'equal)))))
+ (and (check-one (pathname-name pathname))
+ (check-one (pathname-type pathname)))))
+
+#+(or)
+;; from asdf-install
+(defun tar-argument (arg)
+ "Given a filename argument for tar, massage it into our guess of the
+ correct form based on the feature list."
+ #-(or :win32 :mswindows :scl)
+ (namestring (truename arg))
+ #+scl
+ (ext:unix-namestring (truename arg))
+
+ ;; Here we assume that if we're in Windows, we're running Cygwin,
+ ;; and cygpath is available. We call out to cygpath here rather than
+ ;; using shell backquoting. Relying on the shell can cause a host of
+ ;; problems with argument quoting, so we won't assume that
+ ;; RETURN-OUTPUT-FROM-PROGRAM will use a shell. [dwm]
+ #+(or :win32 :mswindows)
+ (with-input-from-string (s (return-output-from-program
+ (find-program "cygpath.exe")
+ (list (namestring (truename arg)))))
+ (values (read-line s))))
+
--- /dev/null
+;;; configuration for LIFT tests
+
+;; settings
+(:if-dribble-exists :supersede)
+(:dribble "trivial-shell.dribble")
+(:print-length 10)
+(:print-level 5)
+(:print-test-case-names t)
+
+;; suites to run
+(trivial-shell-test)
+
+;; report properties
+(:report-property :title "Trivial-Shell | Test results")
+(:report-property :relative-to trivial-shell-test)
+
+(:report-property :style-sheet "test-style.css")
+(:report-property :if-exists :supersede)
+(:report-property :format :html)
+(:report-property :name "test-results/test-report")
+(:report-property :unique-name t)
+(:build-report)
+(:report-property :name "website/output/test-report")
+(:report-property :unique-name nil)
+(:build-report)
+
+(:report-property :format :describe)
+(:report-property :full-pathname *standard-output*)
+(:build-report)
--- /dev/null
+#!/bin/sh
+
+echo $1
--- /dev/null
+(in-package #:common-lisp-user)
+
+(defpackage #:trivial-shell-test
+ (:use #:common-lisp #:lift #:trivial-shell)
+ (:shadowing-import-from #:trivial-shell
+ #:with-timeout
+ #:timeout-error))
+
+#|
+(defpackage #:p1
+ (:use #:common-lisp))
+
+(defpackage #:p2
+ (:use #:common-lisp))
+
+
+(defun p1::f ()
+ :p1)
+
+(defun p2::f ()
+ :p2)
+
+(defpackage p3
+ (:use #:common-lisp)
+ (:shadowing-import-from #:p1 #:f))
+
+(p3::f)
+
+|#
\ No newline at end of file
--- /dev/null
+(in-package #:trivial-shell-test)
+
+(deftestsuite test-with-timeout (trivial-shell-test)
+ ())
+
+(addtest (test-with-timeout)
+ timeout-times-out
+ (ensure-condition timeout-error
+ (with-timeout (1.0)
+ (sleep 2.0))))
\ No newline at end of file
--- /dev/null
+#|
+
+these tests are both very unixy
+
+|#
+
+(in-package #:trivial-shell-test)
+
+(deftestsuite trivial-shell-test ()
+ ())
+
+(addtest (trivial-shell-test)
+ test-1
+ (ensure-same (parse-integer (shell-command "expr 1 + 1") :junk-allowed t) 2))
+
+(addtest (trivial-shell-test)
+ test-input
+ (ensure-same (parse-integer
+ (shell-command "wc -c" :input "hello")
+ :junk-allowed t)
+ 5 :test '=))
+
+
+(deftestsuite spaces-in-command (trivial-shell-test)
+ ()
+ (:documentation "https://github.com/gwkkwg/trivial-shell/issues/1"))
+
+(addtest (spaces-in-command)
+ test-1
+ (ensure-same (parse-integer (shell-command "tests/a\\ b\\ c.sh 56") :junk-allowed t) 56))
--- /dev/null
+(in-package #:common-lisp-user)
+
+(unless (and (find-package '#:com.metabang.trivial-timeout)
+ (find-symbol (symbol-name '#:with-timeout)
+ '#:com.metabang.trivial-timeout)
+ (fboundp (find-symbol (symbol-name '#:with-timeout)
+ '#:com.metabang.trivial-timeout)))
+(defpackage #:com.metabang.trivial-timeout
+ (:use #:common-lisp)
+ (:nicknames #:trivial-timeout)
+ (:export
+ #:with-timeout
+ #:timeout-error)))
--- /dev/null
+(in-package #:com.metabang.trivial-timeout)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+(unless (and (find-symbol (symbol-name '#:with-timeout)
+ '#:com.metabang.trivial-timeout)
+ (fboundp (find-symbol (symbol-name '#:with-timeout)
+ '#:com.metabang.trivial-timeout)))
+(define-condition timeout-error (error)
+ ()
+ (:report (lambda (c s)
+ (declare (ignore c))
+ (format s "Process timeout")))
+ (:documentation "An error signaled when the duration specified in
+the [with-timeout][] is exceeded."))
+
+#+allegro
+(defun generate-platform-specific-code (seconds-symbol doit-symbol)
+ `(mp:with-timeout (,seconds-symbol (error 'timeout-error))
+ (,doit-symbol)))
+
+
+#+(and sbcl (not sb-thread))
+(defun generate-platform-specific-code (seconds-symbol doit-symbol)
+ (let ((glabel (gensym "label-"))
+ (gused-timer? (gensym "used-timer-")))
+ `(let ((,gused-timer? nil))
+ (catch ',glabel
+ (sb-ext:schedule-timer
+ (sb-ext:make-timer (lambda ()
+ (setf ,gused-timer? t)
+ (throw ',glabel nil)))
+ ,seconds-symbol)
+ (,doit-symbol))
+ (when ,gused-timer?
+ (error 'timeout-error)))))
+
+#+(and sbcl sb-thread)
+(defun generate-platform-specific-code (seconds-symbol doit-symbol)
+ `(handler-case
+ (sb-ext:with-timeout ,seconds-symbol (,doit-symbol))
+ (sb-ext::timeout (c)
+ (declare (ignore c))
+ (error 'timeout-error))))
+
+#+cmu
+;;; surely wrong
+(defun generate-platform-specific-code (seconds-symbol doit-symbol)
+ `(handler-case
+ (mp:with-timeout (seconds-symbol) (,doit-symbol))
+ (sb-ext::timeout (c)
+ (declare (ignore c))
+ (error 'timeout-error))))
+
+#+(or digitool openmcl ccl)
+(defun generate-platform-specific-code (seconds-symbol doit-symbol)
+ (let ((checker-process (format nil "Checker ~S" (gensym)))
+ (waiting-process (format nil "Waiter ~S" (gensym)))
+ (result (gensym))
+ (process (gensym)))
+ `(let* ((,result nil)
+ (,process (ccl:process-run-function
+ ,checker-process
+ (lambda ()
+ (setf ,result (multiple-value-list (,doit-symbol)))))))
+ (ccl:process-wait-with-timeout
+ ,waiting-process
+ (* ,seconds-symbol #+(or openmcl ccl)
+ ccl:*ticks-per-second* #+digitool 60)
+ (lambda ()
+ (not (ccl::process-active-p ,process))))
+ (when (ccl::process-active-p ,process)
+ (ccl:process-kill ,process)
+ (cerror "Timeout" 'timeout-error))
+ (values-list ,result))))
+
+#+(or digitool openmcl ccl)
+(defun generate-platform-specific-code (seconds-symbol doit-symbol)
+ (let ((gsemaphore (gensym "semaphore"))
+ (gresult (gensym "result"))
+ (gprocess (gensym "process")))
+ `(let* ((,gsemaphore (ccl:make-semaphore))
+ (,gresult)
+ (,gprocess
+ (ccl:process-run-function
+ ,(format nil "Timed Process ~S" gprocess)
+ (lambda ()
+ (setf ,gresult (multiple-value-list (,doit-symbol)))
+ (ccl:signal-semaphore ,gsemaphore)))))
+ (cond ((ccl:timed-wait-on-semaphore ,gsemaphore ,seconds-symbol)
+ (values-list ,gresult))
+ (t
+ (ccl:process-kill ,gprocess)
+ (error 'timeout-error))))))
+
+#+lispworks
+(defun generate-platform-specific-code (seconds-symbol doit-symbol)
+ (let ((gresult (gensym "result-"))
+ (gprocess (gensym "process-")))
+ `(let* (,gresult
+ (,gprocess (mp:process-run-function
+ "WITH-TIMEOUT"
+ '()
+ (lambda ()
+ (setq ,gresult (multiple-value-list (,doit-symbol)))))))
+ (unless (mp:process-wait-with-timeout
+ "WITH-TIMEOUT"
+ ,seconds-symbol
+ (lambda ()
+ (not (mp:process-alive-p ,gprocess))))
+ (mp:process-kill ,gprocess)
+ (cerror "Timeout" 'timeout-error))
+ (values-list ,gresult))))
+
+(unless (let ((symbol
+ (find-symbol (symbol-name '#:generate-platform-specific-code)
+ '#:com.metabang.trivial-timeout)))
+ (and symbol (fboundp symbol)))
+ (defun generate-platform-specific-code (seconds-symbol doit-symbol)
+ (declare (ignore seconds-symbol))
+ `(,doit-symbol)))
+
+(defmacro with-timeout ((seconds) &body body)
+ "Execute `body` for no more than `seconds` time.
+
+If `seconds` is exceeded, then a [timeout-error][] will be signaled.
+
+If `seconds` is nil, then the body will be run normally until it completes
+or is interrupted."
+ (build-with-timeout seconds body))
+
+(defun build-with-timeout (seconds body)
+ (let ((gseconds (gensym "seconds-"))
+ (gdoit (gensym "doit-")))
+ `(let ((,gseconds ,seconds))
+ (flet ((,gdoit ()
+ (progn ,@body)))
+ (cond (,gseconds
+ ,(generate-platform-specific-code gseconds gdoit))
+ (t
+ (,gdoit)))))))
+
+
+))
\ No newline at end of file
--- /dev/null
+#|
+Author: Gary King
+
+See file COPYING for details
+|#
+
+(defpackage #:trivial-shell-test-system (:use #:cl #:asdf))
+(in-package #:trivial-shell-test-system)
+
+(defsystem trivial-shell-test
+ :author "Gary Warren King <gwking@metabang.com>"
+ :maintainer "Gary Warren King <gwking@metabang.com>"
+ :licence "MIT Style License"
+ :description "Tests for trivial-shell"
+ :components ((:module
+ "setup"
+ :pathname "tests/"
+ :components
+ ((:file "package")
+ (:file "tests" :depends-on ("package"))))
+ (:module
+ "tests"
+ :depends-on ("setup")
+ :components ((:file "test-timeout"))))
+ :depends-on (:lift :trivial-shell))
+
+
--- /dev/null
+#|
+
+Author: Gary King
+
+Code originally forked from Kevin Rosenberg's KMRCL and borrowed from
+Alexander Repenning's Apple event code. It was then subjected to bursts
+of gamma radiation and repeated does of the sonic screwdriver.
+|#
+
+(defpackage :trivial-shell-system (:use #:cl #:asdf))
+(in-package :trivial-shell-system)
+
+(defsystem trivial-shell
+ :version "0.2.0"
+ :author "Gary Warren King <gwking@metabang.com>"
+ :maintainer "Gary Warren King <gwking@metabang.com>"
+ :licence "MIT Style License"
+ :description "OS and Implementation independent access to the shell"
+ :components ((:module
+ "notes"
+ :pathname "dev/"
+ :components
+ ((:static-file "notes.text")))
+ (:module
+ "timeout"
+ :pathname "timeout/"
+ :components
+ ((:file "package")
+ (:file "with-timeout" :depends-on ("package"))))
+ (:module
+ "setup"
+ :pathname "dev/"
+ :depends-on ("timeout")
+ :components
+ ((:file "package")))
+ (:module
+ "dev"
+ :depends-on ("setup")
+ :components
+ ((:file "definitions")
+ (:file "macros")
+ (:file "utilities")
+ (:file "shell"
+ :depends-on ("definitions" "macros" #+digitool "mcl"))))
+ (:module
+ "port"
+ :pathname "dev/"
+ :depends-on ("dev")
+ :components
+ (
+ #+abcl
+ (:file "abcl")
+ #+allegro
+ (:file "allegro")
+ #+clisp
+ (:file "clisp")
+ #+cmu
+ (:file "cmucl")
+ #+digitool
+ (:file "digitool")
+ #+ecl
+ (:file "ecl")
+ #+lispworks
+ (:file "lispworks")
+ #+openmcl
+ (:file "openmcl")
+ #+sbcl
+ (:file "sbcl")
+ #+scl
+ (file "scl")
+
+ #-(or abcl allegro clisp cmu digitool ecl
+ lispworks openmcl sbcl scl)
+ (:file "unsupported")
+ #+digitool
+ (:module "mcl"
+ :components ((:file "eval-apple-script")))))
+ (:module
+ "website"
+ :components
+ ((:module "source"
+ :components ((:static-file "index.md"))))))
+ :in-order-to ((test-op (load-op trivial-shell-test)))
+ :perform (test-op :after (op c)
+ (funcall
+ (intern (symbol-name '#:run-tests) :lift)
+ :config :generic))
+ :depends-on ())
+
+(defmethod operation-done-p
+ ((o test-op)
+ (c (eql (find-system 'trivial-shell))))
+ (values nil))
+
+
--- /dev/null
+;;; -*- Mode: Lisp -*-
+
+(in-package #:rw)
+
+(html-file-page ("index")
+ (html
+ (:HEAD (:TITLE "Trivial Shell")
+ (generate-shared-headers))
+ (:BODY
+ (generate-two-line-header
+ "Trivial Shell" "One shell to rule them all")
+
+ ((:DIV :CLASS "contents")
+ (generate-system-sidebar)
+
+ ((:DIV :CLASS "system-description")
+ (:H3 "What it is")
+ (:P "Trivial shell is a simple platform independent interface to the underlying Operating System. It forks and builds on the code in Kevin Rosenburg's handy KMRCL tools.")
+
+ ((:A :id "mailing-lists"))
+ (:h3 "Mailing Lists")
+ (:ul
+ (:li ((:a :href "http://common-lisp.net/cgi-bin/mailman/listinfo/trivial-shell-announce") "trivial-shell-announce")
+ ": A low volume, read only list for announcements.")
+
+ (:li ((:a :href "http://common-lisp.net/cgi-bin/mailman/listinfo/trivial-shell-devel") "trivial-shell-devel")
+ ": A list for questions, patches, bug reports, and so on; It's for everything
+other than announcements."))
+
+ ((:A :id "downloads"))
+ (:H3 "Where is it")
+ (:P "A " (rw:link :darcs) " repository is available. The darcs command is:")
+ (:PRE
+ "darcs get http://common-lisp.net/project/trivial-shell/darcs/trivial-shell")
+ (:P "Trivial-shell is also " (rw:link :asdf-install :title "ASDF installable") ". Its CLiki home is right " (rw:link :trivial-shell-cliki :title "where") " you'd expect.")
+ (:P "There's also a handy " (rw:link :trivial-shell-package :title "gzipped tar file") ".")
+
+ ((:A :id "news"))
+ (:H3 "What is happening")
+ ((:TABLE :CLASS "system-news")
+ (:tr
+ (:th "17 May 2006")
+ (:td "Created site.")))))
+
+ ((:DIV :CLASS "footer")
+ (generate-button-row
+ (format nil "Last updated: ~A"
+ (format-date "%A, %e %B %Y" (get-universal-time))))))))
\ No newline at end of file
--- /dev/null
+{include resources/header.md}
+{set-property title "Trivial-Shell - Getting out of Lisp more..."}
+
+<div class="contents">
+<div class="system-links">
+
+ * [Getting it][4]
+ * [News][6]
+{remark
+ * [Test results][tr]
+ * [Changelog][7]
+ }
+
+ [4]: #downloads
+ [5]: documentation/ (documentation link)
+ [6]: #news
+ [7]: changelog.html
+ [tr]: test-report.html
+
+</div>
+<div class="system-description">
+
+### What it is
+
+Trivial shell is a simple platform independent interface to
+the underlying Operating System. It includes:
+
+ * [get-env-var][],
+ * [os-process-id][] and, of course,
+ * [shell-command][]
+
+{anchor downloads}
+
+### Where is it
+
+metabang.com is slowly switching from [darcs][] to [git][]
+for source control; the *trivial-shell* repository is on
+[github][github-trivial-shell] and you can clone it using:
+
+ git clone git://github.com/gwkkwg/trivial-shell
+
+Trivial-shell is also [ASDF installable][asdf-install]. Its
+CLiki home is right [where][cliki-home] you'd
+expect.
+
+There's also a handy [gzipped tar file][tarball].
+
+
+{anchor news}
+
+### What is happening
+
+25 April 2010 - (time flies); moved to git and pulled in some
+fixes from Jochen Schmidt (thanks!).
+
+10 Jun 2008 - S'S'S'Syncing up with the jones
+
+6 Nov 2007 - Pulled website to [CL-Markdown][] format,
+brought in some patches (thanks!)
+
+17 May 2006 - Created site. Trivial-shell forks and builds on
+the code in Kevin Rosenburg's handy [KMRCL tools][KMRCL].
+
+</div>
+</div>
+
+{include resources/footer.md}
+
--- /dev/null
+<div id="footer" class="footer">
+<div id="buttons">
+<a class="nav" href="http://validator.w3.org/check/referer" title="xhtml1.1"><img src="http://common-lisp.net/project/cl-containers/shared/buttons/xhtml.gif" width="80" height="15" title="valid xhtml button" alt="valid xhtml" /></a>
+ <a class="nav" href="http://common-lisp.net/project/cl-markdown/" title="Mark with CL-Markdown"><img src="http://common-lisp.net/project/cl-containers/shared/buttons/cl-markdown.png" width="80" height="15" title="Made with CL-Markdown" alt="CL-Markdown" /></a>
+ <a class="nav" href="http://www.catb.org/hacker-emblem/" title="hacker"><img src="http://common-lisp.net/project/cl-containers/shared/buttons/hacker.png" width="80" height="15" title="hacker emblem" alt="hacker button" /></a>
+ <a class="nav" href="http://www.lisp.org/" title="Association of Lisp Users"><img src="http://common-lisp.net/project/cl-containers/shared/buttons/lambda-lisp.png" width="80" height="15" title="ALU emblem" alt="ALU button" /></a>
+ <a class="nav" href="http://common-lisp.net/" title="Common-Lisp.net"><img src="http://common-lisp.net/project/cl-containers/shared/buttons/lisp-lizard.png" width="80" height="15" title="Common-Lisp.net" alt="Common-Lisp.net button" /></a>
+</div>
+
+### Copyright (c) 2006 - 2008 Gary Warren King (gwking@metabang.com)
+
+Trivial-Shell has an MIT style license
+
+<div id="timestamp">Last updated {today} at {now}</div>
+</div>
\ No newline at end of file
--- /dev/null
+{include shared-links.md}
+{set-property html yes}
+{set-property style-sheet "http://common-lisp.net/project/cl-containers/shared/style-200.css"}
+{set-property author "Gary Warren King"}
+
+[devel-list]: http://common-lisp.net/cgi-bin/mailman/listinfo/trivial-shell-devel
+[cliki-home]: http://www.cliki.net/trivial-shell
+[tarball]: http://common-lisp.net/project/trivial-shell/trivial-shell.tar.gz
+
+[KMRCL]: http://www.cliki.net/kmrcl
+
+<div id="header">
+ <span class="logo"><a href="http://www.metabang.com/" title="metabang.com"><img src="http://common-lisp.net/project/cl-containers/shared/metabang-2.png" title="metabang.com" width="100" alt="Metabang Logo" /></a></span>
+
+## trivial-shell
+
+#### One shell to rule them all
+
+</div>
+
+
--- /dev/null
+{include resources/header.md}
+{set-property title "Trivial Shell User's Guide"}
+{set-property docs-package trivial-shell}
+
+# Trivial-Shell User's Guide
+
+## Introduction
+
+It's not much a guide, but it's here!
+
+<div class='reference'>
+
+## Reference
+
+{docs shell-command}
+{docs os-process-id}
+{docs get-env-var}
+
+</div>
+
+## Indices
+
+{docs-index :all}
+
+<hr>
+
+{include resources/footer.md}
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+ <key>currentDocument</key>
+ <string>source/resources/footer.md</string>
+ <key>documents</key>
+ <array>
+ <dict>
+ <key>filename</key>
+ <string>source/index.mmd</string>
+ <key>lastUsed</key>
+ <date>2009-04-29T14:01:17Z</date>
+ </dict>
+ <dict>
+ <key>filename</key>
+ <string>source/user-guide.mmd</string>
+ <key>lastUsed</key>
+ <date>2008-09-01T16:36:02Z</date>
+ </dict>
+ <dict>
+ <key>expanded</key>
+ <true/>
+ <key>name</key>
+ <string>resources</string>
+ <key>regexFolderFilter</key>
+ <string>!.*/(\.[^/]*|CVS|_darcs|_MTN|\{arch\}|blib|.*~\.nib|.*\.(framework|app|pbproj|pbxproj|xcode(proj)?|bundle))$</string>
+ <key>sourceDirectory</key>
+ <string>source/resources</string>
+ </dict>
+ </array>
+ <key>fileHierarchyDrawerWidth</key>
+ <integer>430</integer>
+ <key>metaData</key>
+ <dict>
+ <key>source/index.mmd</key>
+ <dict>
+ <key>caret</key>
+ <dict>
+ <key>column</key>
+ <integer>53</integer>
+ <key>line</key>
+ <integer>60</integer>
+ </dict>
+ <key>firstVisibleColumn</key>
+ <integer>0</integer>
+ <key>firstVisibleLine</key>
+ <integer>18</integer>
+ </dict>
+ <key>source/resources/footer.md</key>
+ <dict>
+ <key>caret</key>
+ <dict>
+ <key>column</key>
+ <integer>0</integer>
+ <key>line</key>
+ <integer>1</integer>
+ </dict>
+ <key>columnSelection</key>
+ <false/>
+ <key>firstVisibleColumn</key>
+ <integer>0</integer>
+ <key>firstVisibleLine</key>
+ <integer>0</integer>
+ <key>selectFrom</key>
+ <dict>
+ <key>column</key>
+ <integer>0</integer>
+ <key>line</key>
+ <integer>0</integer>
+ </dict>
+ <key>selectTo</key>
+ <dict>
+ <key>column</key>
+ <integer>0</integer>
+ <key>line</key>
+ <integer>1</integer>
+ </dict>
+ </dict>
+ <key>source/resources/header.md</key>
+ <dict>
+ <key>caret</key>
+ <dict>
+ <key>column</key>
+ <integer>0</integer>
+ <key>line</key>
+ <integer>10</integer>
+ </dict>
+ <key>firstVisibleColumn</key>
+ <integer>0</integer>
+ <key>firstVisibleLine</key>
+ <integer>0</integer>
+ </dict>
+ <key>source/user-guide.mmd</key>
+ <dict>
+ <key>caret</key>
+ <dict>
+ <key>column</key>
+ <integer>0</integer>
+ <key>line</key>
+ <integer>9</integer>
+ </dict>
+ <key>firstVisibleColumn</key>
+ <integer>0</integer>
+ <key>firstVisibleLine</key>
+ <integer>0</integer>
+ </dict>
+ </dict>
+ <key>openDocuments</key>
+ <array>
+ <string>source/resources/header.md</string>
+ <string>source/index.mmd</string>
+ <string>source/resources/footer.md</string>
+ <string>source/user-guide.mmd</string>
+ </array>
+ <key>showFileHierarchyDrawer</key>
+ <true/>
+ <key>windowFrame</key>
+ <string>{{596, 45}, {578, 788}}</string>
+</dict>
+</plist>
--- /dev/null
+0.7.0:
+
+* General: Separated USOCKET and USOCKET-SERVER systems (only the server part depends on Portable-threads)
+* General: USOCKET now depends on SPLIT-SEQUENCE (the exactly same vendor code is removed from usocket code base)
+* New feature: [LW] (SOCKET-OPTION :TCP-NODELAY) and its SETF version now works on LispWorks 4/5/6/7.
+* New feature: [LW] SOCKET-CONNECT now supports setting "tcp_nodelay" in version 4.x and 5.0.
+* Bugfix: [CCL] fixed issues in SOCKET-SHUTDOWN
+* Bugfix: [CLISP] fixed issues in WAIT-FOR-INPUT (Thanks to a patch by @vibs29, #27)
+* Bugfix: [LW] fixed loading in version <= 6.0 (actually 0.6.5 only fixed loading in LW 6.1)
+* Bugfix: [ECL] all compilation warnings were checked and fixed.
+
+0.6.5:
+
+* New feature: SOCKET-OPTION and (setf SOCKET-OPTION) for :SEND-TIMEOUT (thanks to John Pallister)
+* Bugfix: Let (WAIT-FOR-INPUT NIL &TIMEOUT) return NIL with respect to TIMEOUT.
+* Bugfix: [LW] fixed loading in LispWorks 5.x & 6.x.
+* Bugfix: [LW] fixed SOCKET-SHUTDOWN in all versions.
+* Bugfix: [ABCL] Fixed incorrect IPv6 addresses (#26), patch from Elias Mårtenson (lokedhs)
+
+0.6.4:
+
+* New feature: [SBCL] IPv6 support (patch from Guillaume LE VAILLANT, #15)
+* New feature: [API] SOCKET-SHUTDOWN added (patch from Thayne McCombs #9)
+* New feature: [Corman] minimal initial support of this platform
+* Bugfix: [SBCL/win32] wait-for-input nil-timeout bug (patch from Michal Herda, #13)
+* Bugfix: [ECL] included unistd.h for gethostname() (patch from Daniel Kochmanski, #7)
+* Bugfix: [LispWorks] SOCKET-RECEIVE now updates %READ-P (patch from Frank James)
+
+0.6.3:
+
+* Bugfix: [CCL] Further fixed CCL-1.11 compatibility and a typo in SOCKET-CONNECT for CCL-1.10.
+* Bugfix: [ECL] Fixed build in some versions.
+* Bugfix: [LispWorks] SOCKET-SEND and SOCKET-RECEIVE now throw conditions if something goes wrong.
+
+0.6.2:
+
+* Bugfix: [CCL] Fixed CCL-1.11 compatibility.
+* Bugfix: [ECL] Fixed compatibility on recent versions.
+* Bugfix: [LispWorks] Added support address-in-use-error condition on LW/Win32. (patch from Sergey Katrevich).
+
+0.6.1:
+
+* New feature: [MOCL] Initial MOCL support (TCP only, no W-F-I, patch from github.com/Wukix/usocket).
+* New feature: [MCL] Initial UDP support for Macintosh Common Lisp (MCL/RMCL).
+* New feature: Added TCP-NO-DELAY (TCP_NODELAY) support in SOCKET-OPTION, for TCP client
+* Bugfix: [CCL] Added (:external-format ccl:*default-external-format*) to SOCKET-CONNECT, to prevent it fallback to ISO-8859-1 on NIL. (Patch from Vsevolod Dyomkin)
+* Bugfix: [CCL] Performance improved WAIT-FOR-INPUT and other fixes. (patch from Faré <fahree@gmail.com>)
+
+0.6.0:
+
+* New feature: SOCKET-OPTION and (setf SOCKET-OPTION) for seting and geting various socket options.
+* New feature: SOCKET-SEND now support an CCL-like OFFSET keyword for sending only parts of the whole buffer.
+* New feature: [ECL] Added support for ECL DFFI mode on Windows. (no need for C compilers now)
+* Bugfix: [ECL] ECL now list sb-bsd-sockets as a dependency but relies on REQUIRE. (patched by Juanjo)
+* Bugfix: [ABCL] Make USOCKET compile warning-free on ABCL again: MAKE-IMMEDIATE-OBJECT was deprecated a while ago in favor of 2 predefined constants.
+* Bugfix: [LispWorks] remove redundant call to hcl:flag-special-free-action. (reported by Kamil Shakirov)
+* Bugfix: [CLISP] improved HANDLE-CONDITION for more CLISP environments.
+
+0.5.5:
+
+* Enhancement: SOCKET-CONNECT argument :nodelay can now set to :if-supported (patch from Anton Vodonosov).
+* Enhancement: [Server] adding *remote-host* *remote-port* to socket-server stream handler functions (suggested by Matthew Curry)
+* Bugfix: [LispWorks] Fixed UDP support for LispWorks 6.1 (patch from Camille Troillard by Martin Simmons).
+* Bugfix: [LispWorks] Stop using hcl:add-special-free-action for reclaiming unused UDP socket fds to improve multi-threading stablity (suggested by Camille Troillard).
+* Bugfix: [LispWorks] Fixed SOCKET-CONNECT on Windows, now LOCAL-PORT never have *auto-port* (0) as default value.
+
+0.5.4:
+
+* Bugfix: [ECL] Fixed for ECL's MAKE-BUILD by removing some unecessary code (reported by Juan Jose Garcia-Ripoll, the ECL maintainer)
+* Bugfix: [ACL] Fixed for Allegro CL modern mode.
+* Bugfix: [SBCL] SOCKET-CONNECT on TCP won't call bind() when keyword arguments LOCAL-HOST or LOCAL-PORT is not set. (reported by Robert Brown)
+
+0.5.3:
+
+* Bugfix: [MCL] Fixed SOCKET-LISTEN on vector addresses like #(0 0 0 0)
+* Bugfix: [MCL] Fixed WAIT-FOR-INPUT on passive sockets (stream-server-usocket)
+* Bugfix: [LispWorks] Fixed using OPEN-UDP-SOCKET in delivered applications (thanks to Camille Troillard and Martin Simmons, this fix is from LispWorks-UDP project).
+* Bugfix: [SBCL] Fixed for "SBCL data flush problem", reported by Robert Brown and confirmed by Nikodemus Siivola.
+
+0.5.2:
+
+* General: [SBCL] SOCKET-CONNECT's TIMEOUT argument was limited on non-Windows platforms.
+* Bugfix: [CLISP] WAIT-FOR-INPUT now functions right (with/without READY-ONLY), this made Hunchentoot working on CLISP. (Thanks to Anton Vodonosov <avodonosov@yandex.ru>)
+* Bugfix: [ABCL] Fix SOCKET-ACCEPT to follow the documented API so that when called without an :ELEMENT-TYPE argument. (Thanks to Mark Evenson, the ABCL developer)
+* Bugfix: [LispWorks] Fixed SOCKET-ACCEPT (Windows only) on WAIT-FOR-INPUTed sockets.
+* Bugfix: [SBCL, ECL] Fixed wrongly STATE set/unset for WAIT-FOR-INPUT on Windows (report by Elliott Slaughter)
+* Enhancement: Additional NAME keyword argument for SOCKET-SERVER for setting the server thread name.
+* Enhancement: [ABCL] GET-ADDRESS now works with underlying IP6 addresses.
+* Enhancement: [CLISP] missing GET-LOCAL-* methods for STREAM-SERVER-USOCKET was now added.
+
+0.5.1:
+
+* New feature: [CLISP] UDP (Datagram) support based on FFI (Win/Mac/Linux), no RAWSOCK needed.
+* Enhancement: SOCKET-SERVER return a second value (socket) when calling in new-thread mode.
+* Enhancement: [CLISP] Full support of DNS helper functions (GET-HOST-BY-NAME, ...) added.
+* Enhancement: [CLISP] Better network error type detection based on OS error code.
+* Enhancement: [LispWorks] Better network error type detection based on OS error code.
+* Bugfix: Fixed wrong macro expansions of {IP|PORT}-{FROM|TO}-OCTET-BUFFER functions (since 0.4.0)
+* Bugfix: SOCKET-CONNECT didn't set CONNECTED-P for datagram usockets on most backends.
+* Bugfix: [SBCL] Fixes for "SBCL/Win32: finalizer problem, etc", by Anton Kovalenko <anton@sw4me.com>
+* Bugfix: [SBCL] Fixed SOCKET-SERVER (UDP) on SBCL due to a issue in SOCKET-CONNECT when HOST is NIL.
+* Bugfix: [SBCL] SOCKET-CONNECT's TIMEOUT argument now works as a "connection timeout".
+* Bugfix: [CMUCL] Fixed SOCKET-SEND on unconnected usockets under Unicode version of CMUCL.
+* Bugfix: [CLISP] Fixed and confirmed UDP (Datagram) support (RAWSOCK version).
+
+0.5.0:
+
+* New supported platform: Macintosh Common Lisp (5.0 and up, plus RMCL)
+* Support for UDP (datagram-usocket) was added (for all supported platform except MCL)
+* Add WAIT-FOR-INPUT support for SBCL and ECL on win32.
+* Simple TCP and UDP server API: SOCKET-SERVER
+* Completely rewritten full-feature ABCL backends using latest Java interfaces
+* Lots of bug fixed since 0.4.1
+
+[TODO]
+
+* New feature: CLISP support some advanced TCP features which CLISP's SOCKET interface not provide
--- /dev/null
+(This is the MIT / X Consortium license as taken from
+ http://www.opensource.org/licenses/mit-license.html)
+
+Copyright (c) 2003 Erik Enge
+Copyright (c) 2006-2007 Erik Huelsmann
+
+Permission is hereby granted, free of charge, to any person obtaining
+a copy of this software and associated documentation files (the
+"Software"), to deal in the Software without restriction, including
+without limitation the rights to use, copy, modify, merge, publish,
+distribute, sublicense, and/or sell copies of the Software, and to
+permit persons to whom the Software is furnished to do so, subject to
+the following conditions:
+
+The above copyright notice and this permission notice shall be
+included in all copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
--- /dev/null
+# Introduction
+
+This is the usocket Common Lisp sockets library: a library to bring
+sockets access to the broadest of common lisp implementations as possible.
+
+# The library currently supports:
+
+ - SBCL
+ - CMUCL
+ - ArmedBear Common Lisp
+ - GNU CLISP
+ - Allegro Common Lisp
+ - LispWorks
+ - Clozure CL
+ - ECL
+ - Scieneer Common Lisp
+ - Macintosh Common Lisp
+ - MOCL
+
+If your favorite common lisp misses in the list above, please contact
+usocket-devel@common-lisp.net and submit a request. Please include
+references to available sockets functions in your lisp implementation.
+
+The library has been ASDF (http://cliki.net/ASDF) enabled, meaning
+that you can tar up a checkout and use that to ASDF-INSTALL:INSTALL
+the package in your system package site. (Or use your usual ASDF
+tricks to use the checkout directly.)
+
+# Remarks on licensing
+
+Even though the source code has an MIT style license attached to it,
+when compiling this code with some of the supported lisp implementations
+you may not end up with an MIT style binary version due to the licensing
+of the implementations themselves. ECL is such an example and - when
+it will become supported - GCL is like that too.
+
+# Non-support of :external-format
+
+Because of its definition in the hyperspec, there's no common
+external-format between lisp implementations: every vendor has chosen
+a different way to solve the problem of newline translation or
+character set recoding.
+
+Because there's no way to avoid platform specific code in the application
+when using external-format, the purpose of a portability layer gets
+defeated. So, for now, usocket doesn't support external-format.
+
+The workaround to get reasonably portable external-format support is to
+layer a flexi-stream (from flexi-streams) on top of a usocket stream.
+
+# API definition
+
+ - usocket (class)
+ - stream-usocket (class; usocket derivative)
+ - stream-server-usocket (class; usocket derivative)
+ - socket-connect (function) [ to create an active/connected socket ]
+ socket-connect host port &key element-type
+ where `host' is a vectorized ip
+ or a string representation of a dotted ip address
+ or a hostname for lookup in the DNS system
+ - socket-listen (function) [ to create a passive/listening socket ]
+ socket-listen host port &key reuseaddress backlog element-type
+ where `host' has the same definition as above
+ - socket-accept (method) [ to create an active/connected socket ]
+ socket-accept socket &key element-type
+ returns (server side) a connected socket derived from a
+ listening/passive socket.
+ - socket-close (method)
+ socket-close socket
+ where socket a previously returned socket
+ - socket (usocket slot accessor),
+ the internal/implementation defined socket representation
+ - socket-stream (usocket slot accessor),
+ socket-stream socket
+ the return value of which satisfies the normal stream interface
+ - socket-shutdown
+
+## Errors:
+ - address-in-use-error
+ - address-not-available-error
+ - bad-file-descriptor-error
+ - connection-refused-error
+ - connection-aborted-error
+ - connection-reset-error
+ - invalid-argument-error
+ - no-buffers-error
+ - operation-not-supported-error
+ - operation-not-permitted-error
+ - protocol-not-supported-error
+ - socket-type-not-supported-error
+ - network-unreachable-error
+ - network-down-error
+ - network-reset-error
+ - host-down-error
+ - host-unreachable-error
+ - shutdown-error
+ - timeout-error
+ - unkown-error
+
+## Non-fatal conditions:
+ - interrupted-condition
+ - unkown-condition
+
+(for a description of the API methods and functions see
+ https://common-lisp.net/project/usocket/api-docs.shtml)
+
+# Test suite
+
+The test suite unfortunately isn't mature enough yet to run without
+some manual configuration. Several elements are required which are
+hard to programatically detect. Please adjust the test file before
+running the tests, for these variables:
+
+- +non-existing-host+: The stringified IP address of a host on the
+ same subnet. No physical host may be present.
+- +unused-local-port+: A port number of a port not in use on the
+ machine the tests run on.
+- +common-lisp-net+: A vector with 4 integer elements which make up
+ an IP address. This must be the IP "common-lisp.net" resolves to.
+
+# Known problems
+
+- CMUCL error reporting wrt sockets raises only simple-errors
+ meaning there's no way to tell different error conditions apart.
+ All errors are mapped to unknown-error on CMUCL.
+
+- The ArmedBear backend doesn't do any error mapping (yet). Java
+ defines exceptions at the wrong level (IMO), since the exception
+ reported bares a relation to the function failing, not the actual
+ error that occurred: for example 'Address already in use' (when
+ creating a passive socket) is reported as a BindException with
+ an error text of 'Address already in use'. There's no way to sanely
+ map 'BindException' to a meaningfull error in usocket. [This does not
+ mean the backend should not at least map to 'unknown-error'!]
+
+- When using the library with ECL, you need the C compiler installed
+ to be able to compile and load the Foreign Function Interface.
+ Not all ECL targets support DFFI yet, so on some targets this would
+ be the case anyway. By depending on this technique, usocket can
+ reuse the FFI code on all platforms (including Windows). This benefit
+ currently outweighs the additional requirement. (hey, it's *Embeddable*
+ Common Lisp, so, you probably wanted to embed it all along, right?)
--- /dev/null
+- Fix condition systems (making all implementation generate same error)
+- Add INET6 support.
+- IOlib backend
+
+For more TODO items, see http://trac.common-lisp.net/usocket/report.
--- /dev/null
+;;;; $Id$
+;;;; $URL$
+
+;;;; New ABCL networking support (replacement to old armedbear.lisp)
+;;;; Author: Chun Tian (binghe)
+
+;;;; See LICENSE for licensing information.
+
+(in-package :usocket)
+
+;;; Java Classes ($*...)
+(defvar $*boolean (jclass "boolean"))
+(defvar $*byte (jclass "byte"))
+(defvar $*byte[] (jclass "[B"))
+(defvar $*int (jclass "int"))
+(defvar $*long (jclass "long"))
+(defvar $*|Byte| (jclass "java.lang.Byte"))
+(defvar $*DatagramChannel (jclass "java.nio.channels.DatagramChannel"))
+(defvar $*DatagramPacket (jclass "java.net.DatagramPacket"))
+(defvar $*DatagramSocket (jclass "java.net.DatagramSocket"))
+(defvar $*Inet4Address (jclass "java.net.Inet4Address"))
+(defvar $*InetAddress (jclass "java.net.InetAddress"))
+(defvar $*InetSocketAddress (jclass "java.net.InetSocketAddress"))
+(defvar $*Iterator (jclass "java.util.Iterator"))
+(defvar $*SelectableChannel (jclass "java.nio.channels.SelectableChannel"))
+(defvar $*SelectionKey (jclass "java.nio.channels.SelectionKey"))
+(defvar $*Selector (jclass "java.nio.channels.Selector"))
+(defvar $*ServerSocket (jclass "java.net.ServerSocket"))
+(defvar $*ServerSocketChannel (jclass "java.nio.channels.ServerSocketChannel"))
+(defvar $*Set (jclass "java.util.Set"))
+(defvar $*Socket (jclass "java.net.Socket"))
+(defvar $*SocketAddress (jclass "java.net.SocketAddress"))
+(defvar $*SocketChannel (jclass "java.nio.channels.SocketChannel"))
+(defvar $*String (jclass "java.lang.String"))
+
+;;; Java Constructor ($%.../n)
+(defvar $%Byte/0 (jconstructor $*|Byte| $*byte))
+(defvar $%DatagramPacket/3 (jconstructor $*DatagramPacket $*byte[] $*int $*int))
+(defvar $%DatagramPacket/5 (jconstructor $*DatagramPacket $*byte[] $*int $*int $*InetAddress $*int))
+(defvar $%DatagramSocket/0 (jconstructor $*DatagramSocket))
+(defvar $%DatagramSocket/1 (jconstructor $*DatagramSocket $*int))
+(defvar $%DatagramSocket/2 (jconstructor $*DatagramSocket $*int $*InetAddress))
+(defvar $%InetSocketAddress/1 (jconstructor $*InetSocketAddress $*int))
+(defvar $%InetSocketAddress/2 (jconstructor $*InetSocketAddress $*InetAddress $*int))
+(defvar $%ServerSocket/0 (jconstructor $*ServerSocket))
+(defvar $%ServerSocket/1 (jconstructor $*ServerSocket $*int))
+(defvar $%ServerSocket/2 (jconstructor $*ServerSocket $*int $*int))
+(defvar $%ServerSocket/3 (jconstructor $*ServerSocket $*int $*int $*InetAddress))
+(defvar $%Socket/0 (jconstructor $*Socket))
+(defvar $%Socket/2 (jconstructor $*Socket $*InetAddress $*int))
+(defvar $%Socket/4 (jconstructor $*Socket $*InetAddress $*int $*InetAddress $*int))
+
+;;; Java Methods ($@...[/Class]/n)
+(defvar $@accept/0 (jmethod $*ServerSocket "accept"))
+(defvar $@bind/DatagramSocket/1 (jmethod $*DatagramSocket "bind" $*SocketAddress))
+(defvar $@bind/ServerSocket/1 (jmethod $*ServerSocket "bind" $*SocketAddress))
+(defvar $@bind/ServerSocket/2 (jmethod $*ServerSocket "bind" $*SocketAddress $*int))
+(defvar $@bind/Socket/1 (jmethod $*Socket "bind" $*SocketAddress))
+(defvar $@byteValue/0 (jmethod $*|Byte| "byteValue"))
+(defvar $@channel/0 (jmethod $*SelectionKey "channel"))
+(defvar $@close/DatagramSocket/0 (jmethod $*DatagramSocket "close"))
+(defvar $@close/Selector/0 (jmethod $*Selector "close"))
+(defvar $@close/ServerSocket/0 (jmethod $*ServerSocket "close"))
+(defvar $@close/Socket/0 (jmethod $*Socket "close"))
+(defvar $@shutdownInput/Socket/0 (jmethod $*Socket "shutdownInput"))
+(defvar $@shutdownOutput/Socket/0 (jmethod $*Socket "shutdownOutput"))
+(defvar $@configureBlocking/1 (jmethod $*SelectableChannel "configureBlocking" $*boolean))
+(defvar $@connect/DatagramChannel/1 (jmethod $*DatagramChannel "connect" $*SocketAddress))
+(defvar $@connect/Socket/1 (jmethod $*Socket "connect" $*SocketAddress))
+(defvar $@connect/Socket/2 (jmethod $*Socket "connect" $*SocketAddress $*int))
+(defvar $@connect/SocketChannel/1 (jmethod $*SocketChannel "connect" $*SocketAddress))
+(defvar $@getAddress/0 (jmethod $*InetAddress "getAddress"))
+(defvar $@getAllByName/1 (jmethod $*InetAddress "getAllByName" $*String))
+(defvar $@getByName/1 (jmethod $*InetAddress "getByName" $*String))
+(defvar $@getChannel/DatagramSocket/0 (jmethod $*DatagramSocket "getChannel"))
+(defvar $@getChannel/ServerSocket/0 (jmethod $*ServerSocket "getChannel"))
+(defvar $@getChannel/Socket/0 (jmethod $*Socket "getChannel"))
+(defvar $@getAddress/DatagramPacket/0 (jmethod $*DatagramPacket "getAddress"))
+(defvar $@getHostName/0 (jmethod $*InetAddress "getHostName"))
+(defvar $@getInetAddress/DatagramSocket/0 (jmethod $*DatagramSocket "getInetAddress"))
+(defvar $@getInetAddress/ServerSocket/0 (jmethod $*ServerSocket "getInetAddress"))
+(defvar $@getInetAddress/Socket/0 (jmethod $*Socket "getInetAddress"))
+(defvar $@getLength/DatagramPacket/0 (jmethod $*DatagramPacket "getLength"))
+(defvar $@getLocalAddress/DatagramSocket/0 (jmethod $*DatagramSocket "getLocalAddress"))
+(defvar $@getLocalAddress/Socket/0 (jmethod $*Socket "getLocalAddress"))
+(defvar $@getLocalPort/DatagramSocket/0 (jmethod $*DatagramSocket "getLocalPort"))
+(defvar $@getLocalPort/ServerSocket/0 (jmethod $*ServerSocket "getLocalPort"))
+(defvar $@getLocalPort/Socket/0 (jmethod $*Socket "getLocalPort"))
+(defvar $@getOffset/DatagramPacket/0 (jmethod $*DatagramPacket "getOffset"))
+(defvar $@getPort/DatagramPacket/0 (jmethod $*DatagramPacket "getPort"))
+(defvar $@getPort/DatagramSocket/0 (jmethod $*DatagramSocket "getPort"))
+(defvar $@getPort/Socket/0 (jmethod $*Socket "getPort"))
+(defvar $@hasNext/0 (jmethod $*Iterator "hasNext"))
+(defvar $@iterator/0 (jmethod $*Set "iterator"))
+(defvar $@next/0 (jmethod $*Iterator "next"))
+(defvar $@open/DatagramChannel/0 (jmethod $*DatagramChannel "open"))
+(defvar $@open/Selector/0 (jmethod $*Selector "open"))
+(defvar $@open/ServerSocketChannel/0 (jmethod $*ServerSocketChannel "open"))
+(defvar $@open/SocketChannel/0 (jmethod $*SocketChannel "open"))
+(defvar $@receive/1 (jmethod $*DatagramSocket "receive" $*DatagramPacket))
+(defvar $@register/2 (jmethod $*SelectableChannel "register" $*Selector $*int))
+(defvar $@select/0 (jmethod $*Selector "select"))
+(defvar $@select/1 (jmethod $*Selector "select" $*long))
+(defvar $@selectedKeys/0 (jmethod $*Selector "selectedKeys"))
+(defvar $@send/1 (jmethod $*DatagramSocket "send" $*DatagramPacket))
+(defvar $@setReuseAddress/1 (jmethod $*ServerSocket "setReuseAddress" $*boolean))
+(defvar $@setSoTimeout/DatagramSocket/1 (jmethod $*DatagramSocket "setSoTimeout" $*int))
+(defvar $@setSoTimeout/Socket/1 (jmethod $*Socket "setSoTimeout" $*int))
+(defvar $@setTcpNoDelay/1 (jmethod $*Socket "setTcpNoDelay" $*boolean))
+(defvar $@socket/DatagramChannel/0 (jmethod $*DatagramChannel "socket"))
+(defvar $@socket/ServerSocketChannel/0 (jmethod $*ServerSocketChannel "socket"))
+(defvar $@socket/SocketChannel/0 (jmethod $*SocketChannel "socket"))
+(defvar $@validOps/0 (jmethod $*SelectableChannel "validOps"))
+
+;;; Java Field Variables ($+...)
+(defvar $+op-accept (jfield $*SelectionKey "OP_ACCEPT"))
+(defvar $+op-connect (jfield $*SelectionKey "OP_CONNECT"))
+(defvar $+op-read (jfield $*SelectionKey "OP_READ"))
+(defvar $+op-write (jfield $*SelectionKey "OP_WRITE"))
+
+
+;;; Wrapper functions (return-type: java-object)
+(defun %get-address (address)
+ (jcall $@getAddress/0 address))
+(defun %get-all-by-name (string) ; return a simple vector
+ (jstatic $@getAllByName/1 $*InetAddress string))
+(defun %get-by-name (string)
+ (jstatic $@getByName/1 $*InetAddress string))
+
+(defun host-to-inet4 (host)
+ "USOCKET host formats to Java Inet4Address, used internally."
+ (%get-by-name (host-to-hostname host)))
+
+;;; HANDLE-CONTITION
+
+(defparameter +abcl-error-map+
+ `(("java.net.BindException" . operation-not-permitted-error)
+ ("java.net.ConnectException" . connection-refused-error)
+ ("java.net.NoRouteToHostException" . network-unreachable-error) ; untested
+ ("java.net.PortUnreachableException" . protocol-not-supported-error) ; untested
+ ("java.net.ProtocolException" . protocol-not-supported-error) ; untested
+ ("java.net.SocketException" . socket-type-not-supported-error) ; untested
+ ("java.net.SocketTimeoutException" . timeout-error)))
+
+(defparameter +abcl-nameserver-error-map+
+ `(("java.net.UnknownHostException" . ns-host-not-found-error)))
+
+(defun handle-condition (condition &optional (socket nil))
+ (typecase condition
+ (java-exception
+ (let ((java-cause (java-exception-cause condition)))
+ (let* ((usock-error (cdr (assoc (jclass-of java-cause) +abcl-error-map+
+ :test #'string=)))
+ (usock-error (if (functionp usock-error)
+ (funcall usock-error condition)
+ usock-error))
+ (nameserver-error (cdr (assoc (jclass-of java-cause) +abcl-nameserver-error-map+
+ :test #'string=))))
+ (if nameserver-error
+ (error nameserver-error :host-or-ip nil)
+ (when usock-error
+ (error usock-error :socket socket))))))))
+
+;;; GET-HOSTS-BY-NAME
+
+(defun get-address (address)
+ (when address
+ (let* ((array (%get-address address))
+ (length (jarray-length array)))
+ (labels ((jbyte (n)
+ (let ((byte (jarray-ref array n)))
+ (if (minusp byte) (+ 256 byte) byte))))
+ (cond
+ ((= 4 length)
+ (vector (jbyte 0) (jbyte 1) (jbyte 2) (jbyte 3)))
+ ((= 16 length)
+ (vector (jbyte 0) (jbyte 1) (jbyte 2) (jbyte 3)
+ (jbyte 4) (jbyte 5) (jbyte 6) (jbyte 7)
+ (jbyte 8) (jbyte 9) (jbyte 10) (jbyte 11)
+ (jbyte 12) (jbyte 13) (jbyte 14) (jbyte 15)))
+ (t nil)))))) ; neither a IPv4 nor IPv6 address?!
+
+(defun get-hosts-by-name (name)
+ (with-mapped-conditions ()
+ (map 'list #'get-address (%get-all-by-name name))))
+
+;;; GET-HOST-BY-ADDRESS
+
+(defun get-host-by-address (host)
+ (let ((inet4 (host-to-inet4 host)))
+ (with-mapped-conditions ()
+ (jcall $@getHostName/0 inet4))))
+
+;;; SOCKET-CONNECT
+
+(defun socket-connect (host port &key (protocol :stream) (element-type 'character)
+ timeout deadline (nodelay t nodelay-supplied-p)
+ local-host local-port)
+ (when deadline (unsupported 'deadline 'socket-connect))
+ (let (socket stream usocket)
+ (ecase protocol
+ (:stream ; TCP
+ (let ((channel (jstatic $@open/SocketChannel/0 $*SocketChannel))
+ (address (jnew $%InetSocketAddress/2 (host-to-inet4 host) port)))
+ (setq socket (jcall $@socket/SocketChannel/0 channel))
+ ;; bind to local address if needed
+ (when (or local-host local-port)
+ (let ((local-address (jnew $%InetSocketAddress/2 (host-to-inet4 local-host) (or local-port 0))))
+ (with-mapped-conditions ()
+ (jcall $@bind/Socket/1 socket local-address))))
+ ;; connect to dest address
+ (with-mapped-conditions ()
+ (jcall $@connect/SocketChannel/1 channel address))
+ (setq stream (ext:get-socket-stream socket :element-type element-type)
+ usocket (make-stream-socket :stream stream :socket socket))
+ (when nodelay-supplied-p
+ (jcall $@setTcpNoDelay/1 socket (if nodelay ;; both t and :if-supported mean java:+true+
+ java:+true+ java:+false+)))
+ (when timeout
+ (jcall $@setSoTimeout/Socket/1 socket (truncate (* 1000 timeout))))))
+ (:datagram ; UDP
+ (let ((channel (jstatic $@open/DatagramChannel/0 $*DatagramChannel)))
+ (setq socket (jcall $@socket/DatagramChannel/0 channel))
+ ;; bind to local address if needed
+ (when (or local-host local-port)
+ (let ((local-address (jnew $%InetSocketAddress/2 (host-to-inet4 local-host) (or local-port 0))))
+ (with-mapped-conditions ()
+ (jcall $@bind/DatagramSocket/1 socket local-address))))
+ ;; connect to dest address if needed
+ (when (and host port)
+ (let ((address (jnew $%InetSocketAddress/2 (host-to-inet4 host) port)))
+ (with-mapped-conditions ()
+ (jcall $@connect/DatagramChannel/1 channel address))))
+ (setq usocket (make-datagram-socket socket :connected-p (if (and host port) t nil)))
+ (when timeout
+ (jcall $@setSoTimeout/DatagramSocket/1 socket (truncate (* 1000 timeout)))))))
+ usocket))
+
+;;; SOCKET-LISTEN
+
+(defun socket-listen (host port &key reuseaddress
+ (reuse-address nil reuse-address-supplied-p)
+ (backlog 5 backlog-supplied-p)
+ (element-type 'character))
+ (declare (type boolean reuse-address))
+ (let* ((reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress))
+ (channel (jstatic $@open/ServerSocketChannel/0 $*ServerSocketChannel))
+ (socket (jcall $@socket/ServerSocketChannel/0 channel))
+ (endpoint (jnew $%InetSocketAddress/2 (host-to-inet4 host) (or port 0))))
+ (jcall $@setReuseAddress/1 socket (if reuseaddress java:+true+ java:+false+))
+ (with-mapped-conditions (socket)
+ (if backlog-supplied-p
+ (jcall $@bind/ServerSocket/2 socket endpoint backlog)
+ (jcall $@bind/ServerSocket/1 socket endpoint)))
+ (make-stream-server-socket socket :element-type element-type)))
+
+;;; SOCKET-ACCEPT
+
+(defmethod socket-accept ((usocket stream-server-usocket)
+ &key (element-type 'character element-type-p))
+ (with-mapped-conditions (usocket)
+ (let* ((client-socket (jcall $@accept/0 (socket usocket)))
+ (element-type (if element-type-p
+ element-type
+ (element-type usocket)))
+ (stream (ext:get-socket-stream client-socket :element-type element-type)))
+ (make-stream-socket :stream stream :socket client-socket))))
+
+;;; SOCKET-CLOSE
+
+(defmethod socket-close :before ((usocket usocket))
+ (when (wait-list usocket)
+ (remove-waiter (wait-list usocket) usocket)))
+
+(defmethod socket-close ((usocket stream-server-usocket))
+ (with-mapped-conditions (usocket)
+ (jcall $@close/ServerSocket/0 (socket usocket))))
+
+(defmethod socket-close ((usocket stream-usocket))
+ (with-mapped-conditions (usocket)
+ (close (socket-stream usocket))
+ (jcall $@close/Socket/0 (socket usocket))))
+
+(defmethod socket-close ((usocket datagram-usocket))
+ (with-mapped-conditions (usocket)
+ (jcall $@close/DatagramSocket/0 (socket usocket))))
+
+(defmethod socket-shutdown ((usocket stream-usocket) direction)
+ (with-mapped-conditions (usocket)
+ (ecase direction
+ (:input
+ (jcall $@shutdownInput/Socket/0 (socket usocket)))
+ (:output
+ (jcall $@shutdownOutput/Socket/0 (socket usocket))))))
+
+;;; GET-LOCAL/PEER-NAME/ADDRESS/PORT
+
+(defmethod get-local-name ((usocket usocket))
+ (values (get-local-address usocket)
+ (get-local-port usocket)))
+
+(defmethod get-peer-name ((usocket usocket))
+ (values (get-peer-address usocket)
+ (get-peer-port usocket)))
+
+(defmethod get-local-address ((usocket stream-usocket))
+ (get-address (jcall $@getLocalAddress/Socket/0 (socket usocket))))
+
+(defmethod get-local-address ((usocket stream-server-usocket))
+ (get-address (jcall $@getInetAddress/ServerSocket/0 (socket usocket))))
+
+(defmethod get-local-address ((usocket datagram-usocket))
+ (get-address (jcall $@getLocalAddress/DatagramSocket/0 (socket usocket))))
+
+(defmethod get-peer-address ((usocket stream-usocket))
+ (get-address (jcall $@getInetAddress/Socket/0 (socket usocket))))
+
+(defmethod get-peer-address ((usocket datagram-usocket))
+ (get-address (jcall $@getInetAddress/DatagramSocket/0 (socket usocket))))
+
+(defmethod get-local-port ((usocket stream-usocket))
+ (jcall $@getLocalPort/Socket/0 (socket usocket)))
+
+(defmethod get-local-port ((usocket stream-server-usocket))
+ (jcall $@getLocalPort/ServerSocket/0 (socket usocket)))
+
+(defmethod get-local-port ((usocket datagram-usocket))
+ (jcall $@getLocalPort/DatagramSocket/0 (socket usocket)))
+
+(defmethod get-peer-port ((usocket stream-usocket))
+ (jcall $@getPort/Socket/0 (socket usocket)))
+
+(defmethod get-peer-port ((usocket datagram-usocket))
+ (jcall $@getPort/DatagramSocket/0 (socket usocket)))
+
+;;; SOCKET-SEND & SOCKET-RECEIVE
+
+(defun *->byte (data)
+ (declare (type (unsigned-byte 8) data)) ; required by SOCKET-SEND
+ (jnew $%Byte/0 (if (> data 127) (- data 256) data)))
+
+(defun byte->* (byte &optional (element-type '(unsigned-byte 8)))
+ (let* ((ub8 (if (minusp byte) (+ 256 byte) byte)))
+ (if (eq element-type 'character)
+ (code-char ub8)
+ ub8)))
+
+(defmethod socket-send ((usocket datagram-usocket) buffer size &key host port (offset 0))
+ (let* ((socket (socket usocket))
+ (byte-array (jnew-array $*byte size))
+ (packet (if (and host port)
+ (jnew $%DatagramPacket/5 byte-array 0 size (host-to-inet4 host) port)
+ (jnew $%DatagramPacket/3 byte-array 0 size))))
+ ;; prepare sending data
+ (loop for i from offset below (+ size offset)
+ do (setf (jarray-ref byte-array i) (*->byte (aref buffer i))))
+ (with-mapped-conditions (usocket)
+ (jcall $@send/1 socket packet))))
+
+;;; TODO: return-host and return-port cannot be get ...
+(defmethod socket-receive ((usocket datagram-usocket) buffer length
+ &key (element-type '(unsigned-byte 8)))
+ (declare (values (simple-array (unsigned-byte 8) (*)) ; buffer
+ (integer 0) ; size
+ (unsigned-byte 32) ; host
+ (unsigned-byte 16))) ; port
+ (let* ((socket (socket usocket))
+ (real-length (or length +max-datagram-packet-size+))
+ (byte-array (jnew-array $*byte real-length))
+ (packet (jnew $%DatagramPacket/3 byte-array 0 real-length)))
+ (with-mapped-conditions (usocket)
+ (jcall $@receive/1 socket packet))
+ (let* ((receive-length (jcall $@getLength/DatagramPacket/0 packet))
+ (return-buffer (or buffer (make-array receive-length :element-type element-type))))
+ (loop for i from 0 below receive-length
+ do (setf (aref return-buffer i)
+ (byte->* (jarray-ref byte-array i) element-type)))
+ (let ((return-host (if (connected-p usocket)
+ (get-peer-address usocket)
+ (get-address (jcall $@getAddress/DatagramPacket/0 packet))))
+ (return-port (if (connected-p usocket)
+ (get-peer-port usocket)
+ (jcall $@getPort/DatagramPacket/0 packet))))
+ (values return-buffer
+ receive-length
+ return-host
+ return-port)))))
+
+;;; WAIT-FOR-INPUT
+
+(defun socket-channel-class (usocket)
+ (cond ((stream-usocket-p usocket) $*SocketChannel)
+ ((stream-server-usocket-p usocket) $*ServerSocketChannel)
+ ((datagram-usocket-p usocket) $*DatagramChannel)))
+
+(defun get-socket-channel (usocket)
+ (let ((method (cond ((stream-usocket-p usocket) $@getChannel/Socket/0)
+ ((stream-server-usocket-p usocket) $@getChannel/ServerSocket/0)
+ ((datagram-usocket-p usocket) $@getChannel/DatagramSocket/0))))
+ (jcall method (socket usocket))))
+
+(defun wait-for-input-internal (wait-list &key timeout)
+ (let* ((sockets (wait-list-waiters wait-list))
+ (ops (logior $+op-read $+op-accept))
+ (selector (jstatic $@open/Selector/0 $*Selector))
+ (channels (mapcar #'get-socket-channel sockets)))
+ (unwind-protect
+ (with-mapped-conditions ()
+ (dolist (channel channels)
+ (jcall $@configureBlocking/1 channel java:+false+)
+ (jcall $@register/2 channel selector (logand ops (jcall $@validOps/0 channel))))
+ (let ((ready-count (if timeout
+ (jcall $@select/1 selector (truncate (* timeout 1000)))
+ (jcall $@select/0 selector))))
+ (when (plusp ready-count)
+ (let* ((keys (jcall $@selectedKeys/0 selector))
+ (iterator (jcall $@iterator/0 keys))
+ (%wait (wait-list-%wait wait-list)))
+ (loop while (jcall $@hasNext/0 iterator)
+ do (let* ((key (jcall $@next/0 iterator))
+ (channel (jcall $@channel/0 key)))
+ (setf (state (gethash channel %wait)) :read)))))))
+ (jcall $@close/Selector/0 selector)
+ (dolist (channel channels)
+ (jcall $@configureBlocking/1 channel java:+true+)))))
+
+;;; WAIT-LIST
+
+;;; NOTE from original worker (Erik):
+;;; Note that even though Java has the concept of the Selector class, which
+;;; remotely looks like a wait-list, it requires the sockets to be non-blocking.
+;;; usocket however doesn't make any such guarantees and is therefore unable to
+;;; use the concept outside of the waiting routine itself (blergh!).
+
+(defun %setup-wait-list (wl)
+ (setf (wait-list-%wait wl)
+ (make-hash-table :test #'equal :rehash-size 1.3d0)))
+
+(defun %add-waiter (wl w)
+ (setf (gethash (get-socket-channel w) (wait-list-%wait wl)) w))
+
+(defun %remove-waiter (wl w)
+ (remhash (get-socket-channel w) (wait-list-%wait wl)))
--- /dev/null
+;;;; See LICENSE for licensing information.
+
+(in-package :usocket)
+
+#+cormanlisp
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (require :acl-socket))
+
+#+allegro
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (require :sock)
+ ;; for wait-for-input:
+ (require :process)
+ ;; note: the line below requires ACL 6.2+
+ (require :osi))
+
+(defun get-host-name ()
+ ;; note: the line below requires ACL 7.0+ to actually *work* on windows
+ #+allegro (excl.osi:gethostname)
+ #+cormanlisp "")
+
+(defparameter +allegro-identifier-error-map+
+ '((:address-in-use . address-in-use-error)
+ (:address-not-available . address-not-available-error)
+ (:network-down . network-down-error)
+ (:network-reset . network-reset-error)
+ (:network-unreachable . network-unreachable-error)
+ (:connection-aborted . connection-aborted-error)
+ (:connection-reset . connection-reset-error)
+ (:no-buffer-space . no-buffers-error)
+ (:shutdown . shutdown-error)
+ (:connection-timed-out . timeout-error)
+ (:connection-refused . connection-refused-error)
+ (:host-down . host-down-error)
+ (:host-unreachable . host-unreachable-error)))
+
+(defun handle-condition (condition &optional (socket nil))
+ "Dispatch correct usocket condition."
+ (typecase condition
+ #+allegro
+ (excl:socket-error
+ (let ((usock-err
+ (cdr (assoc (excl:stream-error-identifier condition)
+ +allegro-identifier-error-map+))))
+ (if usock-err
+ (error usock-err :socket socket)
+ (error 'unknown-error
+ :real-error condition
+ :socket socket))))))
+
+(defun to-format (element-type)
+ (if (subtypep element-type 'character)
+ :text
+ :binary))
+
+(defun socket-connect (host port &key (protocol :stream) (element-type 'character)
+ timeout deadline
+ (nodelay t) ;; nodelay == t is the ACL default
+ local-host local-port)
+ (when timeout (unsupported 'timeout 'socket-connect))
+ (when deadline (unsupported 'deadline 'socket-connect))
+ (when (eq nodelay :if-supported)
+ (setf nodelay t))
+
+ (let ((socket))
+ (setf socket
+ (with-mapped-conditions (socket)
+ (ecase protocol
+ (:stream
+ (labels ((make-socket ()
+ (socket:make-socket :remote-host (host-to-hostname host)
+ :remote-port port
+ :local-host (when local-host
+ (host-to-hostname local-host))
+ :local-port local-port
+ :format (to-format element-type)
+ :nodelay nodelay)))
+ #+allegro
+ (if timeout
+ (mp:with-timeout (timeout nil)
+ (make-socket))
+ (make-socket))
+ #+cormanlisp (make-socket)))
+ (:datagram
+ (apply #'socket:make-socket
+ (nconc (list :type protocol
+ :address-family :internet
+ :local-host (when local-host
+ (host-to-hostname local-host))
+ :local-port local-port
+ :format (to-format element-type))
+ (if (and host port)
+ (list :connect :active
+ :remote-host (host-to-hostname host)
+ :remote-port port)
+ (list :connect :passive))))))))
+ (ecase protocol
+ (:stream
+ (make-stream-socket :socket socket :stream socket))
+ (:datagram
+ (make-datagram-socket socket :connected-p (and host port t))))))
+
+;; One socket close method is sufficient,
+;; because socket-streams are also sockets.
+(defmethod socket-close ((usocket usocket))
+ "Close socket."
+ (when (wait-list usocket)
+ (remove-waiter (wait-list usocket) usocket))
+ (with-mapped-conditions (usocket)
+ (close (socket usocket))))
+
+(defmethod socket-shutdown ((usocket stream-usocket) direction)
+ (with-mapped-conditions (usocket)
+ (socket:shutdown (socket usocket) :direction direction)))
+
+(defun socket-listen (host port
+ &key reuseaddress
+ (reuse-address nil reuse-address-supplied-p)
+ (backlog 5)
+ (element-type 'character))
+ ;; Allegro and OpenMCL socket interfaces bear very strong resemblence
+ ;; whatever you change here, change it also for OpenMCL
+ (let* ((reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress))
+ (sock (with-mapped-conditions ()
+ (apply #'socket:make-socket
+ (append (list :connect :passive
+ :reuse-address reuseaddress
+ :local-port port
+ :backlog backlog
+ :format (to-format element-type)
+ ;; allegro now ignores :format
+ )
+ (when (ip/= host *wildcard-host*)
+ (list :local-host host)))))))
+ (make-stream-server-socket sock :element-type element-type)))
+
+(defmethod socket-accept ((socket stream-server-usocket) &key element-type)
+ (declare (ignore element-type)) ;; allegro streams are multivalent
+ (let ((stream-sock
+ (with-mapped-conditions (socket)
+ (socket:accept-connection (socket socket)))))
+ (make-stream-socket :socket stream-sock :stream stream-sock)))
+
+(defmethod get-local-address ((usocket usocket))
+ (hbo-to-vector-quad (socket:local-host (socket usocket))))
+
+(defmethod get-peer-address ((usocket stream-usocket))
+ (hbo-to-vector-quad (socket:remote-host (socket usocket))))
+
+(defmethod get-local-port ((usocket usocket))
+ (socket:local-port (socket usocket)))
+
+(defmethod get-peer-port ((usocket stream-usocket))
+ #+allegro
+ (socket:remote-port (socket usocket)))
+
+(defmethod get-local-name ((usocket usocket))
+ (values (get-local-address usocket)
+ (get-local-port usocket)))
+
+(defmethod get-peer-name ((usocket stream-usocket))
+ (values (get-peer-address usocket)
+ (get-peer-port usocket)))
+
+#+allegro
+(defmethod socket-send ((usocket datagram-usocket) buffer size &key host port (offset 0))
+ (with-mapped-conditions (usocket)
+ (let ((s (socket usocket)))
+ (socket:send-to s
+ (if (zerop offset)
+ buffer
+ (subseq buffer offset (+ offset size)))
+ size
+ :remote-host host
+ :remote-port port))))
+
+#+allegro
+(defmethod socket-receive ((socket datagram-usocket) buffer length &key)
+ (declare (values (simple-array (unsigned-byte 8) (*)) ; buffer
+ (integer 0) ; size
+ (unsigned-byte 32) ; host
+ (unsigned-byte 16))) ; port
+ (with-mapped-conditions (socket)
+ (let ((s (socket socket)))
+ (socket:receive-from s length :buffer buffer :extract t))))
+
+(defun get-host-by-address (address)
+ (with-mapped-conditions ()
+ (socket:ipaddr-to-hostname (host-to-hbo address))))
+
+(defun get-hosts-by-name (name)
+ ;;###FIXME: ACL has the acldns module which returns all A records
+ ;; only problem: it doesn't fall back to tcp (from udp) if the returned
+ ;; structure is too long.
+ (with-mapped-conditions ()
+ (list (hbo-to-vector-quad (socket:lookup-hostname
+ (host-to-hostname name))))))
+
+(defun %setup-wait-list (wait-list)
+ (declare (ignore wait-list)))
+
+(defun %add-waiter (wait-list waiter)
+ (push (socket waiter) (wait-list-%wait wait-list)))
+
+(defun %remove-waiter (wait-list waiter)
+ (setf (wait-list-%wait wait-list)
+ (remove (socket waiter) (wait-list-%wait wait-list))))
+
+#+allegro
+(defun wait-for-input-internal (wait-list &key timeout)
+ (with-mapped-conditions ()
+ (let ((active-internal-sockets
+ (if timeout
+ (mp:wait-for-input-available (wait-list-%wait wait-list)
+ :timeout timeout)
+ (mp:wait-for-input-available (wait-list-%wait wait-list)))))
+ ;; this is quadratic, but hey, the active-internal-sockets
+ ;; list is very short and it's only quadratic in the length of that one.
+ ;; When I have more time I could recode it to something of linear
+ ;; complexity.
+ ;; [Same code is also used in openmcl.lisp]
+ (dolist (x active-internal-sockets)
+ (setf (state (gethash x (wait-list-map wait-list)))
+ :read))
+ wait-list)))
--- /dev/null
+;;;; $Id$
+;;;; $URL$
+
+;;;; See LICENSE for licensing information.
+
+(in-package :usocket)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ #-ffi
+ (warn "This image doesn't contain FFI package, GET-HOST-NAME won't work.")
+ #-(or ffi rawsock)
+ (warn "This image doesn't contain either FFI or RAWSOCK package, no UDP support."))
+
+;; utility routine for looking up the current host name
+#+ffi
+(ffi:def-call-out get-host-name-internal
+ (:name "gethostname")
+ (:arguments (name (FFI:C-PTR (FFI:C-ARRAY-MAX ffi:character 256))
+ :OUT :ALLOCA)
+ (len ffi:int))
+ #+win32 (:library "WS2_32")
+ #-win32 (:library :default)
+ (:language #-win32 :stdc
+ #+win32 :stdc-stdcall)
+ (:return-type ffi:int))
+
+(defun get-host-name ()
+ #+ffi
+ (multiple-value-bind (retcode name)
+ (get-host-name-internal 256)
+ (when (= retcode 0)
+ name))
+ #-ffi
+ "localhost")
+
+(defun get-host-by-address (address)
+ (with-mapped-conditions ()
+ (let ((hostent (posix:resolve-host-ipaddr (host-to-hostname address))))
+ (posix:hostent-name hostent))))
+
+(defun get-hosts-by-name (name)
+ (with-mapped-conditions ()
+ (let ((hostent (posix:resolve-host-ipaddr name)))
+ (mapcar #'host-to-vector-quad
+ (posix:hostent-addr-list hostent)))))
+
+;; Format: ((UNIX Windows) . CONDITION)
+(defparameter +clisp-error-map+
+ #-win32
+ `((:EADDRINUSE . address-in-use-error)
+ (:EADDRNOTAVAIL . address-not-available-error)
+ (:EBADF . bad-file-descriptor-error)
+ (:ECONNREFUSED . connection-refused-error)
+ (:ECONNRESET . connection-reset-error)
+ (:ECONNABORTED . connection-aborted-error)
+ (:EINVAL . invalid-argument-error)
+ (:ENOBUFS . no-buffers-error)
+ (:ENOMEM . out-of-memory-error)
+ (:ENOTSUP . operation-not-supported-error)
+ (:EPERM . operation-not-permitted-error)
+ (:EPROTONOSUPPORT . protocol-not-supported-error)
+ (:ESOCKTNOSUPPORT . socket-type-not-supported-error)
+ (:ENETUNREACH . network-unreachable-error)
+ (:ENETDOWN . network-down-error)
+ (:ENETRESET . network-reset-error)
+ (:ESHUTDOWN . already-shutdown-error)
+ (:ETIMEDOUT . timeout-error)
+ (:EHOSTDOWN . host-down-error)
+ (:EHOSTUNREACH . host-unreachable-error))
+ #+win32
+ `((:WSAEADDRINUSE . address-in-use-error)
+ (:WSAEADDRNOTAVAIL . address-not-available-error)
+ (:WSAEBADF . bad-file-descriptor-error)
+ (:WSAECONNREFUSED . connection-refused-error)
+ (:WSAECONNRESET . connection-reset-error)
+ (:WSAECONNABORTED . connection-aborted-error)
+ (:WSAEINVAL . invalid-argument-error)
+ (:WSAENOBUFS . no-buffers-error)
+ (:WSAENOMEM . out-of-memory-error)
+ (:WSAENOTSUP . operation-not-supported-error)
+ (:WSAEPERM . operation-not-permitted-error)
+ (:WSAEPROTONOSUPPORT . protocol-not-supported-error)
+ (:WSAESOCKTNOSUPPORT . socket-type-not-supported-error)
+ (:WSAENETUNREACH . network-unreachable-error)
+ (:WSAENETDOWN . network-down-error)
+ (:WSAENETRESET . network-reset-error)
+ (:WSAESHUTDOWN . already-shutdown-error)
+ (:WSAETIMEDOUT . timeout-error)
+ (:WSAEHOSTDOWN . host-down-error)
+ (:WSAEHOSTUNREACH . host-unreachable-error)))
+
+(defun handle-condition (condition &optional (socket nil))
+ "Dispatch correct usocket condition."
+ (let (error-keyword error-string)
+ (typecase condition
+ (ext:os-error
+ (let ((errno (car (simple-condition-format-arguments condition))))
+ #+ffi
+ (setq error-keyword (os:errno errno)
+ error-string (os:strerror errno))))
+ (simple-error
+ (let ((keyword
+ (car (simple-condition-format-arguments condition))))
+ (setq error-keyword keyword)
+ #+ffi
+ (setq error-string (os:strerror keyword))))
+ (error (error 'unknown-error :real-error condition))
+ (condition (signal 'unknown-condition :real-condition condition)))
+ (when error-keyword
+ (let ((usocket-error
+ (cdr (assoc error-keyword +clisp-error-map+ :test #'eq))))
+ (if usocket-error
+ (if (subtypep usocket-error 'error)
+ (error usocket-error :socket socket)
+ (signal usocket-error :socket socket))
+ (error "Unknown OS error: ~A (~A)" error-string error-keyword))))))
+
+(defun socket-connect (host port &key (protocol :stream) (element-type 'character)
+ timeout deadline (nodelay t nodelay-specified)
+ local-host local-port)
+ (declare (ignorable timeout local-host local-port))
+ (when deadline (unsupported 'deadline 'socket-connect))
+ (when (and nodelay-specified
+ (not (eq nodelay :if-supported)))
+ (unsupported 'nodelay 'socket-connect))
+ (case protocol
+ (:stream
+ (let ((socket)
+ (hostname (host-to-hostname host)))
+ (with-mapped-conditions (socket)
+ (setf socket
+ (if timeout
+ (socket:socket-connect port hostname
+ :element-type element-type
+ :buffered t
+ :timeout timeout)
+ (socket:socket-connect port hostname
+ :element-type element-type
+ :buffered t))))
+ (make-stream-socket :socket socket
+ :stream socket))) ;; the socket is a stream too
+ (:datagram
+ #+(or rawsock ffi)
+ (socket-create-datagram (or local-port *auto-port*)
+ :local-host (or local-host *wildcard-host*)
+ :remote-host (and host (host-to-vector-quad host))
+ :remote-port port)
+ #-(or rawsock ffi)
+ (unsupported '(protocol :datagram) 'socket-connect))))
+
+(defun socket-listen (host port
+ &key reuseaddress
+ (reuse-address nil reuse-address-supplied-p)
+ (backlog 5)
+ (element-type 'character))
+ ;; clisp 2.39 sets SO_REUSEADDRESS to 1 by default; no need to
+ ;; to explicitly turn it on; unfortunately, there's no way to turn it off...
+ (declare (ignore reuseaddress reuse-address reuse-address-supplied-p))
+ (let ((sock (apply #'socket:socket-server
+ (append (list port
+ :backlog backlog)
+ (when (ip/= host *wildcard-host*)
+ (list :interface host))))))
+ (with-mapped-conditions ()
+ (make-stream-server-socket sock :element-type element-type))))
+
+(defmethod socket-accept ((socket stream-server-usocket) &key element-type)
+ (let ((stream
+ (with-mapped-conditions (socket)
+ (socket:socket-accept (socket socket)
+ :element-type (or element-type
+ (element-type socket))))))
+ (make-stream-socket :socket stream
+ :stream stream)))
+
+;; Only one close method required:
+;; sockets and their associated streams
+;; are the same object
+(defmethod socket-close ((usocket usocket))
+ "Close socket."
+ (when (wait-list usocket)
+ (remove-waiter (wait-list usocket) usocket))
+ (with-mapped-conditions (usocket)
+ (close (socket usocket))))
+
+(defmethod socket-close ((usocket stream-server-usocket))
+ (when (wait-list usocket)
+ (remove-waiter (wait-list usocket) usocket))
+ (socket:socket-server-close (socket usocket)))
+
+(defmethod socket-shutdown ((usocket stream-usocket) direction)
+ (with-mapped-conditions (usocket)
+ (socket:socket-stream-shutdown (socket usocket) direction)))
+
+(defmethod get-local-name ((usocket stream-usocket))
+ (multiple-value-bind
+ (address port)
+ (socket:socket-stream-local (socket usocket) t)
+ (values (dotted-quad-to-vector-quad address) port)))
+
+(defmethod get-local-name ((usocket stream-server-usocket))
+ (values (get-local-address usocket)
+ (get-local-port usocket)))
+
+(defmethod get-peer-name ((usocket stream-usocket))
+ (multiple-value-bind
+ (address port)
+ (socket:socket-stream-peer (socket usocket) t)
+ (values (dotted-quad-to-vector-quad address) port)))
+
+(defmethod get-local-address ((usocket usocket))
+ (nth-value 0 (get-local-name usocket)))
+
+(defmethod get-local-address ((usocket stream-server-usocket))
+ (dotted-quad-to-vector-quad
+ (socket:socket-server-host (socket usocket))))
+
+(defmethod get-peer-address ((usocket usocket))
+ (nth-value 0 (get-peer-name usocket)))
+
+(defmethod get-local-port ((usocket usocket))
+ (nth-value 1 (get-local-name usocket)))
+
+(defmethod get-local-port ((usocket stream-server-usocket))
+ (socket:socket-server-port (socket usocket)))
+
+(defmethod get-peer-port ((usocket usocket))
+ (nth-value 1 (get-peer-name usocket)))
+
+(defun %setup-wait-list (wait-list)
+ (declare (ignore wait-list)))
+
+(defun %add-waiter (wait-list waiter)
+ (push (cons (socket waiter) NIL) (wait-list-%wait wait-list)))
+
+(defun %remove-waiter (wait-list waiter)
+ (setf (wait-list-%wait wait-list)
+ (remove (socket waiter) (wait-list-%wait wait-list) :key #'car)))
+
+(defmethod wait-for-input-internal (wait-list &key timeout)
+ (with-mapped-conditions ()
+ (multiple-value-bind
+ (secs musecs)
+ (split-timeout (or timeout 1))
+ (dolist (x (wait-list-%wait wait-list))
+ (setf (cdr x) :INPUT))
+ (let* ((request-list (wait-list-%wait wait-list))
+ (status-list (if timeout
+ (socket:socket-status request-list secs musecs)
+ (socket:socket-status request-list)))
+ (sockets (wait-list-waiters wait-list)))
+ (do* ((x (pop sockets) (pop sockets))
+ (y (pop status-list) (pop status-list)))
+ ((null x))
+ (when (member y '(T :INPUT))
+ (setf (state x) :READ)))
+ wait-list))))
+
+;;;
+;;; UDP/Datagram sockets (RAWSOCK version)
+;;;
+
+#+rawsock
+(progn
+ (defun make-sockaddr_in ()
+ (make-array 16 :element-type '(unsigned-byte 8) :initial-element 0))
+
+ (declaim (inline fill-sockaddr_in))
+ (defun fill-sockaddr_in (sockaddr_in ip port)
+ (port-to-octet-buffer port sockaddr_in)
+ (ip-to-octet-buffer ip sockaddr_in :start 2)
+ sockaddr_in)
+
+ (defun socket-create-datagram (local-port
+ &key (local-host *wildcard-host*)
+ remote-host
+ remote-port)
+ (let ((sock (rawsock:socket :inet :dgram 0))
+ (lsock_addr (fill-sockaddr_in (make-sockaddr_in)
+ local-host local-port))
+ (rsock_addr (when remote-host
+ (fill-sockaddr_in (make-sockaddr_in)
+ remote-host (or remote-port
+ local-port)))))
+ (rawsock:bind sock (rawsock:make-sockaddr :inet lsock_addr))
+ (when rsock_addr
+ (rawsock:connect sock (rawsock:make-sockaddr :inet rsock_addr)))
+ (make-datagram-socket sock :connected-p (if rsock_addr t nil))))
+
+ (defmethod socket-receive ((socket datagram-usocket) buffer length &key)
+ "Returns the buffer, the number of octets copied into the buffer (received)
+and the address of the sender as values."
+ (let* ((sock (socket socket))
+ (sockaddr (rawsock:make-sockaddr :inet))
+ (real-length (or length +max-datagram-packet-size+))
+ (real-buffer (or buffer
+ (make-array real-length
+ :element-type '(unsigned-byte 8)))))
+ (let ((rv (rawsock:recvfrom sock real-buffer sockaddr
+ :start 0 :end real-length))
+ (host 0) (port 0))
+ (unless (connected-p socket)
+ (let ((data (rawsock:sockaddr-data sockaddr)))
+ (setq host (ip-from-octet-buffer data :start 4)
+ port (port-from-octet-buffer data :start 2))))
+ (values (if buffer real-buffer (subseq real-buffer 0 rv))
+ rv
+ host
+ port))))
+
+ (defmethod socket-send ((socket datagram-usocket) buffer size &key host port (offset 0))
+ "Returns the number of octets sent."
+ (let* ((sock (socket socket))
+ (sockaddr (when (and host port)
+ (rawsock:make-sockaddr :inet
+ (fill-sockaddr_in
+ (make-sockaddr_in)
+ (host-byte-order host)
+ port))))
+ (real-size (min size +max-datagram-packet-size+))
+ (real-buffer (if (typep buffer '(simple-array (unsigned-byte 8) (*)))
+ buffer
+ (make-array real-size
+ :element-type '(unsigned-byte 8)
+ :initial-contents (subseq buffer 0 real-size))))
+ (rv (if (and host port)
+ (rawsock:sendto sock real-buffer sockaddr
+ :start offset
+ :end (+ offset real-size))
+ (rawsock:send sock real-buffer
+ :start offset
+ :end (+ offset real-size)))))
+ rv))
+
+ (defmethod socket-close ((usocket datagram-usocket))
+ (when (wait-list usocket)
+ (remove-waiter (wait-list usocket) usocket))
+ (rawsock:sock-close (socket usocket)))
+
+ (declaim (inline get-socket-name))
+ (defun get-socket-name (socket function)
+ (let ((sockaddr (rawsock:make-sockaddr :inet (make-sockaddr_in))))
+ (funcall function socket sockaddr)
+ (let ((data (rawsock:sockaddr-data sockaddr)))
+ (values (hbo-to-vector-quad (ip-from-octet-buffer data :start 2))
+ (port-from-octet-buffer data :start 0)))))
+
+ (defmethod get-local-name ((usocket datagram-usocket))
+ (get-socket-name (socket usocket) 'rawsock:getsockname))
+
+ (defmethod get-peer-name ((usocket datagram-usocket))
+ (get-socket-name (socket usocket) 'rawsock:getpeername))
+
+) ; progn
+
+;;;
+;;; UDP/Datagram sockets (FFI version)
+;;;
+
+#+(and ffi (not rawsock))
+(progn
+ ;; C primitive types
+ (ffi:def-c-type socklen_t ffi:uint32)
+
+ ;; C structures
+ (ffi:def-c-struct sockaddr
+ #+macos (sa_len ffi:uint8)
+ (sa_family #-macos ffi:ushort
+ #+macos ffi:uint8)
+ (sa_data (ffi:c-array ffi:char 14)))
+
+ (ffi:def-c-struct sockaddr_in
+ #+macos (sin_len ffi:uint8)
+ (sin_family #-macos ffi:short
+ #+macos ffi:uint8)
+ (sin_port #-macos ffi:ushort
+ #+macos ffi:uint16)
+ (sin_addr ffi:uint32)
+ (sin_zero (ffi:c-array ffi:char 8)))
+
+ (ffi:def-c-struct timeval
+ (tv_sec ffi:long)
+ (tv_usec ffi:long))
+
+ ;; foreign functions
+ (ffi:def-call-out %sendto (:name "sendto")
+ (:arguments (socket ffi:int)
+ (buffer ffi:c-pointer)
+ (length ffi:int)
+ (flags ffi:int)
+ (address (ffi:c-ptr sockaddr))
+ (address-len ffi:int))
+ #+win32 (:library "WS2_32")
+ #-win32 (:library :default)
+ (:language #-win32 :stdc
+ #+win32 :stdc-stdcall)
+ (:return-type ffi:int))
+
+ (ffi:def-call-out %send (:name "send")
+ (:arguments (socket ffi:int)
+ (buffer ffi:c-pointer)
+ (length ffi:int)
+ (flags ffi:int))
+ #+win32 (:library "WS2_32")
+ #-win32 (:library :default)
+ (:language #-win32 :stdc
+ #+win32 :stdc-stdcall)
+ (:return-type ffi:int))
+
+ (ffi:def-call-out %recvfrom (:name "recvfrom")
+ (:arguments (socket ffi:int)
+ (buffer ffi:c-pointer)
+ (length ffi:int)
+ (flags ffi:int)
+ (address (ffi:c-ptr sockaddr) :in-out)
+ (address-len (ffi:c-ptr ffi:int) :in-out))
+ #+win32 (:library "WS2_32")
+ #-win32 (:library :default)
+ (:language #-win32 :stdc
+ #+win32 :stdc-stdcall)
+ (:return-type ffi:int))
+
+ (ffi:def-call-out %socket (:name "socket")
+ (:arguments (family ffi:int)
+ (type ffi:int)
+ (protocol ffi:int))
+ #+win32 (:library "WS2_32")
+ #-win32 (:library :default)
+ (:language #-win32 :stdc
+ #+win32 :stdc-stdcall)
+ (:return-type ffi:int))
+
+ (ffi:def-call-out %connect (:name "connect")
+ (:arguments (socket ffi:int)
+ (address (ffi:c-ptr sockaddr) :in)
+ (address_len socklen_t))
+ #+win32 (:library "WS2_32")
+ #-win32 (:library :default)
+ (:language #-win32 :stdc
+ #+win32 :stdc-stdcall)
+ (:return-type ffi:int))
+
+ (ffi:def-call-out %bind (:name "bind")
+ (:arguments (socket ffi:int)
+ (address (ffi:c-ptr sockaddr) :in)
+ (address_len socklen_t))
+ #+win32 (:library "WS2_32")
+ #-win32 (:library :default)
+ (:language #-win32 :stdc
+ #+win32 :stdc-stdcall)
+ (:return-type ffi:int))
+
+ (ffi:def-call-out %close (:name #-win32 "close" #+win32 "closesocket")
+ (:arguments (socket ffi:int))
+ #+win32 (:library "WS2_32")
+ #-win32 (:library :default)
+ (:language #-win32 :stdc
+ #+win32 :stdc-stdcall)
+ (:return-type ffi:int))
+
+ (ffi:def-call-out %getsockopt (:name "getsockopt")
+ (:arguments (sockfd ffi:int)
+ (level ffi:int)
+ (optname ffi:int)
+ (optval ffi:c-pointer)
+ (optlen (ffi:c-ptr socklen_t) :out))
+ #+win32 (:library "WS2_32")
+ #-win32 (:library :default)
+ (:language #-win32 :stdc
+ #+win32 :stdc-stdcall)
+ (:return-type ffi:int))
+
+ (ffi:def-call-out %setsockopt (:name "setsockopt")
+ (:arguments (sockfd ffi:int)
+ (level ffi:int)
+ (optname ffi:int)
+ (optval ffi:c-pointer)
+ (optlen socklen_t))
+ #+win32 (:library "WS2_32")
+ #-win32 (:library :default)
+ (:language #-win32 :stdc
+ #+win32 :stdc-stdcall)
+ (:return-type ffi:int))
+
+ (ffi:def-call-out %htonl (:name "htonl")
+ (:arguments (hostlong ffi:uint32))
+ #+win32 (:library "WS2_32")
+ #-win32 (:library :default)
+ (:language #-win32 :stdc
+ #+win32 :stdc-stdcall)
+ (:return-type ffi:uint32))
+
+ (ffi:def-call-out %htons (:name "htons")
+ (:arguments (hostshort ffi:uint16))
+ #+win32 (:library "WS2_32")
+ #-win32 (:library :default)
+ (:language #-win32 :stdc
+ #+win32 :stdc-stdcall)
+ (:return-type ffi:uint16))
+
+ (ffi:def-call-out %ntohl (:name "ntohl")
+ (:arguments (netlong ffi:uint32))
+ #+win32 (:library "WS2_32")
+ #-win32 (:library :default)
+ (:language #-win32 :stdc
+ #+win32 :stdc-stdcall)
+ (:return-type ffi:uint32))
+
+ (ffi:def-call-out %ntohs (:name "ntohs")
+ (:arguments (netshort ffi:uint16))
+ #+win32 (:library "WS2_32")
+ #-win32 (:library :default)
+ (:language #-win32 :stdc
+ #+win32 :stdc-stdcall)
+ (:return-type ffi:uint16))
+
+ (ffi:def-call-out %getsockname (:name "getsockname")
+ (:arguments (sockfd ffi:int)
+ (localaddr (ffi:c-ptr sockaddr) :in-out)
+ (addrlen (ffi:c-ptr socklen_t) :in-out))
+ #+win32 (:library "WS2_32")
+ #-win32 (:library :default)
+ (:language #-win32 :stdc
+ #+win32 :stdc-stdcall)
+ (:return-type ffi:int))
+
+ (ffi:def-call-out %getpeername (:name "getpeername")
+ (:arguments (sockfd ffi:int)
+ (peeraddr (ffi:c-ptr sockaddr) :in-out)
+ (addrlen (ffi:c-ptr socklen_t) :in-out))
+ #+win32 (:library "WS2_32")
+ #-win32 (:library :default)
+ (:language #-win32 :stdc
+ #+win32 :stdc-stdcall)
+ (:return-type ffi:int))
+
+ ;; socket constants
+ (defconstant +socket-af-inet+ 2)
+ (defconstant +socket-sock-dgram+ 2)
+ (defconstant +socket-ip-proto-udp+ 17)
+
+ (defconstant +sockopt-so-rcvtimeo+ #-linux #x1006 #+linux 20 "Socket receive timeout")
+
+ (defparameter *length-of-sockaddr_in* (ffi:sizeof 'sockaddr_in))
+
+ (declaim (inline fill-sockaddr_in))
+ (defun fill-sockaddr_in (sockaddr host port)
+ (let ((hbo (host-to-hbo host)))
+ (ffi:with-c-place (place sockaddr)
+ #+macos
+ (setf (ffi:slot place 'sin_len) *length-of-sockaddr_in*)
+ (setf (ffi:slot place 'sin_family) +socket-af-inet+
+ (ffi:slot place 'sin_port) (%htons port)
+ (ffi:slot place 'sin_addr) (%htonl hbo)))
+ sockaddr))
+
+ (defun socket-create-datagram (local-port
+ &key (local-host *wildcard-host*)
+ remote-host
+ remote-port)
+ (let ((sock (%socket +socket-af-inet+ +socket-sock-dgram+ +socket-ip-proto-udp+))
+ (lsock_addr (fill-sockaddr_in (ffi:allocate-shallow 'sockaddr_in)
+ local-host local-port))
+ (rsock_addr (when remote-host
+ (fill-sockaddr_in (ffi:allocate-shallow 'sockaddr_in)
+ remote-host (or remote-port local-port)))))
+ (unless (plusp sock)
+ (error "SOCKET-CREATE-DATAGRAM ERROR (socket): ~A" (os:errno)))
+ (unwind-protect
+ (let ((rv (%bind sock (ffi:cast (ffi:foreign-value lsock_addr) 'sockaddr)
+ *length-of-sockaddr_in*)))
+ (unless (zerop rv)
+ (error "SOCKET-CREATE-DATAGRAM ERROR (bind): ~A" (os:errno)))
+ (when rsock_addr
+ (let ((rv (%connect sock
+ (ffi:cast (ffi:foreign-value rsock_addr) 'sockaddr)
+ *length-of-sockaddr_in*)))
+ (unless (zerop rv)
+ (error "SOCKET-CREATE-DATAGRAM ERROR (connect): ~A" (os:errno))))))
+ (ffi:foreign-free lsock_addr)
+ (when remote-host
+ (ffi:foreign-free rsock_addr)))
+ (make-datagram-socket sock :connected-p (if rsock_addr t nil))))
+
+ (defun finalize-datagram-usocket (object)
+ (when (datagram-usocket-p object)
+ (socket-close object)))
+
+ (defmethod initialize-instance :after ((usocket datagram-usocket) &key)
+ (setf (slot-value usocket 'recv-buffer)
+ (ffi:allocate-shallow 'ffi:uint8 :count +max-datagram-packet-size+))
+ ;; finalize the object
+ (ext:finalize usocket 'finalize-datagram-usocket))
+
+ (defmethod socket-close ((usocket datagram-usocket))
+ (when (wait-list usocket)
+ (remove-waiter (wait-list usocket) usocket))
+ (with-slots (recv-buffer socket) usocket
+ (ffi:foreign-free recv-buffer)
+ (zerop (%close socket))))
+
+ (defmethod socket-receive ((usocket datagram-usocket) buffer length &key)
+ (let ((remote-address (ffi:allocate-shallow 'sockaddr_in))
+ (remote-address-length (ffi:allocate-shallow 'ffi:int))
+ nbytes (host 0) (port 0))
+ (setf (ffi:foreign-value remote-address-length)
+ *length-of-sockaddr_in*)
+ (unwind-protect
+ (multiple-value-bind (n address address-length)
+ (%recvfrom (socket usocket)
+ (ffi:foreign-address (slot-value usocket 'recv-buffer))
+ +max-datagram-packet-size+
+ 0 ; flags
+ (ffi:cast (ffi:foreign-value remote-address) 'sockaddr)
+ (ffi:foreign-value remote-address-length))
+ (when (minusp n)
+ (error "SOCKET-RECEIVE ERROR: ~A" (os:errno)))
+ (setq nbytes n)
+ (when (= address-length *length-of-sockaddr_in*)
+ (let ((data (sockaddr-sa_data address)))
+ (setq host (ip-from-octet-buffer data :start 2)
+ port (port-from-octet-buffer data))))
+ (cond ((plusp n)
+ (let ((return-buffer (ffi:foreign-value (slot-value usocket 'recv-buffer))))
+ (if buffer ; replace exist buffer of create new return buffer
+ (let ((end-1 (min (or length (length buffer)) +max-datagram-packet-size+))
+ (end-2 (min n +max-datagram-packet-size+)))
+ (replace buffer return-buffer :end1 end-1 :end2 end-2))
+ (setq buffer (subseq return-buffer 0 (min n +max-datagram-packet-size+))))))
+ ((zerop n))))
+ (ffi:foreign-free remote-address)
+ (ffi:foreign-free remote-address-length))
+ (values buffer nbytes host port)))
+
+ ;; implementation note: different from socket-receive, we know how many bytes we want to send everytime,
+ ;; so, a send buffer will not needed, and if there is a buffer, it's hard to fill its content like those
+ ;; in LispWorks. So, we allocate new foreign buffer for holding data (unknown sequence subtype) every time.
+ ;;
+ ;; I don't know if anyone is watching my coding work, but I think this design is reasonable for CLISP.
+ (defmethod socket-send ((usocket datagram-usocket) buffer size &key host port (offset 0))
+ (declare (type sequence buffer)
+ (type (integer 0 *) size offset))
+ (let ((remote-address
+ (when (and host port)
+ (fill-sockaddr_in (ffi:allocate-shallow 'sockaddr_in) host port)))
+ (send-buffer
+ (ffi:allocate-deep 'ffi:uint8
+ (if (zerop offset)
+ buffer
+ (subseq buffer offset (+ offset size)))
+ :count size :read-only t))
+ (real-size (min size +max-datagram-packet-size+))
+ (nbytes 0))
+ (unwind-protect
+ (let ((n (if remote-address
+ (%sendto (socket usocket)
+ (ffi:foreign-address send-buffer)
+ real-size
+ 0 ; flags
+ (ffi:cast (ffi:foreign-value remote-address) 'sockaddr)
+ *length-of-sockaddr_in*)
+ (%send (socket usocket)
+ (ffi:foreign-address send-buffer)
+ real-size
+ 0))))
+ (cond ((plusp n)
+ (setq nbytes n))
+ ((zerop n)
+ (setq nbytes n))
+ (t (error "SOCKET-SEND ERROR: ~A" (os:errno)))))
+ (ffi:foreign-free send-buffer)
+ (when remote-address
+ (ffi:foreign-free remote-address))
+ nbytes)))
+
+ (declaim (inline get-socket-name))
+ (defun get-socket-name (socket function)
+ (let ((address (ffi:allocate-shallow 'sockaddr_in))
+ (address-length (ffi:allocate-shallow 'ffi:int))
+ (host 0) (port 0))
+ (setf (ffi:foreign-value address-length) *length-of-sockaddr_in*)
+ (unwind-protect
+ (multiple-value-bind (rv return-address return-address-length)
+ (funcall function socket
+ (ffi:cast (ffi:foreign-value address) 'sockaddr)
+ (ffi:foreign-value address-length))
+ (declare (ignore return-address-length))
+ (if (zerop rv)
+ (let ((data (sockaddr-sa_data return-address)))
+ (setq host (ip-from-octet-buffer data :start 2)
+ port (port-from-octet-buffer data)))
+ (error "GET-SOCKET-NAME ERROR: ~A" (os:errno))))
+ (ffi:foreign-free address)
+ (ffi:foreign-free address-length))
+ (values (hbo-to-vector-quad host) port)))
+
+ (defmethod get-local-name ((usocket datagram-usocket))
+ (get-socket-name (socket usocket) '%getsockname))
+
+ (defmethod get-peer-name ((usocket datagram-usocket))
+ (get-socket-name (socket usocket) '%getpeername))
+
+) ; progn
--- /dev/null
+;;;; See LICENSE for licensing information.
+
+;;;; Functions for CCL 1.11 (IPv6) only, see openmcl.lisp for rest of functions.
+
+(in-package :usocket)
+
+#+ipv6
+(defun socket-connect (host port &key (protocol :stream) element-type
+ timeout deadline nodelay
+ local-host local-port)
+ (when (eq nodelay :if-supported)
+ (setf nodelay t))
+ (with-mapped-conditions ()
+ (let* ((remote (when (and host port)
+ (openmcl-socket:resolve-address :host (host-to-hostname host)
+ :port port
+ :socket-type protocol)))
+ (local (when (and local-host local-port)
+ (openmcl-socket:resolve-address :host (host-to-hostname local-host)
+ :port local-port
+ :socket-type protocol)))
+ (mcl-sock (apply #'openmcl-socket:make-socket
+ `(:type ,protocol
+ ,@(when (or remote local)
+ `(:address-family ,(openmcl-socket:socket-address-family (or remote local))))
+ ,@(when remote
+ `(:remote-address ,remote))
+ ,@(when local
+ `(:local-address ,local))
+ :format ,(to-format element-type protocol)
+ :external-format ,ccl:*default-external-format*
+ :deadline ,deadline
+ :nodelay ,nodelay
+ :connect-timeout ,timeout
+ :input-timeout ,timeout))))
+ (ecase protocol
+ (:stream
+ (make-stream-socket :stream mcl-sock :socket mcl-sock))
+ (:datagram
+ (make-datagram-socket mcl-sock :connected-p (and remote t)))))))
+
+#+ipv6
+(defun socket-listen (host port
+ &key
+ (reuse-address nil reuse-address-supplied-p)
+ (reuseaddress (when reuse-address-supplied-p reuse-address))
+ (backlog 5)
+ (element-type 'character))
+ (let ((local-address (openmcl-socket:resolve-address :host (host-to-hostname host)
+ :port port :connect :passive)))
+ (with-mapped-conditions ()
+ (make-stream-server-socket
+ (openmcl-socket:make-socket :connect :passive
+ :address-family (openmcl-socket:socket-address-family local-address)
+ :local-address local-address
+ :reuse-address reuseaddress
+ :backlog backlog
+ :format (to-format element-type :stream))
+ :element-type element-type))))
+
+#+ipv6
+(defmethod socket-send ((usocket datagram-usocket) buffer size &key host port (offset 0))
+ (let* ((ccl-socket (socket usocket))
+ (socket-keys (ccl::socket-keys ccl-socket)))
+ (with-mapped-conditions (usocket)
+ (if (and host port)
+ (openmcl-socket:send-to ccl-socket buffer size
+ :remote-host (host-to-hostname host)
+ :remote-port port
+ :offset offset)
+ (openmcl-socket:send-to ccl-socket buffer size
+ :remote-address (getf socket-keys :remote-address)
+ :offset offset)))))
--- /dev/null
+;;;; $Id$
+;;;; $URL$
+
+;;;; See LICENSE for licensing information.
+
+(in-package :usocket)
+
+#+win32
+(defun remap-for-win32 (z)
+ (mapcar #'(lambda (x)
+ (cons (mapcar #'(lambda (y)
+ (+ 10000 y))
+ (car x))
+ (cdr x)))
+ z))
+
+(defparameter +cmucl-error-map+
+ #+win32
+ (append (remap-for-win32 +unix-errno-condition-map+)
+ (remap-for-win32 +unix-errno-error-map+))
+ #-win32
+ (append +unix-errno-condition-map+
+ +unix-errno-error-map+))
+
+(defun cmucl-map-socket-error (err &key condition socket)
+ (let ((usock-err
+ (cdr (assoc err +cmucl-error-map+ :test #'member))))
+ (if usock-err
+ (if (subtypep usock-err 'error)
+ (error usock-err :socket socket)
+ (signal usock-err :socket socket))
+ (error 'unknown-error
+ :socket socket
+ :real-error condition))))
+
+;; CMUCL error handling is brain-dead: it doesn't preserve any
+;; information other than the OS error string from which the
+;; error can be determined. The OS error string isn't good enough
+;; given that it may have been localized (l10n).
+;;
+;; The above applies to versions pre 19b; 19d and newer are expected to
+;; contain even better error reporting.
+;;
+;;
+;; Just catch the errors and encapsulate them in an unknown-error
+(defun handle-condition (condition &optional (socket nil))
+ "Dispatch correct usocket condition."
+ (typecase condition
+ (ext::socket-error (cmucl-map-socket-error (ext::socket-errno condition)
+ :socket socket
+ :condition condition))))
+
+(defun socket-connect (host port &key (protocol :stream) (element-type 'character)
+ timeout deadline (nodelay t nodelay-specified)
+ (local-host nil local-host-p)
+ (local-port nil local-port-p)
+ &aux
+ (local-bind-p (fboundp 'ext::bind-inet-socket)))
+ (when timeout (unsupported 'timeout 'socket-connect))
+ (when deadline (unsupported 'deadline 'socket-connect))
+ (when (and nodelay-specified
+ (not (eq nodelay :if-supported)))
+ (unsupported 'nodelay 'socket-connect))
+ (when (and local-host-p (not local-bind-p))
+ (unsupported 'local-host 'socket-connect :minimum "Snapshot 2008-08 (19E)"))
+ (when (and local-port-p (not local-bind-p))
+ (unsupported 'local-port 'socket-connect :minimum "Snapshot 2008-08 (19E)"))
+
+ (let ((socket))
+ (ecase protocol
+ (:stream
+ (setf socket
+ (let ((args (list (host-to-hbo host) port protocol)))
+ (when (and local-bind-p (or local-host-p local-port-p))
+ (nconc args (list :local-host (when local-host
+ (host-to-hbo local-host))
+ :local-port local-port)))
+ (with-mapped-conditions (socket)
+ (apply #'ext:connect-to-inet-socket args))))
+ (if socket
+ (let* ((stream (sys:make-fd-stream socket :input t :output t
+ :element-type element-type
+ :buffering :full))
+ ;;###FIXME the above line probably needs an :external-format
+ (usocket (make-stream-socket :socket socket
+ :stream stream)))
+ usocket)
+ (let ((err (unix:unix-errno)))
+ (when err (cmucl-map-socket-error err)))))
+ (:datagram
+ (setf socket
+ (if (and host port)
+ (let ((args (list (host-to-hbo host) port protocol)))
+ (when (and local-bind-p (or local-host-p local-port-p))
+ (nconc args (list :local-host (when local-host
+ (host-to-hbo local-host))
+ :local-port local-port)))
+ (with-mapped-conditions (socket)
+ (apply #'ext:connect-to-inet-socket args)))
+ (if (or local-host-p local-port-p)
+ (with-mapped-conditions (socket)
+ (apply #'ext:create-inet-listener
+ (nconc (list (or local-port 0) protocol)
+ (when (and local-host-p
+ (ip/= local-host *wildcard-host*))
+ (list :host (host-to-hbo local-host))))))
+ (with-mapped-conditions (socket)
+ (ext:create-inet-socket protocol)))))
+ (if socket
+ (let ((usocket (make-datagram-socket socket :connected-p (and host port t))))
+ (ext:finalize usocket #'(lambda () (when (%open-p usocket)
+ (ext:close-socket socket))))
+ usocket)
+ (let ((err (unix:unix-errno)))
+ (when err (cmucl-map-socket-error err))))))))
+
+(defun socket-listen (host port
+ &key reuseaddress
+ (reuse-address nil reuse-address-supplied-p)
+ (backlog 5)
+ (element-type 'character))
+ (let* ((reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress))
+ (server-sock
+ (with-mapped-conditions ()
+ (apply #'ext:create-inet-listener
+ (nconc (list port :stream
+ :backlog backlog
+ :reuse-address reuseaddress)
+ (when (ip/= host *wildcard-host*)
+ (list :host
+ (host-to-hbo host))))))))
+ (make-stream-server-socket server-sock :element-type element-type)))
+
+(defmethod socket-accept ((usocket stream-server-usocket) &key element-type)
+ (with-mapped-conditions (usocket)
+ (let* ((sock (ext:accept-tcp-connection (socket usocket)))
+ (stream (sys:make-fd-stream sock :input t :output t
+ :element-type (or element-type
+ (element-type usocket))
+ :buffering :full)))
+ (make-stream-socket :socket sock :stream stream))))
+
+;; Sockets and socket streams are represented
+;; by different objects. Be sure to close the
+;; socket stream when closing a stream socket.
+(defmethod socket-close ((usocket stream-usocket))
+ "Close socket."
+ (when (wait-list usocket)
+ (remove-waiter (wait-list usocket) usocket))
+ (with-mapped-conditions (usocket)
+ (close (socket-stream usocket))))
+
+(defmethod socket-close ((usocket usocket))
+ "Close socket."
+ (when (wait-list usocket)
+ (remove-waiter (wait-list usocket) usocket))
+ (with-mapped-conditions (usocket)
+ (ext:close-socket (socket usocket))))
+
+(defmethod socket-close :after ((socket datagram-usocket))
+ (setf (%open-p socket) nil))
+
+#+unicode
+(defun %unix-send (fd buffer length flags)
+ (alien:alien-funcall
+ (alien:extern-alien "send"
+ (function c-call:int
+ c-call:int
+ system:system-area-pointer
+ c-call:int
+ c-call:int))
+ fd
+ (system:vector-sap buffer)
+ length
+ flags))
+
+(defmethod socket-shutdown ((usocket usocket) direction)
+ (with-mapped-conditions (usocket)
+ (ext:inet-shutdown (socket usocket) (ecase direction
+ (:input ext:shut-rd)
+ (:output ext:shut-wr)))))
+
+(defmethod socket-send ((usocket datagram-usocket) buffer size &key host port (offset 0)
+ &aux (real-buffer (if (zerop offset)
+ buffer
+ (subseq buffer offset (+ offset size)))))
+ (with-mapped-conditions (usocket)
+ (if (and host port)
+ (ext:inet-sendto (socket usocket) real-buffer size (host-to-hbo host) port)
+ #-unicode
+ (unix:unix-send (socket usocket) real-buffer size 0)
+ #+unicode
+ (%unix-send (socket usocket) real-buffer size 0))))
+
+(defmethod socket-receive ((usocket datagram-usocket) buffer length &key)
+ (declare (values (simple-array (unsigned-byte 8) (*)) ; buffer
+ (integer 0) ; size
+ (unsigned-byte 32) ; host
+ (unsigned-byte 16))) ; port
+ (let ((real-buffer (or buffer
+ (make-array length :element-type '(unsigned-byte 8))))
+ (real-length (or length
+ (length buffer))))
+ (multiple-value-bind (nbytes remote-host remote-port)
+ (with-mapped-conditions (usocket)
+ (ext:inet-recvfrom (socket usocket) real-buffer real-length))
+ (values real-buffer nbytes remote-host remote-port))))
+
+(defmethod get-local-name ((usocket usocket))
+ (multiple-value-bind
+ (address port)
+ (ext:get-socket-host-and-port (socket usocket))
+ (values (hbo-to-vector-quad address) port)))
+
+(defmethod get-peer-name ((usocket stream-usocket))
+ (multiple-value-bind
+ (address port)
+ (ext:get-peer-host-and-port (socket usocket))
+ (values (hbo-to-vector-quad address) port)))
+
+(defmethod get-local-address ((usocket usocket))
+ (nth-value 0 (get-local-name usocket)))
+
+(defmethod get-peer-address ((usocket stream-usocket))
+ (nth-value 0 (get-peer-name usocket)))
+
+(defmethod get-local-port ((usocket usocket))
+ (nth-value 1 (get-local-name usocket)))
+
+(defmethod get-peer-port ((usocket stream-usocket))
+ (nth-value 1 (get-peer-name usocket)))
+
+
+(defun lookup-host-entry (host)
+ (multiple-value-bind
+ (entry errno)
+ (ext:lookup-host-entry host)
+ (if entry
+ entry
+ ;;###The constants below work on *most* OSes, but are defined as the
+ ;; constants mentioned in C
+ (let ((exception
+ (second (assoc errno
+ '((1 ns-host-not-found-error) ;; HOST_NOT_FOUND
+ (2 ns-no-recovery-error) ;; NO_DATA
+ (3 ns-no-recovery-error) ;; NO_RECOVERY
+ (4 ns-try-again-condition)))))) ;; TRY_AGAIN
+ (when exception
+ (error exception))))))
+
+
+(defun get-host-by-address (address)
+ (handler-case (ext:host-entry-name
+ (lookup-host-entry (host-byte-order address)))
+ (condition (condition) (handle-condition condition))))
+
+(defun get-hosts-by-name (name)
+ (handler-case (mapcar #'hbo-to-vector-quad
+ (ext:host-entry-addr-list
+ (lookup-host-entry name)))
+ (condition (condition) (handle-condition condition))))
+
+(defun get-host-name ()
+ (unix:unix-gethostname))
+
+(defun %setup-wait-list (wait-list)
+ (declare (ignore wait-list)))
+
+(defun %add-waiter (wait-list waiter)
+ (push (socket waiter) (wait-list-%wait wait-list)))
+
+(defun %remove-waiter (wait-list waiter)
+ (setf (wait-list-%wait wait-list)
+ (remove (socket waiter) (wait-list-%wait wait-list))))
+
+(defun wait-for-input-internal (wait-list &key timeout)
+ (with-mapped-conditions ()
+ (alien:with-alien ((rfds (alien:struct unix:fd-set)))
+ (unix:fd-zero rfds)
+ (dolist (socket (wait-list-%wait wait-list))
+ (unix:fd-set socket rfds))
+ (multiple-value-bind
+ (secs musecs)
+ (split-timeout (or timeout 1))
+ (multiple-value-bind (count err)
+ (unix:unix-fast-select (1+ (reduce #'max
+ (wait-list-%wait wait-list)))
+ (alien:addr rfds) nil nil
+ (when timeout secs) musecs)
+ (declare (ignore err))
+ (if (<= 0 count)
+ ;; process the result...
+ (dolist (x (wait-list-waiters wait-list))
+ (when (unix:fd-isset (socket x) rfds)
+ (setf (state x) :READ)))
+ (progn
+ ;;###FIXME generate an error, except for EINTR
+ )))))))
--- /dev/null
+;;;; -*- Mode: Lisp -*-
+;;;; $Id$
+;;;; $URL$
+
+;;;; Foreign functions defined by ECL's DFFI, used for #+ecl-bytecmp only.
+;;;; See LICENSE for licensing information.
+
+(in-package :usocket)
+
+#+(and ecl-bytecmp windows)
+(eval-when (:load-toplevel :execute)
+ (ffi:load-foreign-library "ws2_32.dll" :module "ws2_32"))
+
+#+(and ecl-bytecmp windows)
+(progn
+ (ffi:def-function ("gethostname" c-gethostname)
+ ((name (* :unsigned-char))
+ (len :int))
+ :returning :int
+ :module "ws2_32")
+
+ (defun get-host-name ()
+ "Returns the hostname"
+ (ffi:with-foreign-object (name '(:array :unsigned-char 256))
+ (when (zerop (c-gethostname (ffi:char-array-to-pointer name) 256))
+ (ffi:convert-from-foreign-string name))))
+
+ (ffi:def-foreign-type ws-socket :unsigned-int)
+ (ffi:def-foreign-type ws-dword :unsigned-long)
+ (ffi:def-foreign-type ws-event :unsigned-int)
+
+ (ffi:def-struct wsa-network-events
+ (network-events :long)
+ (error-code (:array :int 10)))
+
+ (ffi:def-function ("WSACreateEvent" wsa-event-create)
+ ()
+ :returning ws-event
+ :module "ws2_32")
+
+ (ffi:def-function ("WSACloseEvent" c-wsa-event-close)
+ ((event-object ws-event))
+ :returning :int
+ :module "ws2_32")
+
+ (defun wsa-event-close (ws-event)
+ (not (zerop (c-wsa-event-close ws-event))))
+
+ (ffi:def-function ("WSAEnumNetworkEvents" wsa-enum-network-events)
+ ((socket ws-socket)
+ (event-object ws-event)
+ (network-events (* wsa-network-events)))
+ :returning :int
+ :module "ws2_32")
+
+ (ffi:def-function ("WSAEventSelect" wsa-event-select)
+ ((socket ws-socket)
+ (event-object ws-event)
+ (network-events :long))
+ :returning :int
+ :module "ws2_32")
+
+ (ffi:def-function ("WSAWaitForMultipleEvents" c-wsa-wait-for-multiple-events)
+ ((number-of-events ws-dword)
+ (events (* ws-event))
+ (wait-all-p :int)
+ (timeout ws-dword)
+ (alertable-p :int))
+ :returning ws-dword
+ :module "ws2_32")
+
+ (defun wsa-wait-for-multiple-events (number-of-events events wait-all-p timeout alertable-p)
+ (c-wsa-wait-for-multiple-events number-of-events
+ events
+ (if wait-all-p -1 0)
+ timeout
+ (if alertable-p -1 0)))
+
+ (ffi:def-function ("ioctlsocket" wsa-ioctlsocket)
+ ((socket ws-socket)
+ (cmd :long)
+ (argp (* :unsigned-long)))
+ :returning :int
+ :module "ws2_32")
+
+ (ffi:def-function ("WSAGetLastError" wsa-get-last-error)
+ ()
+ :returning :int
+ :module "ws2_32")
+
+ (defun maybe-wsa-error (rv &optional socket)
+ (unless (zerop rv)
+ (raise-usock-err (wsa-get-last-error) socket)))
+
+ (defun bytes-available-for-read (socket)
+ (ffi:with-foreign-object (int-ptr :unsigned-long)
+ (maybe-wsa-error (wsa-ioctlsocket (socket-handle socket) fionread int-ptr)
+ socket)
+ (let ((int (ffi:deref-pointer int-ptr :unsigned-long)))
+ (prog1 int
+ (when (plusp int)
+ (setf (state socket) :read))))))
+
+ (defun map-network-events (func network-events)
+ (let ((event-map (ffi:get-slot-value network-events 'wsa-network-events 'network-events))
+ (error-array (ffi:get-slot-pointer network-events 'wsa-network-events 'error-code)))
+ (unless (zerop event-map)
+ (dotimes (i fd-max-events)
+ (unless (zerop (ldb (byte 1 i) event-map))
+ (funcall func (ffi:deref-array error-array '(:array :int 10) i)))))))
+
+ (defun update-ready-and-state-slots (sockets)
+ (dolist (socket sockets)
+ (if (%ready-p socket)
+ (progn
+ (setf (state socket) :READ))
+ (ffi:with-foreign-object (network-events 'wsa-network-events)
+ (let ((rv (wsa-enum-network-events (socket-handle socket) 0 network-events)))
+ (if (zerop rv)
+ (map-network-events
+ #'(lambda (err-code)
+ (if (zerop err-code)
+ (progn
+ (setf (state socket) :READ)
+ (when (stream-server-usocket-p socket)
+ (setf (%ready-p socket) t)))
+ (raise-usock-err err-code socket)))
+ network-events)
+ (maybe-wsa-error rv socket)))))))
+
+ (defun os-wait-list-%wait (wait-list)
+ (ffi:deref-pointer (wait-list-%wait wait-list) 'ws-event))
+
+ (defun (setf os-wait-list-%wait) (value wait-list)
+ (setf (ffi:deref-pointer (wait-list-%wait wait-list) 'ws-event) value))
+
+ (defun free-wait-list (wl)
+ (when (wait-list-p wl)
+ (unless (null (wait-list-%wait wl))
+ (wsa-event-close (os-wait-list-%wait wl))
+ (ffi:free-foreign-object (wait-list-%wait wl))
+ (setf (wait-list-%wait wl) nil))))
+
+ (defun %setup-wait-list (wait-list)
+ (setf (wait-list-%wait wait-list)
+ (ffi:allocate-foreign-object 'ws-event))
+ (setf (os-wait-list-%wait wait-list)
+ (wsa-event-create))
+ (ext:set-finalizer wait-list #'free-wait-list))
+
+ (defun os-socket-handle (usocket)
+ (socket-handle usocket))
+
+) ; #+(and ecl-bytecmp windows)
--- /dev/null
+;;;; See LICENSE for licensing information.
+
+(in-package :usocket)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (require "comm")
+
+ #+lispworks3
+ (error "LispWorks 3 is not supported by USOCKET any more."))
+
+;;; ---------------------------------------------------------------------------
+;;; Warn if multiprocessing is not running on Lispworks
+
+(defun check-for-multiprocessing-started (&optional errorp)
+ (unless mp:*current-process*
+ (funcall (if errorp 'error 'warn)
+ "You must start multiprocessing on Lispworks by calling~
+ ~%~3t(~s)~
+ ~%for ~s function properly."
+ 'mp:initialize-multiprocessing
+ 'wait-for-input)))
+
+(eval-when (:load-toplevel :execute)
+ (check-for-multiprocessing-started))
+
+#+win32
+(eval-when (:load-toplevel :execute)
+ (fli:register-module "ws2_32"))
+
+(fli:define-foreign-function (get-host-name-internal "gethostname" :source)
+ ((return-string (:reference-return (:ef-mb-string :limit 257)))
+ (namelen :int))
+ :lambda-list (&aux (namelen 256) return-string)
+ :result-type :int
+ #+win32 :module
+ #+win32 "ws2_32")
+
+(defun get-host-name ()
+ (multiple-value-bind (return-code name)
+ (get-host-name-internal)
+ (when (zerop return-code)
+ name)))
+
+#+win32
+(defun remap-maybe-for-win32 (z)
+ (mapcar #'(lambda (x)
+ (cons (mapcar #'(lambda (y) (+ 10000 y)) (car x))
+ (cdr x)))
+ z))
+
+(defparameter +lispworks-error-map+
+ #+win32
+ (append (remap-maybe-for-win32 +unix-errno-condition-map+)
+ (remap-maybe-for-win32 +unix-errno-error-map+))
+ #-win32
+ (append +unix-errno-condition-map+
+ +unix-errno-error-map+))
+
+(defun raise-usock-err (errno socket &optional condition)
+ (let ((usock-err
+ (cdr (assoc errno +lispworks-error-map+ :test #'member))))
+ (if usock-err
+ (if (subtypep usock-err 'error)
+ (error usock-err :socket socket)
+ (signal usock-err))
+ (error 'unknown-error
+ :socket socket
+ :real-error condition
+ :errno errno))))
+
+(defun handle-condition (condition &optional (socket nil))
+ "Dispatch correct usocket condition."
+ (typecase condition
+ (condition (let ((errno #-win32 (lw:errno-value)
+ #+win32 (wsa-get-last-error)))
+ (unless (zerop errno)
+ (raise-usock-err errno socket condition))))))
+
+(defconstant *socket_sock_dgram* 2
+ "Connectionless, unreliable datagrams of fixed maximum length.")
+
+(defconstant *socket_ip_proto_udp* 17)
+
+(defconstant *sockopt_so_rcvtimeo*
+ #-linux #x1006
+ #+linux 20
+ "Socket receive timeout")
+
+(defconstant *sockopt_so_sndtimeo*
+ #-linux #x1007
+ #+linux 21
+ "Socket send timeout")
+
+(fli:define-c-struct timeval
+ (tv-sec :long)
+ (tv-usec :long))
+
+;;; ssize_t
+;;; recvfrom(int socket, void *restrict buffer, size_t length, int flags,
+;;; struct sockaddr *restrict address, socklen_t *restrict address_len);
+(fli:define-foreign-function (%recvfrom "recvfrom" :source)
+ ((socket :int)
+ (buffer (:pointer (:unsigned :byte)))
+ (length :int)
+ (flags :int)
+ (address (:pointer (:struct comm::sockaddr)))
+ (address-len (:pointer :int)))
+ :result-type :int
+ #+win32 :module
+ #+win32 "ws2_32")
+
+;;; ssize_t
+;;; sendto(int socket, const void *buffer, size_t length, int flags,
+;;; const struct sockaddr *dest_addr, socklen_t dest_len);
+(fli:define-foreign-function (%sendto "sendto" :source)
+ ((socket :int)
+ (buffer (:pointer (:unsigned :byte)))
+ (length :int)
+ (flags :int)
+ (address (:pointer (:struct comm::sockaddr)))
+ (address-len :int))
+ :result-type :int
+ #+win32 :module
+ #+win32 "ws2_32")
+
+#-win32
+(defun set-socket-receive-timeout (socket-fd seconds)
+ "Set socket option: RCVTIMEO, argument seconds can be a float number"
+ (declare (type integer socket-fd)
+ (type number seconds))
+ (multiple-value-bind (sec usec) (truncate seconds)
+ (fli:with-dynamic-foreign-objects ((timeout (:struct timeval)))
+ (fli:with-foreign-slots (tv-sec tv-usec) timeout
+ (setf tv-sec sec
+ tv-usec (truncate (* 1000000 usec)))
+ (if (zerop (comm::setsockopt socket-fd
+ comm::*sockopt_sol_socket*
+ *sockopt_so_rcvtimeo*
+ (fli:copy-pointer timeout
+ :type '(:pointer :void))
+ (fli:size-of '(:struct timeval))))
+ seconds)))))
+
+#-win32
+(defun set-socket-send-timeout (socket-fd seconds)
+ "Set socket option: SNDTIMEO, argument seconds can be a float number"
+ (declare (type integer socket-fd)
+ (type number seconds))
+ (multiple-value-bind (sec usec) (truncate seconds)
+ (fli:with-dynamic-foreign-objects ((timeout (:struct timeval)))
+ (fli:with-foreign-slots (tv-sec tv-usec) timeout
+ (setf tv-sec sec
+ tv-usec (truncate (* 1000000 usec)))
+ (if (zerop (comm::setsockopt socket-fd
+ comm::*sockopt_sol_socket*
+ *sockopt_so_sndtimeo*
+ (fli:copy-pointer timeout
+ :type '(:pointer :void))
+ (fli:size-of '(:struct timeval))))
+ seconds)))))
+
+#+win32
+(defun set-socket-receive-timeout (socket-fd seconds)
+ "Set socket option: RCVTIMEO, argument seconds can be a float number.
+ On win32, you must bind the socket before use this function."
+ (declare (type integer socket-fd)
+ (type number seconds))
+ (fli:with-dynamic-foreign-objects ((timeout :int))
+ (setf (fli:dereference timeout)
+ (truncate (* 1000 seconds)))
+ (if (zerop (comm::setsockopt socket-fd
+ comm::*sockopt_sol_socket*
+ *sockopt_so_rcvtimeo*
+ (fli:copy-pointer timeout
+ :type '(:pointer :char))
+ (fli:size-of :int)))
+ seconds)))
+
+#+win32
+(defun set-socket-send-timeout (socket-fd seconds)
+ "Set socket option: SNDTIMEO, argument seconds can be a float number.
+ On win32, you must bind the socket before use this function."
+ (declare (type integer socket-fd)
+ (type number seconds))
+ (fli:with-dynamic-foreign-objects ((timeout :int))
+ (setf (fli:dereference timeout)
+ (truncate (* 1000 seconds)))
+ (if (zerop (comm::setsockopt socket-fd
+ comm::*sockopt_sol_socket*
+ *sockopt_so_sndtimeo*
+ (fli:copy-pointer timeout
+ :type '(:pointer :char))
+ (fli:size-of :int)))
+ seconds)))
+
+#-win32
+(defun get-socket-receive-timeout (socket-fd)
+ "Get socket option: RCVTIMEO, return value is a float number"
+ (declare (type integer socket-fd))
+ (fli:with-dynamic-foreign-objects ((timeout (:struct timeval))
+ (len :int))
+ (comm::getsockopt socket-fd
+ comm::*sockopt_sol_socket*
+ *sockopt_so_rcvtimeo*
+ (fli:copy-pointer timeout
+ :type '(:pointer :void))
+ len)
+ (fli:with-foreign-slots (tv-sec tv-usec) timeout
+ (float (+ tv-sec (/ tv-usec 1000000))))))
+
+#-win32
+(defun get-socket-send-timeout (socket-fd)
+ "Get socket option: SNDTIMEO, return value is a float number"
+ (declare (type integer socket-fd))
+ (fli:with-dynamic-foreign-objects ((timeout (:struct timeval))
+ (len :int))
+ (comm::getsockopt socket-fd
+ comm::*sockopt_sol_socket*
+ *sockopt_so_sndtimeo*
+ (fli:copy-pointer timeout
+ :type '(:pointer :void))
+ len)
+ (fli:with-foreign-slots (tv-sec tv-usec) timeout
+ (float (+ tv-sec (/ tv-usec 1000000))))))
+
+#+win32
+(defun get-socket-receive-timeout (socket-fd)
+ "Get socket option: RCVTIMEO, return value is a float number"
+ (declare (type integer socket-fd))
+ (fli:with-dynamic-foreign-objects ((timeout :int)
+ (len :int))
+ (comm::getsockopt socket-fd
+ comm::*sockopt_sol_socket*
+ *sockopt_so_rcvtimeo*
+ (fli:copy-pointer timeout
+ :type '(:pointer :void))
+ len)
+ (float (/ (fli:dereference timeout) 1000))))
+
+#+win32
+(defun get-socket-send-timeout (socket-fd)
+ "Get socket option: SNDTIMEO, return value is a float number"
+ (declare (type integer socket-fd))
+ (fli:with-dynamic-foreign-objects ((timeout :int)
+ (len :int))
+ (comm::getsockopt socket-fd
+ comm::*sockopt_sol_socket*
+ *sockopt_so_sndtimeo*
+ (fli:copy-pointer timeout
+ :type '(:pointer :void))
+ len)
+ (float (/ (fli:dereference timeout) 1000))))
+
+#+lispworks4
+(defun set-socket-tcp-nodelay (socket-fd new-value)
+ "Set socket option: TCP_NODELAY, argument is a fixnum (0 or 1)"
+ (declare (type integer socket-fd)
+ (type (integer 0 1) new-value))
+ (fli:with-dynamic-foreign-objects ((zero-or-one :int))
+ (setf (fli:dereference zero-or-one) new-value)
+ (when (zerop (comm::setsockopt socket-fd
+ comm::*sockopt_sol_socket*
+ comm::*sockopt_tcp_nodelay*
+ (fli:copy-pointer zero-or-one
+ :type '(:pointer #+win32 :char #-win32 :void))
+ (fli:size-of :int)))
+ new-value)))
+
+(defun get-socket-tcp-nodelay (socket-fd)
+ "Get socket option: TCP_NODELAY, return value is a fixnum (0 or 1)"
+ (declare (type integer socket-fd))
+ (fli:with-dynamic-foreign-objects ((zero-or-one :int)
+ (len :int))
+ (if (zerop (comm::getsockopt socket-fd
+ comm::*sockopt_sol_socket*
+ comm::*sockopt_tcp_nodelay*
+ (fli:copy-pointer zero-or-one
+ :type '(:pointer #+win32 :char #-win32 :void))
+ len))
+ zero-or-one 0))) ; on error, return 0
+
+(defun initialize-dynamic-sockaddr (hostname service protocol &aux (original-hostname hostname))
+ (declare (ignorable original-hostname))
+ #+(or lispworks4 lispworks5 lispworks6.0)
+ (let ((server-addr (fli:allocate-dynamic-foreign-object
+ :type '(:struct comm::sockaddr_in))))
+ (values (comm::initialize-sockaddr_in
+ server-addr
+ comm::*socket_af_inet*
+ hostname
+ service protocol)
+ comm::*socket_af_inet*
+ server-addr
+ (fli:pointer-element-size server-addr)))
+ #-(or lispworks4 lispworks5 lispworks6.0) ; version>=6.1
+ (progn
+ (when (stringp hostname)
+ (setq hostname (comm:string-ip-address hostname))
+ (unless hostname
+ (let ((resolved-hostname (comm:get-host-entry original-hostname :fields '(:address))))
+ (unless resolved-hostname
+ (return-from initialize-dynamic-sockaddr :unknown-host))
+ (setq hostname resolved-hostname))))
+ (if (or (null hostname)
+ (integerp hostname)
+ (comm:ipv6-address-p hostname))
+ (let ((server-addr (fli:allocate-dynamic-foreign-object
+ :type '(:struct comm::lw-sockaddr))))
+ (multiple-value-bind (error family)
+ (comm::initialize-sockaddr_in
+ server-addr
+ hostname
+ service protocol)
+ (values error family
+ server-addr
+ (if (eql family comm::*socket_af_inet*)
+ (fli:size-of '(:struct comm::sockaddr_in))
+ (fli:size-of '(:struct comm::sockaddr_in6))))))
+ :bad-host)))
+
+(defun open-udp-socket (&key local-address local-port read-timeout
+ (address-family comm::*socket_af_inet*))
+ "Open a unconnected UDP socket.
+ For binding on address ANY(*), just not set LOCAL-ADDRESS (NIL),
+ for binding on random free unused port, set LOCAL-PORT to 0."
+
+ ;; Note: move (ensure-sockets) here to make sure delivered applications
+ ;; correctly have networking support initialized.
+ ;;
+ ;; Following words was from Martin Simmons, forwarded by Camille Troillard:
+
+ ;; Calling comm::ensure-sockets at load time looks like a bug in Lispworks-udp
+ ;; (it is too early and also unnecessary).
+
+ ;; The LispWorks comm package calls comm::ensure-sockets when it is needed, so I
+ ;; think open-udp-socket should probably do it too. Calling it more than once is
+ ;; safe and it will be very fast after the first time.
+ #+win32 (comm::ensure-sockets)
+
+ (let ((socket-fd (comm::socket address-family *socket_sock_dgram* *socket_ip_proto_udp*)))
+ (if socket-fd
+ (progn
+ (when read-timeout (set-socket-receive-timeout socket-fd read-timeout))
+ (if local-port
+ (fli:with-dynamic-foreign-objects ()
+ (multiple-value-bind (error local-address-family
+ client-addr client-addr-length)
+ (initialize-dynamic-sockaddr local-address local-port "udp")
+ (if (or error (not (eql address-family local-address-family)))
+ (progn
+ (comm::close-socket socket-fd)
+ (error "cannot resolve hostname ~S, service ~S: ~A"
+ local-address local-port (or error "address family mismatch")))
+ (if (comm::bind socket-fd client-addr client-addr-length)
+ ;; success, return socket fd
+ socket-fd
+ (progn
+ (comm::close-socket socket-fd)
+ (error "cannot bind"))))))
+ socket-fd))
+ (error "cannot create socket"))))
+
+(defun connect-to-udp-server (hostname service
+ &key local-address local-port read-timeout)
+ "Something like CONNECT-TO-TCP-SERVER"
+ (fli:with-dynamic-foreign-objects ()
+ (multiple-value-bind (error address-family server-addr server-addr-length)
+ (initialize-dynamic-sockaddr hostname service "udp")
+ (when error
+ (error "cannot resolve hostname ~S, service ~S: ~A"
+ hostname service error))
+ (let ((socket-fd (open-udp-socket :local-address local-address
+ :local-port local-port
+ :read-timeout read-timeout
+ :address-family address-family)))
+ (if socket-fd
+ (if (comm::connect socket-fd server-addr server-addr-length)
+ ;; success, return socket fd
+ socket-fd
+ ;; fail, close socket and return nil
+ (progn
+ (comm::close-socket socket-fd)
+ (error "cannot connect")))
+ (error "cannot create socket"))))))
+
+(defun socket-connect (host port &key (protocol :stream) (element-type 'base-char)
+ timeout deadline (nodelay t)
+ local-host local-port)
+ ;; What's the meaning of this keyword?
+ (when deadline
+ (unimplemented 'deadline 'socket-connect))
+
+ #+(and lispworks4 (not lispworks4.4)) ; < 4.4.5
+ (when timeout
+ (unsupported 'timeout 'socket-connect :minimum "LispWorks 4.4.5"))
+
+ #+lispworks4
+ (when local-host
+ (unsupported 'local-host 'socket-connect :minimum "LispWorks 5.0"))
+ #+lispworks4
+ (when local-port
+ (unsupported 'local-port 'socket-connect :minimum "LispWorks 5.0"))
+
+ (ecase protocol
+ (:stream
+ (let ((hostname (host-to-hostname host))
+ (stream))
+ (setq stream
+ (with-mapped-conditions ()
+ (comm:open-tcp-stream hostname port
+ :element-type element-type
+ #-(and lispworks4 (not lispworks4.4)) ; >= 4.4.5
+ #-(and lispworks4 (not lispworks4.4))
+ :timeout timeout
+ #-lispworks4 #-lispworks4
+ #-lispworks4 #-lispworks4
+ :local-address (when local-host (host-to-hostname local-host))
+ :local-port local-port
+ #-(or lispworks4 lispworks5.0) ; >= 5.1
+ #-(or lispworks4 lispworks5.0)
+ :nodelay nodelay)))
+
+ ;; Then handle `nodelay' separately for older versions <= 5.0
+ #+(or lispworks4 lispworks5.0)
+ (when (and stream nodelay)
+ (#+lispworks4 set-socket-tcp-nodelay
+ #+lispworks5.0 comm::set-socket-tcp-nodelay
+ (comm:socket-stream-socket stream)
+ (bool->int nodelay))) ; ":if-supported" maps to 1 too.
+
+ (if stream
+ (make-stream-socket :socket (comm:socket-stream-socket stream)
+ :stream stream)
+ ;; if no other error catched by above with-mapped-conditions and still fails, then it's a timeout
+ (error 'timeout-error))))
+ (:datagram
+ (let ((usocket (make-datagram-socket
+ (if (and host port)
+ (with-mapped-conditions ()
+ (connect-to-udp-server (host-to-hostname host) port
+ :local-address (and local-host (host-to-hostname local-host))
+ :local-port local-port
+ :read-timeout timeout))
+ (with-mapped-conditions ()
+ (open-udp-socket :local-address (and local-host (host-to-hostname local-host))
+ :local-port local-port
+ :read-timeout timeout)))
+ :connected-p (and host port t))))
+ usocket))))
+
+(defun socket-listen (host port
+ &key reuseaddress
+ (reuse-address nil reuse-address-supplied-p)
+ (backlog 5)
+ (element-type 'base-char))
+ #+lispworks4.1
+ (unsupported 'host 'socket-listen :minimum "LispWorks 4.0 or newer than 4.1")
+ #+lispworks4.1
+ (unsupported 'backlog 'socket-listen :minimum "LispWorks 4.0 or newer than 4.1")
+
+ (let* ((reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress))
+ (comm::*use_so_reuseaddr* reuseaddress)
+ (hostname (host-to-hostname host))
+ (socket-res-list (with-mapped-conditions ()
+ (multiple-value-list
+ #-lispworks4.1 (comm::create-tcp-socket-for-service
+ port :address hostname :backlog backlog)
+ #+lispworks4.1 (comm::create-tcp-socket-for-service port))))
+ (sock (if (not (or (second socket-res-list) (third socket-res-list)))
+ (first socket-res-list)
+ (when (eq (second socket-res-list) :bind)
+ (error 'address-in-use-error)))))
+ (make-stream-server-socket sock :element-type element-type)))
+
+;; Note: COMM::GET-FD-FROM-SOCKET contains addition socket wait operations, which
+;; should NOT be applied on socket FDs who have already been called on W-F-I,
+;; so we have to check the %READY-P slot to decide if this waiting is necessary,
+;; or SOCKET-ACCEPT will just hang. -- Chun Tian (binghe), May 1, 2011
+
+(defmethod socket-accept ((usocket stream-server-usocket) &key element-type)
+ (let* ((socket (with-mapped-conditions (usocket)
+ #+win32
+ (if (%ready-p usocket)
+ (comm::accept-connection-to-socket (socket usocket))
+ (comm::get-fd-from-socket (socket usocket)))
+ #-win32
+ (comm::get-fd-from-socket (socket usocket))))
+ (stream (make-instance 'comm:socket-stream
+ :socket socket
+ :direction :io
+ :element-type (or element-type
+ (element-type usocket)))))
+ #+win32
+ (when socket
+ (setf (%ready-p usocket) nil))
+ (make-stream-socket :socket socket :stream stream)))
+
+;; Sockets and their streams are different objects
+;; close the stream in order to make sure buffers
+;; are correctly flushed and the socket closed.
+(defmethod socket-close ((usocket stream-usocket))
+ "Close socket."
+ (when (wait-list usocket)
+ (remove-waiter (wait-list usocket) usocket))
+ (close (socket-stream usocket)))
+
+(defmethod socket-close ((usocket usocket))
+ (when (wait-list usocket)
+ (remove-waiter (wait-list usocket) usocket))
+ (with-mapped-conditions (usocket)
+ (comm::close-socket (socket usocket))))
+
+(defmethod socket-close :after ((socket datagram-usocket))
+ "Additional socket-close method for datagram-usocket"
+ (setf (%open-p socket) nil))
+
+(defconstant +shutdown-read+ 0)
+(defconstant +shutdown-write+ 1)
+(defconstant +shutdown-read-write+ 2)
+
+;;; int
+;;; shutdown(int socket, int what);
+(fli:define-foreign-function (%shutdown "shutdown" :source)
+ ((socket :int)
+ (what :int))
+ :result-type :int
+ #+win32 :module
+ #+win32 "ws2_32")
+
+(defmethod socket-shutdown ((usocket datagram-usocket) direction)
+ (unless (member direction '(:input :output :io))
+ (error 'invalid-argument-error))
+ (let ((what (case direction
+ (:input +shutdown-read+)
+ (:output +shutdown-write+)
+ (:io +shutdown-read-write+))))
+ (with-mapped-conditions (usocket)
+ #-(or lispworks4 lispworks5 lispworks6) ; lispworks 7.0+
+ (comm::shutdown (socket usocket) what)
+ #+(or lispworks4 lispworks5 lispworks6)
+ (= 0 (%shutdown (socket usocket) what)))))
+
+(defmethod socket-shutdown ((usocket stream-usocket) direction)
+ (unless (member direction '(:input :output :io))
+ (error 'invalid-argument-error))
+ (with-mapped-conditions (usocket)
+ #-(or lispworks4 lispworks5 lispworks6)
+ (comm:socket-stream-shutdown (socket usocket) direction)
+ #+(or lispworks4 lispworks5 lispworks6)
+ (let ((what (case direction
+ (:input +shutdown-read+)
+ (:output +shutdown-write+)
+ (:io +shutdown-read-write+))))
+ (= 0 (%shutdown (comm:socket-stream-socket (socket usocket)) what)))))
+
+(defmethod initialize-instance :after ((socket datagram-usocket) &key)
+ (setf (slot-value socket 'send-buffer)
+ (make-array +max-datagram-packet-size+
+ :element-type '(unsigned-byte 8)
+ :allocation :static))
+ (setf (slot-value socket 'recv-buffer)
+ (make-array +max-datagram-packet-size+
+ :element-type '(unsigned-byte 8)
+ :allocation :static)))
+
+(defvar *length-of-sockaddr_in*
+ (fli:size-of '(:struct comm::sockaddr_in)))
+
+(defmethod socket-send ((usocket datagram-usocket) buffer size &key host port (offset 0)
+ &aux (socket-fd (socket usocket))
+ (message (slot-value usocket 'send-buffer))) ; TODO: multiple threads send together?
+ "Send message to a socket, using sendto()/send()"
+ (declare (type integer socket-fd)
+ (type sequence buffer))
+ (when host (setq host (host-to-hostname host)))
+ (fli:with-dynamic-lisp-array-pointer (ptr message :type '(:unsigned :byte))
+ (replace message buffer :start2 offset :end2 (+ offset size))
+ (let ((n (if (and host port)
+ (fli:with-dynamic-foreign-objects ()
+ (multiple-value-bind (error family client-addr client-addr-length)
+ (initialize-dynamic-sockaddr host port "udp")
+ (declare (ignore family))
+ (when error
+ (error "cannot resolve hostname ~S, port ~S: ~A"
+ host port error))
+ (%sendto socket-fd ptr (min size +max-datagram-packet-size+) 0
+ (fli:copy-pointer client-addr :type '(:struct comm::sockaddr))
+ client-addr-length)))
+ (comm::%send socket-fd ptr (min size +max-datagram-packet-size+) 0))))
+ (declare (type fixnum n))
+ (if (plusp n)
+ n
+ (let ((errno #-win32 (lw:errno-value)
+ #+win32 (wsa-get-last-error)))
+ (if (zerop errno)
+ n
+ (raise-usock-err errno socket-fd)))))))
+
+(defmethod socket-receive ((socket datagram-usocket) buffer length &key timeout (max-buffer-size +max-datagram-packet-size+))
+ "Receive message from socket, read-timeout is a float number in seconds.
+
+ This function will return 4 values:
+ 1. receive buffer
+ 2. number of receive bytes
+ 3. remote address
+ 4. remote port"
+ (declare (values (simple-array (unsigned-byte 8) (*)) ; buffer
+ (integer 0) ; size
+ (unsigned-byte 32) ; host
+ (unsigned-byte 16)) ; port
+ (type sequence buffer))
+ (let ((socket-fd (socket socket))
+ (message (slot-value socket 'recv-buffer)) ; TODO: how multiple threads do this in parallel?
+ (read-timeout timeout)
+ old-timeout)
+ (declare (type integer socket-fd))
+ (fli:with-dynamic-foreign-objects ((client-addr (:struct comm::sockaddr_in))
+ (len :int
+ #-(or lispworks4 lispworks5.0) ; <= 5.0
+ :initial-element *length-of-sockaddr_in*))
+ #+(or lispworks4 lispworks5.0) ; <= 5.0
+ (setf (fli:dereference len) *length-of-sockaddr_in*)
+ (fli:with-dynamic-lisp-array-pointer (ptr message :type '(:unsigned :byte))
+ ;; setup new read timeout
+ (when read-timeout
+ (setf old-timeout (get-socket-receive-timeout socket-fd))
+ (set-socket-receive-timeout socket-fd read-timeout))
+ (let ((n (%recvfrom socket-fd ptr max-buffer-size 0
+ (fli:copy-pointer client-addr :type '(:struct comm::sockaddr))
+ len)))
+ (declare (type fixnum n))
+ ;; restore old read timeout
+ (when (and read-timeout (/= old-timeout read-timeout))
+ (set-socket-receive-timeout socket-fd old-timeout))
+ ;; Frank James' patch: reset the %read-p for WAIT-FOR-INPUT
+ #+win32 (setf (%ready-p socket) nil)
+ (if (plusp n)
+ (values (if buffer
+ (replace buffer message
+ :end1 (min length max-buffer-size)
+ :end2 (min n max-buffer-size))
+ (subseq message 0 (min n max-buffer-size)))
+ (min n max-buffer-size)
+ (comm::ntohl (fli:foreign-slot-value
+ (fli:foreign-slot-value client-addr
+ 'comm::sin_addr
+ :object-type '(:struct comm::sockaddr_in)
+ :type '(:struct comm::in_addr)
+ :copy-foreign-object nil)
+ 'comm::s_addr
+ :object-type '(:struct comm::in_addr)))
+ (comm::ntohs (fli:foreign-slot-value client-addr
+ 'comm::sin_port
+ :object-type '(:struct comm::sockaddr_in)
+ :type '(:unsigned :short)
+ :copy-foreign-object nil)))
+ (let ((errno #-win32 (lw:errno-value)
+ #+win32 (wsa-get-last-error)))
+ (if (zerop errno)
+ (values nil n 0 0)
+ (raise-usock-err errno socket-fd)))))))))
+
+(defmethod get-local-name ((usocket usocket))
+ (multiple-value-bind
+ (address port)
+ (comm:get-socket-address (socket usocket))
+ (values (hbo-to-vector-quad address) port)))
+
+(defmethod get-peer-name ((usocket stream-usocket))
+ (multiple-value-bind
+ (address port)
+ (comm:get-socket-peer-address (socket usocket))
+ (values (hbo-to-vector-quad address) port)))
+
+(defmethod get-local-address ((usocket usocket))
+ (nth-value 0 (get-local-name usocket)))
+
+(defmethod get-peer-address ((usocket stream-usocket))
+ (nth-value 0 (get-peer-name usocket)))
+
+(defmethod get-local-port ((usocket usocket))
+ (nth-value 1 (get-local-name usocket)))
+
+(defmethod get-peer-port ((usocket stream-usocket))
+ (nth-value 1 (get-peer-name usocket)))
+
+(defun lw-hbo-to-vector-quad (hbo)
+ #+(or lispworks4 lispworks5 lispworks6.0)
+ (hbo-to-vector-quad hbo)
+ #-(or lispworks4 lispworks5 lispworks6.0) ; version>= 6.1
+ (if (comm:ipv6-address-p hbo)
+ (ipv6-host-to-vector (comm:ipv6-address-string hbo))
+ (hbo-to-vector-quad hbo)))
+
+(defun get-hosts-by-name (name)
+ (with-mapped-conditions ()
+ (mapcar #'lw-hbo-to-vector-quad
+ (comm:get-host-entry name :fields '(:addresses)))))
+
+(defun os-socket-handle (usocket)
+ (socket usocket))
+
+(defun usocket-listen (usocket)
+ (if (stream-usocket-p usocket)
+ (when (listen (socket-stream usocket))
+ usocket)
+ (when (comm::socket-listen (socket usocket))
+ usocket)))
+
+;;;
+;;; Non Windows implementation
+;;; The Windows implementation needs to resort to the Windows API in order
+;;; to achieve what we want (what we want is waiting without busy-looping)
+;;;
+
+#-win32
+(progn
+
+ (defun %setup-wait-list (wait-list)
+ (declare (ignore wait-list)))
+
+ (defun %add-waiter (wait-list waiter)
+ (declare (ignore wait-list waiter)))
+
+ (defun %remove-waiter (wait-list waiter)
+ (declare (ignore wait-list waiter)))
+
+ (defun wait-for-input-internal (wait-list &key timeout)
+ (with-mapped-conditions ()
+ ;; unfortunately, it's impossible to share code between
+ ;; non-win32 and win32 platforms...
+ ;; Can we have a sane -pref. complete [UDP!?]- API next time, please?
+ (dolist (x (wait-list-waiters wait-list))
+ (mp:notice-fd (os-socket-handle x)))
+ (labels ((wait-function (socks)
+ (let (rv)
+ (dolist (x socks rv)
+ (when (usocket-listen x)
+ (setf (state x) :READ
+ rv t))))))
+ (if timeout
+ (mp:process-wait-with-timeout "Waiting for a socket to become active"
+ (truncate timeout)
+ #'wait-function
+ (wait-list-waiters wait-list))
+ (mp:process-wait "Waiting for a socket to become active"
+ #'wait-function
+ (wait-list-waiters wait-list))))
+ (dolist (x (wait-list-waiters wait-list))
+ (mp:unnotice-fd (os-socket-handle x)))
+ wait-list))
+
+) ; end of block
+
+
+;;;
+;;; The Windows side of the story
+;;; We want to wait without busy looping
+;;; This code only works in threads which don't have (hidden)
+;;; windows which need to receive messages. There are workarounds in the Windows API
+;;; but are those available to 'us'.
+;;;
+
+
+#+win32
+(progn
+
+ ;; LispWorks doesn't provide an interface to wait for a socket
+ ;; to become ready (under Win32, that is) meaning that we need
+ ;; to resort to system calls to achieve the same thing.
+ ;; Luckily, it provides us access to the raw socket handles (as we
+ ;; wrote the code above.
+
+ (defconstant fd-read 1)
+ (defconstant fd-read-bit 0)
+ (defconstant fd-write 2)
+ (defconstant fd-write-bit 1)
+ (defconstant fd-oob 4)
+ (defconstant fd-oob-bit 2)
+ (defconstant fd-accept 8)
+ (defconstant fd-accept-bit 3)
+ (defconstant fd-connect 16)
+ (defconstant fd-connect-bit 4)
+ (defconstant fd-close 32)
+ (defconstant fd-close-bit 5)
+ (defconstant fd-qos 64)
+ (defconstant fd-qos-bit 6)
+ (defconstant fd-group-qos 128)
+ (defconstant fd-group-qos-bit 7)
+ (defconstant fd-routing-interface 256)
+ (defconstant fd-routing-interface-bit 8)
+ (defconstant fd-address-list-change 512)
+ (defconstant fd-address-list-change-bit 9)
+
+ (defconstant fd-max-events 10)
+
+ (defconstant fionread 1074030207)
+
+
+ ;; Note:
+ ;;
+ ;; If special finalization has to occur for a given
+ ;; system resource (handle), an associated object should
+ ;; be created. A special cleanup action should be added
+ ;; to the system and a special cleanup action should
+ ;; be flagged on all objects created for resources like it
+ ;;
+ ;; We have 2 functions to do so:
+ ;; * hcl:add-special-free-action (function-symbol)
+ ;; * hcl:flag-special-free-action (object)
+ ;;
+ ;; Note that the special free action will be called on all
+ ;; objects which have been flagged for special free, so be
+ ;; sure to check for the right argument type!
+
+ (fli:define-foreign-type ws-socket () '(:unsigned :int))
+ (fli:define-foreign-type win32-handle () '(:unsigned :int))
+ (fli:define-c-struct wsa-network-events
+ (network-events :long)
+ (error-code (:c-array :int 10)))
+
+ (fli:define-foreign-function (wsa-event-create "WSACreateEvent" :source)
+ ()
+ :lambda-list nil
+ :result-type :int
+ :module "ws2_32")
+
+ (fli:define-foreign-function (wsa-event-close "WSACloseEvent" :source)
+ ((event-object win32-handle))
+ :result-type :int
+ :module "ws2_32")
+
+ (fli:define-foreign-function (wsa-enum-network-events "WSAEnumNetworkEvents" :source)
+ ((socket ws-socket)
+ (event-object win32-handle)
+ (network-events (:reference-return wsa-network-events)))
+ :result-type :int
+ :module "ws2_32")
+
+ (fli:define-foreign-function (wsa-event-select "WSAEventSelect" :source)
+ ((socket ws-socket)
+ (event-object win32-handle)
+ (network-events :long))
+ :result-type :int
+ :module "ws2_32")
+
+ (fli:define-foreign-function (wsa-get-last-error "WSAGetLastError" :source)
+ ()
+ :result-type :int
+ :module "ws2_32")
+
+ (fli:define-foreign-function (wsa-ioctlsocket "ioctlsocket" :source)
+ ((socket :long) (cmd :long) (argp (:ptr :long)))
+ :result-type :int
+ :module "ws2_32")
+
+
+ ;; The Windows system
+
+
+ ;; Now that we have access to the system calls, this is the plan:
+
+ ;; 1. Receive a wait-list with associated sockets to wait for
+ ;; 2. Add all those sockets to an event handle
+ ;; 3. Listen for an event on that handle (we have a LispWorks system:: internal for that)
+ ;; 4. After listening, detect if there are errors
+ ;; (this step is different from Unix, where we can have only one error)
+ ;; 5. If so, raise one of them
+ ;; 6. If not so, return the sockets which have input waiting for them
+
+
+ (defun maybe-wsa-error (rv &optional socket)
+ (unless (zerop rv)
+ (raise-usock-err (wsa-get-last-error) socket)))
+
+ (defun bytes-available-for-read (socket)
+ (fli:with-dynamic-foreign-objects ((int-ptr :long))
+ (let ((rv (wsa-ioctlsocket (os-socket-handle socket) fionread int-ptr)))
+ (if (= 0 rv)
+ (fli:dereference int-ptr)
+ 0))))
+
+ (defun socket-ready-p (socket)
+ (if (typep socket 'stream-usocket)
+ (< 0 (bytes-available-for-read socket))
+ (%ready-p socket)))
+
+ (defun waiting-required (sockets)
+ (notany #'socket-ready-p sockets))
+
+ (defun wait-for-input-internal (wait-list &key timeout)
+ (when (waiting-required (wait-list-waiters wait-list))
+ (system:wait-for-single-object (wait-list-%wait wait-list)
+ "Waiting for socket activity" timeout))
+ (update-ready-and-state-slots (wait-list-waiters wait-list)))
+
+ (defun map-network-events (func network-events)
+ (let ((event-map (fli:foreign-slot-value network-events 'network-events))
+ (error-array (fli:foreign-slot-pointer network-events 'error-code)))
+ (unless (zerop event-map)
+ (dotimes (i fd-max-events)
+ (unless (zerop (ldb (byte 1 i) event-map)) ;;### could be faster with ash and logand?
+ (funcall func (fli:foreign-aref error-array i)))))))
+
+ (defun update-ready-and-state-slots (sockets)
+ (dolist (socket sockets)
+ (if (or (and (stream-usocket-p socket)
+ (listen (socket-stream socket)))
+ (%ready-p socket))
+ (setf (state socket) :READ)
+ (multiple-value-bind
+ (rv network-events)
+ (wsa-enum-network-events (os-socket-handle socket) 0 t)
+ (if (zerop rv)
+ (map-network-events #'(lambda (err-code)
+ (if (zerop err-code)
+ (setf (%ready-p socket) t
+ (state socket) :READ)
+ (raise-usock-err err-code socket)))
+ network-events)
+ (maybe-wsa-error rv socket))))))
+
+ ;; The wait-list part
+
+ (defun free-wait-list (wl)
+ (when (wait-list-p wl)
+ (unless (null (wait-list-%wait wl))
+ (wsa-event-close (wait-list-%wait wl))
+ (setf (wait-list-%wait wl) nil))))
+
+ (eval-when (:load-toplevel :execute)
+ (hcl:add-special-free-action 'free-wait-list))
+
+ (defun %setup-wait-list (wait-list)
+ (hcl:flag-special-free-action wait-list)
+ (setf (wait-list-%wait wait-list) (wsa-event-create)))
+
+ (defun %add-waiter (wait-list waiter)
+ (let ((events (etypecase waiter
+ (stream-server-usocket (logior fd-connect fd-accept fd-close))
+ (stream-usocket (logior fd-connect fd-read fd-oob fd-close))
+ (datagram-usocket (logior fd-read)))))
+ (maybe-wsa-error
+ (wsa-event-select (os-socket-handle waiter) (wait-list-%wait wait-list) events)
+ waiter)))
+
+ (defun %remove-waiter (wait-list waiter)
+ (maybe-wsa-error
+ (wsa-event-select (os-socket-handle waiter) (wait-list-%wait wait-list) 0)
+ waiter))
+
+) ; end of WIN32-block
+
+(defun set-socket-reuse-address (socket-fd reuse-address-p)
+ (declare (type integer socket-fd)
+ (type boolean reuse-address-p))
+ (fli:with-dynamic-foreign-objects ((value :int))
+ (setf (fli:dereference value) (if reuse-address-p 1 0))
+ (if (zerop (comm::setsockopt socket-fd
+ comm::*sockopt_sol_socket*
+ comm::*sockopt_so_reuseaddr*
+ (fli:copy-pointer value
+ :type '(:pointer :void))
+ (fli:size-of :int)))
+ reuse-address-p)))
+
+(defun get-socket-reuse-address (socket-fd)
+ (declare (type integer socket-fd))
+ (fli:with-dynamic-foreign-objects ((value :int) (len :int))
+ (if (zerop (comm::getsockopt socket-fd
+ comm::*sockopt_sol_socket*
+ comm::*sockopt_so_reuseaddr*
+ (fli:copy-pointer value
+ :type '(:pointer :void))
+ len))
+ (= 1 (fli:dereference value)))))
--- /dev/null
+;;;; $Id$
+;;;; $URL$
+
+;; MCL backend for USOCKET 0.4.1
+;; Terje Norderhaug <terje@in-progress.com>, January 1, 2009
+
+(in-package :usocket)
+
+(defun handle-condition (condition &optional socket)
+ ; incomplete, needs to handle additional conditions
+ (flet ((raise-error (&optional socket-condition)
+ (if socket-condition
+ (error socket-condition :socket socket)
+ (error 'unknown-error :socket socket :real-error condition))))
+ (typecase condition
+ (ccl:host-stopped-responding
+ (raise-error 'host-down-error))
+ (ccl:host-not-responding
+ (raise-error 'host-unreachable-error))
+ (ccl:connection-reset
+ (raise-error 'connection-reset-error))
+ (ccl:connection-timed-out
+ (raise-error 'timeout-error))
+ (ccl:opentransport-protocol-error
+ (raise-error 'protocol-not-supported-error))
+ (otherwise
+ (raise-error)))))
+
+(defun socket-connect (host port &key (element-type 'character) timeout deadline nodelay
+ local-host local-port (protocol :stream))
+ (when (eq nodelay :if-supported)
+ (setf nodelay t))
+ (ecase protocol
+ (:stream
+ (with-mapped-conditions ()
+ (let* ((socket
+ (make-instance 'active-socket
+ :remote-host (when host (host-to-hostname host))
+ :remote-port port
+ :local-host (when local-host (host-to-hostname local-host))
+ :local-port local-port
+ :deadline deadline
+ :nodelay nodelay
+ :connect-timeout (and timeout (round (* timeout 60)))
+ :element-type element-type))
+ (stream (socket-open-stream socket)))
+ (make-stream-socket :socket socket :stream stream))))
+ (:datagram
+ (with-mapped-conditions ()
+ (make-datagram-socket
+ (ccl::open-udp-socket :local-address (and local-host (host-to-hbo local-host))
+ :local-port local-port))))))
+
+(defun socket-listen (host port
+ &key reuseaddress
+ (reuse-address nil reuse-address-supplied-p)
+ (backlog 5)
+ (element-type 'character))
+ (let* ((reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress))
+ (socket (with-mapped-conditions ()
+ (make-instance 'passive-socket
+ :local-port port
+ :local-host (host-to-hbo host)
+ :reuse-address reuseaddress
+ :backlog backlog))))
+ (make-stream-server-socket socket :element-type element-type)))
+
+(defmethod socket-accept ((usocket stream-server-usocket) &key element-type)
+ (let* ((socket (socket usocket))
+ (stream (with-mapped-conditions (usocket)
+ (socket-accept socket :element-type element-type))))
+ (make-stream-socket :socket socket :stream stream)))
+
+(defmethod socket-close ((usocket usocket))
+ (with-mapped-conditions (usocket)
+ (socket-close (socket usocket))))
+
+(defmethod socket-shutdown ((usocket usocket) direction)
+ (declare (ignore usocket direction))
+ ;; As far as I can tell there isn't a way to shutdown a socket in mcl.
+ (unsupported "shutdown" 'socket-shutdown))
+
+(defmethod ccl::stream-close ((usocket usocket))
+ (socket-close usocket))
+
+(defun get-hosts-by-name (name)
+ (with-mapped-conditions ()
+ (list (hbo-to-vector-quad (ccl::get-host-address
+ (host-to-hostname name))))))
+
+(defun get-host-by-address (address)
+ (with-mapped-conditions ()
+ (ccl::inet-host-name (host-to-hbo address))))
+
+(defmethod get-local-name ((usocket usocket))
+ (values (get-local-address usocket)
+ (get-local-port usocket)))
+
+(defmethod get-peer-name ((usocket stream-usocket))
+ (values (get-peer-address usocket)
+ (get-peer-port usocket)))
+
+(defmethod get-local-address ((usocket usocket))
+ (hbo-to-vector-quad (ccl::get-host-address (or (local-host (socket usocket)) ""))))
+
+(defmethod get-local-port ((usocket usocket))
+ (local-port (socket usocket)))
+
+(defmethod get-peer-address ((usocket stream-usocket))
+ (hbo-to-vector-quad (ccl::get-host-address (remote-host (socket usocket)))))
+
+(defmethod get-peer-port ((usocket stream-usocket))
+ (remote-port (socket usocket)))
+
+
+(defun %setup-wait-list (wait-list)
+ (declare (ignore wait-list)))
+
+(defun %add-waiter (wait-list waiter)
+ (declare (ignore wait-list waiter)))
+
+(defun %remove-waiter (wait-list waiter)
+ (declare (ignore wait-list waiter)))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; BASIC MCL SOCKET IMPLEMENTATION
+
+(defclass socket ()
+ ((local-port :reader local-port :initarg :local-port)
+ (local-host :reader local-host :initarg :local-host)
+ (element-type :reader element-type :initform 'ccl::base-character :initarg :element-type)))
+
+(defclass active-socket (socket)
+ ((remote-host :reader remote-host :initarg :remote-host)
+ (remote-port :reader remote-port :initarg :remote-port)
+ (deadline :initarg :deadline)
+ (nodelay :initarg :nodelay)
+ (connect-timeout :reader connect-timeout :initform NIL :initarg :connect-timeout
+ :type (or null fixnum) :documentation "ticks (60th of a second)")))
+
+(defmethod socket-open-stream ((socket active-socket))
+ (ccl::open-tcp-stream (or (remote-host socket)(ccl::local-interface-ip-address)) (remote-port socket)
+ :element-type (if (subtypep (element-type socket) 'character) 'ccl::base-character 'unsigned-byte)
+ :connect-timeout (connect-timeout socket)))
+
+(defmethod socket-close ((socket active-socket))
+ NIL)
+
+(defclass passive-socket (socket)
+ ((streams :accessor socket-streams :type list :initform NIL
+ :documentation "Circular list of streams with first element the next to open")
+ (reuse-address :reader reuse-address :initarg :reuse-address)
+ (lock :reader socket-lock :initform (ccl:make-lock "Socket"))))
+
+(defmethod initialize-instance :after ((socket passive-socket) &key backlog)
+ (loop repeat backlog
+ collect (socket-open-listener socket) into streams
+ finally (setf (socket-streams socket)
+ (cdr (rplacd (last streams) streams))))
+ (when (zerop (local-port socket))
+ (setf (slot-value socket 'local-port)
+ (or (ccl::process-wait-with-timeout "binding port" (* 10 60)
+ #'ccl::stream-local-port (car (socket-streams socket)))
+ (error "timeout")))))
+
+(defmethod socket-accept ((socket passive-socket) &key element-type &aux (lock (socket-lock socket)))
+ (flet ((connection-established-p (stream)
+ (ccl::with-io-buffer-locked ((ccl::stream-io-buffer stream nil))
+ (let ((state (ccl::opentransport-stream-connection-state stream)))
+ (not (eq :unbnd state))))))
+ (with-mapped-conditions ()
+ (ccl:with-lock-grabbed (lock nil "Socket Lock")
+ (let ((connection (shiftf (car (socket-streams socket))
+ (socket-open-listener socket element-type))))
+ (pop (socket-streams socket))
+ (ccl:process-wait "Accepting" #'connection-established-p connection)
+ connection)))))
+
+(defmethod socket-close ((socket passive-socket))
+ (loop
+ with streams = (socket-streams socket)
+ for (stream tail) on streams
+ do (close stream :abort T)
+ until (eq tail streams)
+ finally (setf (socket-streams socket) NIL)))
+
+(defmethod socket-open-listener (socket &optional element-type)
+ ; see http://code.google.com/p/mcl/issues/detail?id=28
+ (let* ((ccl::*passive-interface-address* (local-host socket))
+ (new (ccl::open-tcp-stream NIL (or (local-port socket) #$kOTAnyInetAddress)
+ :reuse-local-port-p (reuse-address socket)
+ :element-type (if (subtypep (or element-type (element-type socket))
+ 'character)
+ 'ccl::base-character
+ 'unsigned-byte))))
+ (declare (special ccl::*passive-interface-address*))
+ new))
+
+(defmethod input-available-p ((stream ccl::opentransport-stream))
+ (macrolet ((when-io-buffer-lock-grabbed ((lock &optional multiple-value-p) &body body)
+ "Evaluates the body if and only if the lock is successfully grabbed"
+ ;; like with-io-buffer-lock-grabbed but returns immediately instead of polling the lock
+ (let ((needs-unlocking-p (gensym))
+ (lock-var (gensym)))
+ `(let* ((,lock-var ,lock)
+ (ccl::*grabbed-io-buffer-locks* (cons ,lock-var ccl::*grabbed-io-buffer-locks*))
+ (,needs-unlocking-p (needs-unlocking-p ,lock-var)))
+ (declare (dynamic-extent ccl::*grabbed-io-buffer-locks*))
+ (when ,needs-unlocking-p
+ (,(if multiple-value-p 'multiple-value-prog1 'prog1)
+ (progn ,@body)
+ (ccl::%release-io-buffer-lock ,lock-var)))))))
+ (labels ((needs-unlocking-p (lock)
+ (declare (type ccl::lock lock))
+ ;; crucial - clears bogus lock.value as in grab-io-buffer-lock-out-of-line:
+ (ccl::%io-buffer-lock-really-grabbed-p lock)
+ (ccl:store-conditional lock nil ccl:*current-process*)))
+ "similar to stream-listen on buffered-input-stream-mixin but without waiting for lock"
+ (let ((io-buffer (ccl::stream-io-buffer stream)))
+ (or (not (eql 0 (ccl::io-buffer-incount io-buffer)))
+ (ccl::io-buffer-untyi-char io-buffer)
+ (locally (declare (optimize (speed 3) (safety 0)))
+ (when-io-buffer-lock-grabbed ((ccl::io-buffer-lock io-buffer))
+ (funcall (ccl::io-buffer-listen-function io-buffer) stream io-buffer))))))))
+
+(defmethod connection-established-p ((stream ccl::opentransport-stream))
+ (ccl::with-io-buffer-locked ((ccl::stream-io-buffer stream nil))
+ (let ((state (ccl::opentransport-stream-connection-state stream)))
+ (not (eq :unbnd state)))))
+
+(defun wait-for-input-internal (wait-list &key timeout &aux result)
+ (labels ((ready-sockets (sockets)
+ (dolist (sock sockets result)
+ (when (cond ((stream-usocket-p sock)
+ (input-available-p (socket-stream sock)))
+ ((stream-server-usocket-p sock)
+ (let ((ot-stream (first (socket-streams (socket sock)))))
+ (or (input-available-p ot-stream)
+ (connection-established-p ot-stream)))))
+ (push sock result)))))
+ (with-mapped-conditions ()
+ (ccl:process-wait-with-timeout
+ "socket input"
+ (when timeout (truncate (* timeout 60)))
+ #'ready-sockets
+ (wait-list-waiters wait-list)))
+ (nreverse result)))
+
+;;; datagram socket methods
+
+(defmethod initialize-instance :after ((usocket datagram-usocket) &key)
+ (with-slots (socket send-buffer recv-buffer) usocket
+ (setq send-buffer
+ (ccl::make-TUnitData (ccl::ot-conn-endpoint socket)))
+ (setq recv-buffer
+ (ccl::make-TUnitData (ccl::ot-conn-endpoint socket)))))
+
+(defmethod socket-send ((usocket datagram-usocket) buffer size &key host port (offset 0))
+ (with-mapped-conditions (usocket)
+ (with-slots (socket send-buffer) usocket
+ (unless (and host port)
+ (unsupported 'host 'socket-send))
+ (ccl::send-message socket send-buffer buffer size host port offset))))
+
+(defmethod socket-receive ((usocket datagram-usocket) buffer length &key)
+ (with-mapped-conditions (usocket)
+ (with-slots (socket recv-buffer) usocket
+ (ccl::receive-message socket recv-buffer buffer length))))
+
+(defmethod socket-close ((socket datagram-usocket))
+ nil) ; TODO
--- /dev/null
+;;;; $Id$
+;;;; $URL$
+
+;;;; See LICENSE for licensing information.
+
+(in-package :usocket)
+
+(defun handle-condition (condition &optional (socket nil))
+ "Dispatch correct usocket condition."
+ (declare (ignore socket))
+ (signal condition))
+
+(defun socket-connect (host port &key (protocol :stream) (element-type 'character)
+ timeout deadline (nodelay t nodelay-specified)
+ (local-host nil local-host-p)
+ (local-port nil local-port-p))
+ (when (and nodelay-specified
+ (not (eq nodelay :if-supported)))
+ (unsupported 'nodelay 'socket-connect))
+ (when deadline (unsupported 'deadline 'socket-connect))
+ (when timeout (unimplemented 'timeout 'socket-connect))
+ (when local-host-p
+ (unimplemented 'local-host 'socket-connect))
+ (when local-port-p
+ (unimplemented 'local-port 'socket-connect))
+
+ (let (socket)
+ (ecase protocol
+ (:stream
+ (setf socket (rt::socket-connect host port))
+ (let ((stream (rt::make-socket-stream socket :binaryp (not (eq element-type 'character)))))
+ (make-stream-socket :socket socket :stream stream)))
+ (:datagram
+ (error 'unsupported
+ :feature '(protocol :datagram)
+ :context 'socket-connect)))))
+
+(defun socket-listen (host port
+ &key reuseaddress
+ (reuse-address nil reuse-address-supplied-p)
+ (backlog 5)
+ (element-type 'character))
+ (unimplemented 'socket-listen 'mocl))
+
+(defmethod socket-accept ((usocket stream-server-usocket) &key element-type)
+ (unimplemented 'socket-accept 'mocl))
+
+;; Sockets and their associated streams are modelled as
+;; different objects. Be sure to close the socket stream
+;; when closing stream-sockets; it makes sure buffers
+;; are flushed and the socket is closed correctly afterwards.
+(defmethod socket-close ((usocket usocket))
+ "Close socket."
+ (when (wait-list usocket)
+ (remove-waiter (wait-list usocket) usocket))
+ (rt::socket-shutdown usocket)
+ (rt::c-fclose usocket))
+
+(defmethod socket-close ((usocket stream-usocket))
+ "Close socket."
+ (when (wait-list usocket)
+ (remove-waiter (wait-list usocket) usocket))
+ (close (socket-stream usocket)))
+
+;; (defmethod socket-close :after ((socket datagram-usocket))
+;; (setf (%open-p socket) nil))
+
+(defmethod socket-shutdown ((usocket stream-usocket) direction)
+ (declare (ignore usocket direction))
+ ;; sure would be nice if there was some documentation for mocl...
+ (unimplemented "shutdown" 'socket-shutdown))
+
+;; (defmethod socket-send ((usocket datagram-usocket) buffer size &key host port)
+;; (let ((s (socket usocket))
+;; (host (if host (host-to-hbo host)))
+;; (real-buffer (if (zerop offset)
+;; buffer
+;; (subseq buffer offset (+ offset size)))))
+;; (multiple-value-bind (result errno)
+;; (ext:inet-socket-send-to s real-buffer size
+;; :remote-host host :remote-port port)
+;; (or result
+;; (mocl-map-socket-error errno :socket usocket)))))
+
+;; (defmethod socket-receive ((socket datagram-usocket) buffer length &key)
+;; (declare (values (simple-array (unsigned-byte 8) (*)) ; buffer
+;; (integer 0) ; size
+;; (unsigned-byte 32) ; host
+;; (unsigned-byte 16))) ; port
+;; (let ((s (socket socket)))
+;; (let ((real-buffer (or buffer
+;; (make-array length :element-type '(unsigned-byte 8))))
+;; (real-length (or length
+;; (length buffer))))
+;; (multiple-value-bind (result errno remote-host remote-port)
+;; (ext:inet-socket-receive-from s real-buffer real-length)
+;; (if result
+;; (values real-buffer result remote-host remote-port)
+;; (mocl-map-socket-error errno :socket socket))))))
+
+;; (defmethod get-local-name ((usocket usocket))
+;; (multiple-value-bind (address port)
+;; (with-mapped-conditions (usocket)
+;; (ext:get-socket-host-and-port (socket usocket)))
+;; (values (hbo-to-vector-quad address) port)))
+
+;; (defmethod get-peer-name ((usocket stream-usocket))
+;; (multiple-value-bind (address port)
+;; (with-mapped-conditions (usocket)
+;; (ext:get-peer-host-and-port (socket usocket)))
+;; (values (hbo-to-vector-quad address) port)))
+
+;; (defmethod get-local-address ((usocket usocket))
+;; (nth-value 0 (get-local-name usocket)))
+
+;; (defmethod get-peer-address ((usocket stream-usocket))
+;; (nth-value 0 (get-peer-name usocket)))
+
+;; (defmethod get-local-port ((usocket usocket))
+;; (nth-value 1 (get-local-name usocket)))
+
+;; (defmethod get-peer-port ((usocket stream-usocket))
+;; (nth-value 1 (get-peer-name usocket)))
+
+
+;; (defun get-host-by-address (address)
+;; (multiple-value-bind (host errno)
+;; (ext:lookup-host-entry (host-byte-order address))
+;; (cond (host
+;; (ext:host-entry-name host))
+;; (t
+;; (let ((condition (cdr (assoc errno +unix-ns-error-map+))))
+;; (cond (condition
+;; (error condition :host-or-ip address))
+;; (t
+;; (error 'ns-unknown-error :host-or-ip address
+;; :real-error errno))))))))
+
+(defun get-hosts-by-name (name)
+ (rt::lookup-host name))
+
+;; (defun get-host-name ()
+;; (unix:unix-gethostname))
+
+
+;;
+;;
+;; WAIT-LIST part
+;;
+
+
+(defun %add-waiter (wl waiter)
+ (declare (ignore wl waiter)))
+
+(defun %remove-waiter (wl waiter)
+ (declare (ignore wl waiter)))
+
+(defun %setup-wait-list (wl)
+ (declare (ignore wl)))
+
+(defun wait-for-input-internal (wait-list &key timeout)
+ (unimplemented 'wait-for-input-internal 'mocl))
--- /dev/null
+;;;; See LICENSE for licensing information.
+
+(in-package :usocket)
+
+(defun get-host-name ()
+ (ccl::%stack-block ((resultbuf 256))
+ (when (zerop (#_gethostname resultbuf 256))
+ (ccl::%get-cstring resultbuf))))
+
+(defparameter +openmcl-error-map+
+ '((:address-in-use . address-in-use-error)
+ (:connection-aborted . connection-aborted-error)
+ (:no-buffer-space . no-buffers-error)
+ (:connection-timed-out . timeout-error)
+ (:connection-refused . connection-refused-error)
+ (:host-unreachable . host-unreachable-error)
+ (:host-down . host-down-error)
+ (:network-down . network-down-error)
+ (:address-not-available . address-not-available-error)
+ (:network-reset . network-reset-error)
+ (:connection-reset . connection-reset-error)
+ (:shutdown . shutdown-error)
+ (:access-denied . operation-not-permitted-error)))
+
+(defparameter +openmcl-nameserver-error-map+
+ '((:no-recovery . ns-no-recovery-error)
+ (:try-again . ns-try-again-condition)
+ (:host-not-found . ns-host-not-found-error)))
+
+;; we need something which the openmcl implementors 'forgot' to do:
+;; wait for more than one socket-or-fd
+
+(defun input-available-p (sockets &optional ticks-to-wait)
+ (ccl::rletZ ((tv :timeval))
+ (ccl::ticks-to-timeval ticks-to-wait tv)
+ ;;### The trickery below can be moved to the wait-list now...
+ (ccl::%stack-block ((infds ccl::*fd-set-size*))
+ (ccl::fd-zero infds)
+ (let ((max-fd -1))
+ (dolist (sock sockets)
+ (let ((fd (openmcl-socket:socket-os-fd (socket sock))))
+ (when fd ;; may be NIL if closed
+ (setf max-fd (max max-fd fd))
+ (ccl::fd-set fd infds))))
+ (let ((res (#_select (1+ max-fd)
+ infds (ccl::%null-ptr) (ccl::%null-ptr)
+ (if ticks-to-wait tv (ccl::%null-ptr)))))
+ (when (> res 0)
+ (dolist (sock sockets)
+ (let ((fd (openmcl-socket:socket-os-fd (socket sock))))
+ (when (and fd (ccl::fd-is-set fd infds))
+ (setf (state sock) :READ)))))
+ sockets)))))
+
+(defun raise-error-from-id (condition-id socket real-condition)
+ (let ((usock-err (cdr (assoc condition-id +openmcl-error-map+))))
+ (if usock-err
+ (error usock-err :socket socket)
+ (error 'unknown-error :socket socket :real-error real-condition))))
+
+(defun handle-condition (condition &optional socket)
+ (typecase condition
+ (openmcl-socket:socket-error
+ (raise-error-from-id (openmcl-socket:socket-error-identifier condition)
+ socket condition))
+ (ccl:input-timeout
+ (error 'timeout-error :socket socket))
+ (ccl:communication-deadline-expired
+ (error 'deadline-timeout-error :socket socket))
+ (ccl::socket-creation-error #| ugh! |#
+ (let* ((condition-id (ccl::socket-creation-error-identifier condition))
+ (nameserver-error (cdr (assoc condition-id
+ +openmcl-nameserver-error-map+))))
+ (if nameserver-error
+ (if (typep nameserver-error 'serious-condition)
+ (error nameserver-error :host-or-ip nil)
+ (signal nameserver-error :host-or-ip nil))
+ (raise-error-from-id condition-id socket condition))))))
+
+(defun to-format (element-type protocol)
+ (cond ((null element-type)
+ (ecase protocol ; default value of different protocol
+ (:stream :text)
+ (:datagram :binary)))
+ ((subtypep element-type 'character)
+ :text)
+ (t :binary)))
+
+#-ipv6
+(defun socket-connect (host port &key (protocol :stream) element-type
+ timeout deadline nodelay
+ local-host local-port)
+ (when (eq nodelay :if-supported)
+ (setf nodelay t))
+ (with-mapped-conditions ()
+ (ecase protocol
+ (:stream
+ (let ((mcl-sock
+ (openmcl-socket:make-socket :remote-host (host-to-hostname host)
+ :remote-port port
+ :local-host local-host
+ :local-port local-port
+ :format (to-format element-type protocol)
+ :external-format ccl:*default-external-format*
+ :deadline deadline
+ :nodelay nodelay
+ :connect-timeout timeout)))
+ (make-stream-socket :stream mcl-sock :socket mcl-sock)))
+ (:datagram
+ (let* ((mcl-sock
+ (openmcl-socket:make-socket :address-family :internet
+ :type :datagram
+ :local-host local-host
+ :local-port local-port
+ :input-timeout timeout
+ :format (to-format element-type protocol)
+ :external-format ccl:*default-external-format*))
+ (usocket (make-datagram-socket mcl-sock)))
+ (when (and host port)
+ (ccl::inet-connect (ccl::socket-device mcl-sock)
+ (ccl::host-as-inet-host host)
+ (ccl::port-as-inet-port port "udp")))
+ (setf (connected-p usocket) t)
+ usocket)))))
+
+#-ipv6
+(defun socket-listen (host port
+ &key reuseaddress
+ (reuse-address nil reuse-address-supplied-p)
+ (backlog 5)
+ (element-type 'character))
+ (let* ((reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress))
+ (real-host (host-to-hostname host))
+ (sock (with-mapped-conditions ()
+ (apply #'openmcl-socket:make-socket
+ (append (list :connect :passive
+ :reuse-address reuseaddress
+ :local-port port
+ :backlog backlog
+ :format (to-format element-type :stream))
+ (unless (eq host *wildcard-host*)
+ (list :local-host real-host)))))))
+ (make-stream-server-socket sock :element-type element-type)))
+
+(defmethod socket-accept ((usocket stream-server-usocket) &key element-type)
+ (declare (ignore element-type)) ;; openmcl streams are bi/multivalent
+ (let ((sock (with-mapped-conditions (usocket)
+ (openmcl-socket:accept-connection (socket usocket)))))
+ (make-stream-socket :socket sock :stream sock)))
+
+;; One close method is sufficient because sockets
+;; and their associated objects are represented
+;; by the same object.
+(defmethod socket-close ((usocket usocket))
+ (when (wait-list usocket)
+ (remove-waiter (wait-list usocket) usocket))
+ (with-mapped-conditions (usocket)
+ (close (socket usocket))))
+
+(defmethod socket-shutdown ((usocket usocket) direction)
+ (with-mapped-conditions (usocket)
+ (openmcl-socket:shutdown (socket usocket) :direction direction)))
+
+#-ipv6
+(defmethod socket-send ((usocket datagram-usocket) buffer size &key host port (offset 0))
+ (with-mapped-conditions (usocket)
+ (if (and host port)
+ (openmcl-socket:send-to (socket usocket) buffer size
+ :remote-host (host-to-hbo host)
+ :remote-port port
+ :offset offset)
+ ;; Clozure CL's socket function SEND-TO doesn't support operations on connected UDP sockets,
+ ;; so we have to define our own.
+ (let* ((socket (socket usocket))
+ (fd (ccl::socket-device socket)))
+ (multiple-value-setq (buffer offset)
+ (ccl::verify-socket-buffer buffer offset size))
+ (ccl::%stack-block ((bufptr size))
+ (ccl::%copy-ivector-to-ptr buffer offset bufptr 0 size)
+ (ccl::socket-call socket "send"
+ (ccl::with-eagain fd :output
+ (ccl::ignoring-eintr
+ (ccl::check-socket-error (#_send fd bufptr size 0))))))))))
+
+(defmethod socket-receive ((usocket datagram-usocket) buffer length &key)
+ (with-mapped-conditions (usocket)
+ (openmcl-socket:receive-from (socket usocket) length :buffer buffer)))
+
+(defun usocket-host-address (address)
+ (cond
+ ((integerp address)
+ (hbo-to-vector-quad address))
+ ((and (arrayp address)
+ (= (length address) 16)
+ (every #'= address #(0 0 0 0 0 0 0 0 0 0 #xff #xff)))
+ (make-array 4 :displaced-to address :displaced-index-offset 12))
+ (t
+ address)))
+
+(defmethod get-local-address ((usocket usocket))
+ (usocket-host-address (openmcl-socket:local-host (socket usocket))))
+
+(defmethod get-peer-address ((usocket stream-usocket))
+ (usocket-host-address (openmcl-socket:remote-host (socket usocket))))
+
+(defmethod get-local-port ((usocket usocket))
+ (openmcl-socket:local-port (socket usocket)))
+
+(defmethod get-peer-port ((usocket stream-usocket))
+ (openmcl-socket:remote-port (socket usocket)))
+
+(defmethod get-local-name ((usocket usocket))
+ (values (get-local-address usocket)
+ (get-local-port usocket)))
+
+(defmethod get-peer-name ((usocket stream-usocket))
+ (values (get-peer-address usocket)
+ (get-peer-port usocket)))
+
+(defun get-host-by-address (address)
+ (with-mapped-conditions ()
+ (openmcl-socket:ipaddr-to-hostname (host-to-hbo address))))
+
+(defun get-hosts-by-name (name)
+ (with-mapped-conditions ()
+ (list (hbo-to-vector-quad (openmcl-socket:lookup-hostname
+ (host-to-hostname name))))))
+
+(defun %setup-wait-list (wait-list)
+ (declare (ignore wait-list)))
+
+(defun %add-waiter (wait-list waiter)
+ (declare (ignore wait-list waiter)))
+
+(defun %remove-waiter (wait-list waiter)
+ (declare (ignore wait-list waiter)))
+
+(defun wait-for-input-internal (wait-list &key timeout)
+ (with-mapped-conditions ()
+ (let* ((ticks-timeout (truncate (* (or timeout 1)
+ ccl::*ticks-per-second*))))
+ (input-available-p (wait-list-waiters wait-list)
+ (when timeout ticks-timeout))
+ wait-list)))
+
+;;; Helper functions for option.lisp
+
+(defun get-socket-option-reuseaddr (socket)
+ (ccl::int-getsockopt (ccl::socket-device socket)
+ #$SOL_SOCKET #$SO_REUSEADDR))
+
+(defun set-socket-option-reuseaddr (socket value)
+ (ccl::int-setsockopt (ccl::socket-device socket)
+ #$SOL_SOCKET #$SO_REUSEADDR value))
+
+(defun get-socket-option-broadcast (socket)
+ (ccl::int-getsockopt (ccl::socket-device socket)
+ #$SOL_SOCKET #$SO_BROADCAST))
+
+(defun set-socket-option-broadcast (socket value)
+ (ccl::int-setsockopt (ccl::socket-device socket)
+ #$SOL_SOCKET #$SO_BROADCAST value))
+
+(defun get-socket-option-tcp-nodelay (socket)
+ (ccl::int-getsockopt (ccl::socket-device socket)
+ #$IPPROTO_TCP #$TCP_NODELAY))
+
+(defun set-socket-option-tcp-nodelay (socket value)
+ (ccl::int-setsockopt (ccl::socket-device socket)
+ #$IPPROTO_TCP #$TCP_NODELAY value))
--- /dev/null
+;;;; -*- Mode: Common-Lisp -*-
+
+;;;; See LICENSE for licensing information.
+
+(in-package :usocket)
+
+#+sbcl
+(progn
+ #-win32
+ (defun get-host-name ()
+ (sb-unix:unix-gethostname))
+
+ ;; we assume winsock has already been loaded, after all,
+ ;; we already loaded sb-bsd-sockets and sb-alien
+ #+win32
+ (defun get-host-name ()
+ (sb-alien:with-alien ((buf (sb-alien:array sb-alien:char 256)))
+ (let ((result (sb-alien:alien-funcall
+ (sb-alien:extern-alien "gethostname"
+ (sb-alien:function sb-alien:int
+ (* sb-alien:char)
+ sb-alien:int))
+ (sb-alien:cast buf (* sb-alien:char))
+ 256)))
+ (when (= result 0)
+ (sb-alien:cast buf sb-alien:c-string))))))
+
+#+(and ecl (not ecl-bytecmp))
+(progn
+ #-:wsock
+ (ffi:clines
+ "#include <errno.h>"
+ "#include <sys/socket.h>"
+ "#include <unistd.h>")
+ #+:wsock
+ (ffi:clines
+ "#ifndef FD_SETSIZE"
+ "#define FD_SETSIZE 1024"
+ "#endif"
+ "#include <winsock2.h>")
+
+ (ffi:clines
+ #+:msvc "#include <time.h>"
+ #-:msvc "#include <sys/time.h>"
+ "#include <ecl/ecl-inl.h>")
+#|
+ #+:prefixed-api
+ (ffi:clines
+ "#define CONS(x, y) ecl_cons((x), (y))"
+ "#define MAKE_INTEGER(x) ecl_make_integer((x))")
+ #-:prefixed-api
+ (ffi:clines
+ "#define CONS(x, y) make_cons((x), (y))"
+ "#define MAKE_INTEGER(x) make_integer((x))")
+|#
+
+ (defun cerrno ()
+ (ffi:c-inline () () :int
+ "errno" :one-liner t))
+
+ (defun fd-setsize ()
+ (ffi:c-inline () () :fixnum
+ "FD_SETSIZE" :one-liner t))
+
+ (defun fdset-alloc ()
+ (ffi:c-inline () () :pointer-void
+ "ecl_alloc_atomic(sizeof(fd_set))" :one-liner t))
+
+ (defun fdset-zero (fdset)
+ (ffi:c-inline (fdset) (:pointer-void) :void
+ "FD_ZERO((fd_set*)#0)" :one-liner t))
+
+ (defun fdset-set (fdset fd)
+ (ffi:c-inline (fdset fd) (:pointer-void :fixnum) :void
+ "FD_SET(#1,(fd_set*)#0)" :one-liner t))
+
+ (defun fdset-clr (fdset fd)
+ (ffi:c-inline (fdset fd) (:pointer-void :fixnum) :void
+ "FD_CLR(#1,(fd_set*)#0)" :one-liner t))
+
+ (defun fdset-fd-isset (fdset fd)
+ (ffi:c-inline (fdset fd) (:pointer-void :fixnum) :bool
+ "FD_ISSET(#1,(fd_set*)#0)" :one-liner t))
+
+ (declaim (inline cerrno
+ fd-setsize
+ fdset-alloc
+ fdset-zero
+ fdset-set
+ fdset-clr
+ fdset-fd-isset))
+
+ (defun get-host-name ()
+ (ffi:c-inline
+ () () :object
+ "{ char *buf = (char *) ecl_alloc_atomic(257);
+
+ if (gethostname(buf,256) == 0)
+ @(return) = make_simple_base_string(buf);
+ else
+ @(return) = Cnil;
+ }" :one-liner nil :side-effects nil))
+
+ (defun read-select (wl to-secs &optional (to-musecs 0))
+ (let* ((sockets (wait-list-waiters wl))
+ (rfds (wait-list-%wait wl))
+ (max-fd (reduce #'(lambda (x y)
+ (let ((sy (sb-bsd-sockets:socket-file-descriptor
+ (socket y))))
+ (if (< x sy) sy x)))
+ (cdr sockets)
+ :initial-value (sb-bsd-sockets:socket-file-descriptor
+ (socket (car sockets))))))
+ (fdset-zero rfds)
+ (dolist (sock sockets)
+ (fdset-set rfds (sb-bsd-sockets:socket-file-descriptor
+ (socket sock))))
+ (let ((count
+ (ffi:c-inline (to-secs to-musecs rfds max-fd)
+ (t :unsigned-int :pointer-void :int)
+ :int
+ "
+ int count;
+ struct timeval tv;
+
+ if (#0 != Cnil) {
+ tv.tv_sec = fixnnint(#0);
+ tv.tv_usec = #1;
+ }
+ @(return) = select(#3 + 1, (fd_set*)#2, NULL, NULL,
+ (#0 != Cnil) ? &tv : NULL);
+" :one-liner nil)))
+ (cond
+ ((= 0 count)
+ (values nil nil))
+ ((< count 0)
+ ;; check for EINTR and EAGAIN; these should not err
+ (values nil (cerrno)))
+ (t
+ (dolist (sock sockets)
+ (when (fdset-fd-isset rfds (sb-bsd-sockets:socket-file-descriptor
+ (socket sock)))
+ (setf (state sock) :READ))))))))
+) ; progn
+
+(defun map-socket-error (sock-err)
+ (map-errno-error (sb-bsd-sockets::socket-error-errno sock-err)))
+
+(defparameter +sbcl-condition-map+
+ '((interrupted-error . interrupted-condition)))
+
+(defparameter +sbcl-error-map+
+ `((sb-bsd-sockets:address-in-use-error . address-in-use-error)
+ (sb-bsd-sockets::no-address-error . address-not-available-error)
+ (sb-bsd-sockets:bad-file-descriptor-error . bad-file-descriptor-error)
+ (sb-bsd-sockets:connection-refused-error . connection-refused-error)
+ (sb-bsd-sockets:invalid-argument-error . invalid-argument-error)
+ (sb-bsd-sockets:no-buffers-error . no-buffers-error)
+ (sb-bsd-sockets:operation-not-supported-error
+ . operation-not-supported-error)
+ (sb-bsd-sockets:operation-not-permitted-error
+ . operation-not-permitted-error)
+ (sb-bsd-sockets:protocol-not-supported-error
+ . protocol-not-supported-error)
+ #-ecl
+ (sb-bsd-sockets:unknown-protocol
+ . protocol-not-supported-error)
+ (sb-bsd-sockets:socket-type-not-supported-error
+ . socket-type-not-supported-error)
+ (sb-bsd-sockets:network-unreachable-error . network-unreachable-error)
+ (sb-bsd-sockets:operation-timeout-error . timeout-error)
+ #-ecl
+ (sb-sys:io-timeout . timeout-error)
+ #+sbcl
+ (sb-ext:timeout . timeout-error)
+ (sb-bsd-sockets:socket-error . ,#'map-socket-error)
+
+ ;; Nameservice errors: mapped to unknown-error
+ #-ecl
+ (sb-bsd-sockets:no-recovery-error . ns-no-recovery-error)
+ #-ecl
+ (sb-bsd-sockets:try-again-error . ns-try-again-condition)
+ #-ecl
+ (sb-bsd-sockets:host-not-found-error . ns-host-not-found-error)))
+
+(defun handle-condition (condition &optional (socket nil))
+ "Dispatch correct usocket condition."
+ (typecase condition
+ (serious-condition (let* ((usock-error (cdr (assoc (type-of condition)
+ +sbcl-error-map+)))
+ (usock-error (if (functionp usock-error)
+ (funcall usock-error condition)
+ usock-error)))
+ (when usock-error
+ (error usock-error :socket socket))))
+ (condition (let* ((usock-cond (cdr (assoc (type-of condition)
+ +sbcl-condition-map+)))
+ (usock-cond (if (functionp usock-cond)
+ (funcall usock-cond condition)
+ usock-cond)))
+ (if usock-cond
+ (signal usock-cond :socket socket))))))
+
+;;; "The socket stream ends up with a bogus name as it is created before
+;;; the socket is connected, making things harder to debug than they need
+;;; to be." -- Nikodemus Siivola <nikodemus@random-state.net>
+
+(defvar *dummy-stream*
+ (let ((stream (make-broadcast-stream)))
+ (close stream)
+ stream))
+
+;;; Amusingly, neither SBCL's own, nor GBBopen's WITH-TIMEOUT is asynch
+;;; unwind safe. The one I posted is -- that's what the WITHOUT-INTERRUPTS
+;;; and WITH-LOCAL-INTERRUPTS were for. :) But yeah, it's miles saner than
+;;; the SB-EXT:WITH-TIMEOUT. -- Nikodemus Siivola <nikodemus@random-state.net>
+
+#+(and sbcl (not win32))
+(defmacro %with-timeout ((seconds timeout-form) &body body)
+ "Runs BODY as an implicit PROGN with timeout of SECONDS. If
+timeout occurs before BODY has finished, BODY is unwound and
+TIMEOUT-FORM is executed with its values returned instead.
+
+Note that BODY is unwound asynchronously when a timeout occurs,
+so unless all code executed during it -- including anything
+down the call chain -- is asynch unwind safe, bad things will
+happen. Use with care."
+ (let ((exec (gensym)) (unwind (gensym)) (timer (gensym))
+ (timeout (gensym)) (block (gensym)))
+ `(block ,block
+ (tagbody
+ (flet ((,unwind ()
+ (go ,timeout))
+ (,exec ()
+ ,@body))
+ (declare (dynamic-extent #',exec #',unwind))
+ (let ((,timer (sb-ext:make-timer #',unwind)))
+ (declare (dynamic-extent ,timer))
+ (sb-sys:without-interrupts
+ (unwind-protect
+ (progn
+ (sb-ext:schedule-timer ,timer ,seconds)
+ (return-from ,block
+ (sb-sys:with-local-interrupts
+ (,exec))))
+ (sb-ext:unschedule-timer ,timer)))))
+ ,timeout
+ (return-from ,block ,timeout-form)))))
+
+(defun get-hosts-by-name (name)
+ (with-mapped-conditions ()
+ (multiple-value-bind (host4 host6)
+ (sb-bsd-sockets:get-host-by-name name)
+ (let ((addr4 (when host4
+ (sb-bsd-sockets::host-ent-addresses host4)))
+ (addr6 (when host6
+ (sb-bsd-sockets::host-ent-addresses host6))))
+ (append addr4 addr6)))))
+
+(defun socket-connect (host port &key (protocol :stream) (element-type 'character)
+ timeout deadline (nodelay t nodelay-specified)
+ local-host local-port
+ &aux
+ (sockopt-tcp-nodelay-p
+ (fboundp 'sb-bsd-sockets::sockopt-tcp-nodelay)))
+ (when deadline (unsupported 'deadline 'socket-connect))
+ #+ecl
+ (when timeout (unsupported 'timeout 'socket-connect))
+ (when (and nodelay-specified
+ ;; 20080802: ECL added this function to its sockets
+ ;; package today. There's no guarantee the functions
+ ;; we need are available, but we can make sure not to
+ ;; call them if they aren't
+ (not (eq nodelay :if-supported))
+ (not sockopt-tcp-nodelay-p))
+ (unsupported 'nodelay 'socket-connect))
+ (when (eq nodelay :if-supported)
+ (setf nodelay t))
+
+ (let* ((remote (when host
+ (car (get-hosts-by-name (host-to-hostname host)))))
+ (local (when local-host
+ (car (get-hosts-by-name (host-to-hostname local-host)))))
+ (ipv6 (or (and remote (= 16 (length remote)))
+ (and local (= 16 (length local)))))
+ (socket (make-instance #+sbcl (if ipv6
+ 'sb-bsd-sockets::inet6-socket
+ 'sb-bsd-sockets:inet-socket)
+ #+ecl 'sb-bsd-sockets:inet-socket
+ :type protocol
+ :protocol (case protocol
+ (:stream :tcp)
+ (:datagram :udp))))
+ usocket
+ ok)
+
+ (unwind-protect
+ (progn
+ (ecase protocol
+ (:stream
+ ;; If make a real socket stream before the socket is
+ ;; connected, it gets a misleading name so supply a
+ ;; dummy value to start with.
+ (setf usocket (make-stream-socket :socket socket :stream *dummy-stream*))
+ ;; binghe: use SOCKOPT-TCP-NODELAY as internal symbol
+ ;; to pass compilation on ECL without it.
+ (when (and nodelay-specified sockopt-tcp-nodelay-p)
+ (setf (sb-bsd-sockets::sockopt-tcp-nodelay socket) nodelay))
+ (when (or local-host local-port)
+ (sb-bsd-sockets:socket-bind socket
+ (if ipv6
+ (or local (ipv6-host-to-vector "::0"))
+ (or local (host-to-vector-quad *wildcard-host*)))
+ (or local-port *auto-port*)))
+
+ (with-mapped-conditions (usocket)
+ #+(and sbcl (not win32))
+ (labels ((connect ()
+ (sb-bsd-sockets:socket-connect socket remote port)))
+ (if timeout
+ (%with-timeout (timeout (error 'sb-ext:timeout)) (connect))
+ (connect)))
+ #+(or ecl (and sbcl win32))
+ (sb-bsd-sockets:socket-connect socket remote port)
+ ;; Now that we're connected make the stream.
+ (setf (socket-stream usocket)
+ (sb-bsd-sockets:socket-make-stream socket
+ :input t :output t :buffering :full
+ :element-type element-type
+ ;; Robert Brown <robert.brown@gmail.com> said on Aug 4, 2011:
+ ;; ... This means that SBCL streams created by usocket have a true
+ ;; serve-events property. When writing large amounts of data to several
+ ;; streams, the kernel will eventually stop accepting data from SBCL.
+ ;; When this happens, SBCL either waits for I/O to be possible on
+ ;; the file descriptor it's writing to or queues the data to be flushed later.
+ ;; Because usocket streams specify serve-events as true, SBCL
+ ;; always queues. Instead, it should wait for I/O to be available and
+ ;; write the remaining data to the socket. That's what serve-events
+ ;; equal to NIL gets you.
+ ;;
+ ;; Nikodemus Siivola <nikodemus@random-state.net> said on Aug 8, 2011:
+ ;; It's set to T for purely historical reasons, and will soon change to
+ ;; NIL in SBCL. (The docstring has warned of T being a temporary default
+ ;; for as long as the :SERVE-EVENTS keyword argument has existed.)
+ :serve-events nil))))
+ (:datagram
+ (when (or local-host local-port)
+ (sb-bsd-sockets:socket-bind socket
+ (if ipv6
+ (or local (ipv6-host-to-vector "::0"))
+ (or local (host-to-vector-quad *wildcard-host*)))
+ (or local-port *auto-port*)))
+ (setf usocket (make-datagram-socket socket))
+ (when (and host port)
+ (with-mapped-conditions (usocket)
+ (sb-bsd-sockets:socket-connect socket remote port)
+ (setf (connected-p usocket) t)))))
+ (setf ok t))
+ ;; Clean up in case of an error.
+ (unless ok
+ (sb-bsd-sockets:socket-close socket :abort t)))
+ usocket))
+
+(defun socket-listen (host port
+ &key reuseaddress
+ (reuse-address nil reuse-address-supplied-p)
+ (backlog 5)
+ (element-type 'character))
+ (let* (#+sbcl
+ (local (when host
+ (car (get-hosts-by-name (host-to-hostname host)))))
+ #+sbcl
+ (ipv6 (and local (= 16 (length local))))
+ (reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress))
+ (ip #+sbcl (if (and local (not (eq host *wildcard-host*)))
+ local
+ (hbo-to-vector-quad sb-bsd-sockets-internal::inaddr-any))
+ #+ecl (host-to-vector-quad host))
+ (sock (make-instance #+sbcl (if ipv6
+ 'sb-bsd-sockets::inet6-socket
+ 'sb-bsd-sockets:inet-socket)
+ #+ecl 'sb-bsd-sockets:inet-socket
+ :type :stream
+ :protocol :tcp)))
+ (handler-case
+ (with-mapped-conditions ()
+ (setf (sb-bsd-sockets:sockopt-reuse-address sock) reuseaddress)
+ (sb-bsd-sockets:socket-bind sock ip port)
+ (sb-bsd-sockets:socket-listen sock backlog)
+ (make-stream-server-socket sock :element-type element-type))
+ (t (c)
+ ;; Make sure we don't leak filedescriptors
+ (sb-bsd-sockets:socket-close sock)
+ (error c)))))
+
+;;; "2. SB-BSD-SOCKETS:SOCKET-ACCEPT method returns NIL for EAGAIN/EINTR,
+;;; instead of raising a condition. It's always possible for
+;;; SOCKET-ACCEPT on non-blocking socket to fail, even after the socket
+;;; was detected to be ready: connection might be reset, for example.
+;;;
+;;; "I had to redefine SOCKET-ACCEPT method of STREAM-SERVER-USOCKET to
+;;; handle this situation. Here is the redefinition:" -- Anton Kovalenko <anton@sw4me.com>
+
+(defmethod socket-accept ((usocket stream-server-usocket) &key element-type)
+ (with-mapped-conditions (usocket)
+ (let ((socket (sb-bsd-sockets:socket-accept (socket usocket))))
+ (when socket
+ (prog1
+ (make-stream-socket
+ :socket socket
+ :stream (sb-bsd-sockets:socket-make-stream
+ socket
+ :input t :output t :buffering :full
+ :element-type (or element-type
+ (element-type usocket))))
+
+ ;; next time wait for event again if we had EAGAIN/EINTR
+ ;; or else we'd enter a tight loop of failed accepts
+ #+win32
+ (setf (%ready-p usocket) nil))))))
+
+;; Sockets and their associated streams are modelled as
+;; different objects. Be sure to close the stream (which
+;; closes the socket too) when closing a stream-socket.
+(defmethod socket-close ((usocket usocket))
+ (when (wait-list usocket)
+ (remove-waiter (wait-list usocket) usocket))
+ (with-mapped-conditions (usocket)
+ (sb-bsd-sockets:socket-close (socket usocket))))
+
+(defmethod socket-close ((usocket stream-usocket))
+ (when (wait-list usocket)
+ (remove-waiter (wait-list usocket) usocket))
+ (with-mapped-conditions (usocket)
+ (close (socket-stream usocket))))
+
+#+sbcl
+(defmethod socket-shutdown ((usocket stream-usocket) direction)
+ (with-mapped-conditions (usocket)
+ (sb-bsd-sockets::socket-shutdown (socket usocket) :direction direction)))
+
+#+ecl
+(defmethod socket-shutdown ((usocket stream-usocket) direction)
+ (let ((sock-fd (sb-bsd-sockets:socket-file-descriptor (socket usocket)))
+ (direction-flag (ecase direction
+ (:input 0)
+ (:output 1))))
+ (unless (zerop (ffi:c-inline (sock-fd direction-flag) (:int :int) :int
+ "shutdown(#0, #1)" :one-liner t))
+ (error (map-errno-error (cerrno))))))
+
+(defmethod socket-send ((usocket datagram-usocket) buffer size &key host port (offset 0))
+ (let ((remote (when host
+ (car (get-hosts-by-name (host-to-hostname host))))))
+ (with-mapped-conditions (usocket)
+ (let* ((s (socket usocket))
+ (dest (if (and host port) (list remote port) nil))
+ (real-buffer (if (zerop offset)
+ buffer
+ (subseq buffer offset (+ offset size)))))
+ (sb-bsd-sockets:socket-send s real-buffer size :address dest)))))
+
+(defmethod socket-receive ((socket datagram-usocket) buffer length
+ &key (element-type '(unsigned-byte 8)))
+ #+sbcl
+ (declare (values (simple-array (unsigned-byte 8) (*)) ; buffer
+ (integer 0) ; size
+ (simple-array (unsigned-byte 8) (*)) ; host
+ (unsigned-byte 16))) ; port
+ (with-mapped-conditions (socket)
+ (let ((s (socket socket)))
+ (sb-bsd-sockets:socket-receive s buffer length :element-type element-type))))
+
+(defmethod get-local-name ((usocket usocket))
+ (sb-bsd-sockets:socket-name (socket usocket)))
+
+(defmethod get-peer-name ((usocket stream-usocket))
+ (sb-bsd-sockets:socket-peername (socket usocket)))
+
+(defmethod get-local-address ((usocket usocket))
+ (nth-value 0 (get-local-name usocket)))
+
+(defmethod get-peer-address ((usocket stream-usocket))
+ (nth-value 0 (get-peer-name usocket)))
+
+(defmethod get-local-port ((usocket usocket))
+ (nth-value 1 (get-local-name usocket)))
+
+(defmethod get-peer-port ((usocket stream-usocket))
+ (nth-value 1 (get-peer-name usocket)))
+
+(defun get-host-by-address (address)
+ (with-mapped-conditions ()
+ (sb-bsd-sockets::host-ent-name
+ (sb-bsd-sockets:get-host-by-address address))))
+
+#+(and sbcl (not win32))
+(progn
+ (defun %setup-wait-list (wait-list)
+ (declare (ignore wait-list)))
+
+ (defun %add-waiter (wait-list waiter)
+ (push (socket waiter) (wait-list-%wait wait-list)))
+
+ (defun %remove-waiter (wait-list waiter)
+ (setf (wait-list-%wait wait-list)
+ (remove (socket waiter) (wait-list-%wait wait-list))))
+
+ (defun wait-for-input-internal (sockets &key timeout)
+ (with-mapped-conditions ()
+ (sb-alien:with-alien ((rfds (sb-alien:struct sb-unix:fd-set)))
+ (sb-unix:fd-zero rfds)
+ (dolist (socket (wait-list-%wait sockets))
+ (sb-unix:fd-set
+ (sb-bsd-sockets:socket-file-descriptor socket)
+ rfds))
+ (multiple-value-bind
+ (secs musecs)
+ (split-timeout (or timeout 1))
+ (multiple-value-bind
+ (count err)
+ (sb-unix:unix-fast-select
+ (1+ (reduce #'max (wait-list-%wait sockets)
+ :key #'sb-bsd-sockets:socket-file-descriptor))
+ (sb-alien:addr rfds) nil nil
+ (when timeout secs) (when timeout musecs))
+ (if (null count)
+ (unless (= err sb-unix:EINTR)
+ (error (map-errno-error err)))
+ (when (< 0 count)
+ ;; process the result...
+ (dolist (x (wait-list-waiters sockets))
+ (when (sb-unix:fd-isset
+ (sb-bsd-sockets:socket-file-descriptor
+ (socket x))
+ rfds)
+ (setf (state x) :READ))))))))))
+) ; progn
+
+;;; WAIT-FOR-INPUT support for SBCL on Windows platform (Chun Tian (binghe))
+;;; Based on LispWorks version written by Erik Huelsmann.
+
+#+win32 ; shared by ECL and SBCL
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defconstant +wsa-wait-failed+ #xffffffff)
+ (defconstant +wsa-wait-event-0+ 0)
+ (defconstant +wsa-wait-timeout+ 258))
+
+#+win32 ; shared by ECL and SBCL
+(progn
+ (defconstant fd-read 1)
+ (defconstant fd-read-bit 0)
+ (defconstant fd-write 2)
+ (defconstant fd-write-bit 1)
+ (defconstant fd-oob 4)
+ (defconstant fd-oob-bit 2)
+ (defconstant fd-accept 8)
+ (defconstant fd-accept-bit 3)
+ (defconstant fd-connect 16)
+ (defconstant fd-connect-bit 4)
+ (defconstant fd-close 32)
+ (defconstant fd-close-bit 5)
+ (defconstant fd-qos 64)
+ (defconstant fd-qos-bit 6)
+ (defconstant fd-group-qos 128)
+ (defconstant fd-group-qos-bit 7)
+ (defconstant fd-routing-interface 256)
+ (defconstant fd-routing-interface-bit 8)
+ (defconstant fd-address-list-change 512)
+ (defconstant fd-address-list-change-bit 9)
+ (defconstant fd-max-events 10)
+ (defconstant fionread 1074030207)
+
+ ;; Note: for ECL, socket-handle will return raw Windows Handle,
+ ;; while SBCL returns OSF Handle instead.
+ (defun socket-handle (usocket)
+ (sb-bsd-sockets:socket-file-descriptor (socket usocket)))
+
+ (defun socket-ready-p (socket)
+ (if (typep socket 'stream-usocket)
+ (plusp (bytes-available-for-read socket))
+ (%ready-p socket)))
+
+ (defun waiting-required (sockets)
+ (notany #'socket-ready-p sockets))
+
+ (defun raise-usock-err (errno &optional socket)
+ (error 'unknown-error
+ :socket socket
+ :real-error errno))
+
+ (defun wait-for-input-internal (wait-list &key timeout)
+ (when (waiting-required (wait-list-waiters wait-list))
+ (let ((rv (wsa-wait-for-multiple-events 1 (wait-list-%wait wait-list)
+ nil (truncate (* 1000 (if timeout timeout 0))) nil)))
+ (ecase rv
+ ((#.+wsa-wait-event-0+)
+ (update-ready-and-state-slots (wait-list-waiters wait-list)))
+ ((#.+wsa-wait-timeout+)) ; do nothing here
+ ((#.+wsa-wait-failed+)
+ (maybe-wsa-error rv))))))
+
+ (defun %add-waiter (wait-list waiter)
+ (let ((events (etypecase waiter
+ (stream-server-usocket (logior fd-connect fd-accept fd-close))
+ (stream-usocket (logior fd-read))
+ (datagram-usocket (logior fd-read)))))
+ (maybe-wsa-error
+ (wsa-event-select (os-socket-handle waiter) (os-wait-list-%wait wait-list) events)
+ waiter)))
+
+ (defun %remove-waiter (wait-list waiter)
+ (maybe-wsa-error
+ (wsa-event-select (os-socket-handle waiter) (os-wait-list-%wait wait-list) 0)
+ waiter))
+) ; progn
+
+#+(and sbcl win32)
+(progn
+ ;; "SOCKET is defined as intptr_t in Windows headers; however, WS-SOCKET
+ ;; is defined as unsigned-int, i.e. 32-bit even on 64-bit platform. It
+ ;; seems to be a good thing to redefine WS-SOCKET as SB-ALIEN:SIGNED,
+ ;; which is always machine word-sized (exactly as intptr_t;
+ ;; N.B. as of Windows/x64, long and signed-long are 32-bit, and thus not
+ ;; enough -- potentially)."
+ ;; -- Anton Kovalenko <anton@sw4me.com>, Mar 22, 2011
+ (sb-alien:define-alien-type ws-socket sb-alien:signed)
+
+ (sb-alien:define-alien-type ws-dword sb-alien:unsigned-long)
+ (sb-alien:define-alien-type ws-event sb-alien::hinstance)
+
+ (sb-alien:define-alien-type nil
+ (sb-alien:struct wsa-network-events
+ (network-events sb-alien:long)
+ (error-code (array sb-alien:int 10)))) ; 10 = fd-max-events
+
+ (sb-alien:define-alien-routine ("WSACreateEvent" wsa-event-create)
+ ws-event) ; return type only
+
+ (sb-alien:define-alien-routine ("WSACloseEvent" wsa-event-close)
+ (boolean #.sb-vm::n-machine-word-bits)
+ (event-object ws-event))
+
+ (sb-alien:define-alien-routine ("WSAEnumNetworkEvents" wsa-enum-network-events)
+ sb-alien:int
+ (socket ws-socket)
+ (event-object ws-event)
+ (network-events (* (sb-alien:struct wsa-network-events))))
+
+ (sb-alien:define-alien-routine ("WSAEventSelect" wsa-event-select)
+ sb-alien:int
+ (socket ws-socket)
+ (event-object ws-event)
+ (network-events sb-alien:long))
+
+ (sb-alien:define-alien-routine ("WSAWaitForMultipleEvents" wsa-wait-for-multiple-events)
+ ws-dword
+ (number-of-events ws-dword)
+ (events (* ws-event))
+ (wait-all-p (boolean #.sb-vm::n-machine-word-bits))
+ (timeout ws-dword)
+ (alertable-p (boolean #.sb-vm::n-machine-word-bits)))
+
+ (sb-alien:define-alien-routine ("ioctlsocket" wsa-ioctlsocket)
+ sb-alien:int
+ (socket ws-socket)
+ (cmd sb-alien:long)
+ (argp (* sb-alien:unsigned-long)))
+
+ (defun maybe-wsa-error (rv &optional socket)
+ (unless (zerop rv)
+ (raise-usock-err (sockint::wsa-get-last-error) socket)))
+
+ (defun os-socket-handle (usocket)
+ (sb-bsd-sockets:socket-file-descriptor (socket usocket)))
+
+ (defun bytes-available-for-read (socket)
+ (sb-alien:with-alien ((int-ptr sb-alien:unsigned-long))
+ (maybe-wsa-error (wsa-ioctlsocket (os-socket-handle socket) fionread (sb-alien:addr int-ptr))
+ socket)
+ (prog1 int-ptr
+ (when (plusp int-ptr)
+ (setf (state socket) :read)))))
+
+ (defun map-network-events (func network-events)
+ (let ((event-map (sb-alien:slot network-events 'network-events))
+ (error-array (sb-alien:slot network-events 'error-code)))
+ (unless (zerop event-map)
+ (dotimes (i fd-max-events)
+ (unless (zerop (ldb (byte 1 i) event-map)) ;;### could be faster with ash and logand?
+ (funcall func (sb-alien:deref error-array i)))))))
+
+ (defun update-ready-and-state-slots (sockets)
+ (dolist (socket sockets)
+ (if (%ready-p socket)
+ (progn
+ (setf (state socket) :READ))
+ (sb-alien:with-alien ((network-events (sb-alien:struct wsa-network-events)))
+ (let ((rv (wsa-enum-network-events (os-socket-handle socket) 0
+ (sb-alien:addr network-events))))
+ (if (zerop rv)
+ (map-network-events
+ #'(lambda (err-code)
+ (if (zerop err-code)
+ (progn
+ (setf (state socket) :READ)
+ (when (stream-server-usocket-p socket)
+ (setf (%ready-p socket) t)))
+ (raise-usock-err err-code socket)))
+ network-events)
+ (maybe-wsa-error rv socket)))))))
+
+ (defun os-wait-list-%wait (wait-list)
+ (sb-alien:deref (wait-list-%wait wait-list)))
+
+ (defun (setf os-wait-list-%wait) (value wait-list)
+ (setf (sb-alien:deref (wait-list-%wait wait-list)) value))
+
+ ;; "Event handles are leaking in current SBCL backend implementation,
+ ;; because of SBCL-unfriendly usage of finalizers.
+ ;;
+ ;; "SBCL never calls a finalizer that closes over a finalized object: a
+ ;; reference from that closure prevents its collection forever. That's
+ ;; the case with USOCKET in %SETUP-WAIT-LIST.
+ ;;
+ ;; "I use the following redefinition of %SETUP-WAIT-LIST:
+ ;;
+ ;; "Of course it may be rewritten with more clarity, but you can see the
+ ;; core idea: I'm closing over those components of WAIT-LIST that I need
+ ;; for finalization, not the wait-list itself. With the original
+ ;; %SETUP-WAIT-LIST, hunchentoot stops working after ~100k accepted
+ ;; connections; it doesn't happen with redefined %SETUP-WAIT-LIST."
+ ;;
+ ;; -- Anton Kovalenko <anton@sw4me.com>, Mar 22, 2011
+
+ (defun %setup-wait-list (wait-list)
+ (setf (wait-list-%wait wait-list) (sb-alien:make-alien ws-event))
+ (setf (os-wait-list-%wait wait-list) (wsa-event-create))
+ (sb-ext:finalize wait-list
+ (let ((event-handle (os-wait-list-%wait wait-list))
+ (alien (wait-list-%wait wait-list)))
+ #'(lambda ()
+ (wsa-event-close event-handle)
+ (unless (null alien)
+ (sb-alien:free-alien alien))))))
+
+) ; progn
+
+#+(and ecl (not win32))
+(progn
+ (defun wait-for-input-internal (wl &key timeout)
+ (with-mapped-conditions ()
+ (multiple-value-bind (secs usecs)
+ (split-timeout (or timeout 1))
+ (multiple-value-bind (result-fds err)
+ (read-select wl (when timeout secs) usecs)
+ (declare (ignore result-fds))
+ (unless (null err)
+ (error (map-errno-error err)))))))
+
+ (defun %setup-wait-list (wl)
+ (setf (wait-list-%wait wl)
+ (fdset-alloc)))
+
+ (defun %add-waiter (wl w)
+ (declare (ignore wl w)))
+
+ (defun %remove-waiter (wl w)
+ (declare (ignore wl w)))
+) ; progn
+
+#+(and ecl win32 (not ecl-bytecmp))
+(progn
+ (defun maybe-wsa-error (rv &optional syscall)
+ (unless (zerop rv)
+ (sb-bsd-sockets::socket-error syscall)))
+
+ (defun %setup-wait-list (wl)
+ (setf (wait-list-%wait wl)
+ (ffi:c-inline () () :int
+ "WSAEVENT event;
+ event = WSACreateEvent();
+ @(return) = event;")))
+
+ (defun %add-waiter (wait-list waiter)
+ (let ((events (etypecase waiter
+ (stream-server-usocket (logior fd-connect fd-accept fd-close))
+ (stream-usocket (logior fd-read))
+ (datagram-usocket (logior fd-read)))))
+ (maybe-wsa-error
+ (ffi:c-inline ((socket-handle waiter) (wait-list-%wait wait-list) events)
+ (:fixnum :fixnum :fixnum) :fixnum
+ "int result;
+ result = WSAEventSelect((SOCKET)#0, (WSAEVENT)#1, (long)#2);
+ @(return) = result;")
+ '%add-waiter)))
+
+ (defun %remove-waiter (wait-list waiter)
+ (maybe-wsa-error
+ (ffi:c-inline ((socket-handle waiter) (wait-list-%wait wait-list))
+ (:fixnum :fixnum) :fixnum
+ "int result;
+ result = WSAEventSelect((SOCKET)#0, (WSAEVENT)#1, 0L);
+ @(return) = result;")
+ '%remove-waiter))
+
+ ;; TODO: how to handle error (result) in this call?
+ (declaim (inline %bytes-available-for-read))
+ (defun %bytes-available-for-read (socket)
+ (ffi:c-inline ((socket-handle socket)) (:fixnum) :fixnum
+ "u_long nbytes;
+ int result;
+ nbytes = 0L;
+ result = ioctlsocket((SOCKET)#0, FIONREAD, &nbytes);
+ @(return) = nbytes;"))
+
+ (defun bytes-available-for-read (socket)
+ (let ((nbytes (%bytes-available-for-read socket)))
+ (when (plusp nbytes)
+ (setf (state socket) :read))
+ nbytes))
+
+ (defun update-ready-and-state-slots (sockets)
+ (dolist (socket sockets)
+ (if (%ready-p socket)
+ (setf (state socket) :READ)
+ (let ((events (etypecase socket
+ (stream-server-usocket (logior fd-connect fd-accept fd-close))
+ (stream-usocket (logior fd-read))
+ (datagram-usocket (logior fd-read)))))
+ ;; TODO: check the iErrorCode array
+ (multiple-value-bind (valid-p ready-p)
+ (ffi:c-inline ((socket-handle socket) events) (:fixnum :fixnum)
+ (values :bool :bool)
+ "WSANETWORKEVENTS network_events;
+ int i, result;
+ result = WSAEnumNetworkEvents((SOCKET)#0, 0, &network_events);
+ if (!result) {
+ @(return 0) = Ct;
+ @(return 1) = (#1 & network_events.lNetworkEvents)? Ct : Cnil;
+ } else {
+ @(return 0) = Cnil;
+ @(return 1) = Cnil;
+ }")
+ (if valid-p
+ (when ready-p
+ (setf (state socket) :READ)
+ (when (stream-server-usocket-p socket)
+ (setf (%ready-p socket) t)))
+ (sb-bsd-sockets::socket-error 'update-ready-and-state-slots)))))))
+
+ (defun wait-for-input-internal (wait-list &key timeout)
+ (when (waiting-required (wait-list-waiters wait-list))
+ (let ((rv (ffi:c-inline ((wait-list-%wait wait-list) (truncate (* 1000 timeout)))
+ (:fixnum :fixnum) :fixnum
+ "DWORD result;
+ WSAEVENT events[1];
+ events[0] = (WSAEVENT)#0;
+ result = WSAWaitForMultipleEvents(1, events, NULL, #1, NULL);
+ @(return) = result;")))
+ (ecase rv
+ ((#.+wsa-wait-event-0+)
+ (update-ready-and-state-slots (wait-list-waiters wait-list)))
+ ((#.+wsa-wait-timeout+)) ; do nothing here
+ ((#.+wsa-wait-failed+)
+ (sb-bsd-sockets::socket-error 'wait-for-input-internal))))))
+
+) ; progn
--- /dev/null
+;;;; $Id$
+;;;; $URL$
+
+;;;; See LICENSE for licensing information.
+
+(in-package :usocket)
+
+(defparameter +scl-error-map+
+ (append +unix-errno-condition-map+
+ +unix-errno-error-map+))
+
+(defun scl-map-socket-error (err &key condition socket)
+ (let ((usock-err (cdr (assoc err +scl-error-map+ :test #'member))))
+ (cond (usock-err
+ (if (subtypep usock-err 'error)
+ (error usock-err :socket socket)
+ (signal usock-err :socket socket)))
+ (t
+ (error 'unknown-error
+ :socket socket
+ :real-error condition)))))
+
+(defun handle-condition (condition &optional (socket nil))
+ "Dispatch correct usocket condition."
+ (typecase condition
+ (ext::socket-error
+ (scl-map-socket-error (ext::socket-errno condition)
+ :socket socket
+ :condition condition))))
+
+(defun socket-connect (host port &key (protocol :stream) (element-type 'character)
+ timeout deadline (nodelay t nodelay-specified)
+ (local-host nil local-host-p)
+ (local-port nil local-port-p)
+ &aux
+ (patch-udp-p (fboundp 'ext::inet-socket-send-to)))
+ (when (and nodelay-specified
+ (not (eq nodelay :if-supported)))
+ (unsupported 'nodelay 'socket-connect))
+ (when deadline (unsupported 'deadline 'socket-connect))
+ (when timeout (unsupported 'timeout 'socket-connect))
+ (when (and local-host-p (not patch-udp-p))
+ (unsupported 'local-host 'socket-connect :minimum "1.3.9"))
+ (when (and local-port-p (not patch-udp-p))
+ (unsupported 'local-port 'socket-connect :minimum "1.3.9"))
+
+ (let ((socket))
+ (ecase protocol
+ (:stream
+ (setf socket (let ((args (list (host-to-hbo host) port :kind protocol)))
+ (when (and patch-udp-p (or local-host-p local-port-p))
+ (nconc args (list :local-host (when local-host
+ (host-to-hbo local-host))
+ :local-port local-port)))
+ (with-mapped-conditions (socket)
+ (apply #'ext:connect-to-inet-socket args))))
+ (let ((stream (sys:make-fd-stream socket :input t :output t
+ :element-type element-type
+ :buffering :full)))
+ (make-stream-socket :socket socket :stream stream)))
+ (:datagram
+ (when (not patch-udp-p)
+ (error 'unsupported
+ :feature '(protocol :datagram)
+ :context 'socket-connect
+ :minumum "1.3.9"))
+ (setf socket
+ (if (and host port)
+ (let ((args (list (host-to-hbo host) port :kind protocol)))
+ (when (and patch-udp-p (or local-host-p local-port-p))
+ (nconc args (list :local-host (when local-host
+ (host-to-hbo local-host))
+ :local-port local-port)))
+ (with-mapped-conditions (socket)
+ (apply #'ext:connect-to-inet-socket args)))
+ (if (or local-host-p local-port-p)
+ (with-mapped-conditions ()
+ (ext:create-inet-listener (or local-port 0)
+ protocol
+ :host (when local-host
+ (if (ip= local-host *wildcard-host*)
+ 0
+ (host-to-hbo local-host)))))
+ (with-mapped-conditions ()
+ (ext:create-inet-socket protocol)))))
+ (let ((usocket (make-datagram-socket socket :connected-p (and host port t))))
+ (ext:finalize usocket #'(lambda ()
+ (when (%open-p usocket)
+ (ext:close-socket socket))))
+ usocket)))))
+
+(defun socket-listen (host port
+ &key reuseaddress
+ (reuse-address nil reuse-address-supplied-p)
+ (backlog 5)
+ (element-type 'character))
+ (let* ((reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress))
+ (host (if (ip= host *wildcard-host*)
+ 0
+ (host-to-hbo host)))
+ (server-sock
+ (with-mapped-conditions ()
+ (ext:create-inet-listener port :stream
+ :host host
+ :reuse-address reuseaddress
+ :backlog backlog))))
+ (make-stream-server-socket server-sock :element-type element-type)))
+
+(defmethod socket-accept ((usocket stream-server-usocket) &key element-type)
+ (with-mapped-conditions (usocket)
+ (let* ((sock (ext:accept-tcp-connection (socket usocket)))
+ (stream (sys:make-fd-stream sock :input t :output t
+ :element-type (or element-type
+ (element-type usocket))
+ :buffering :full)))
+ (make-stream-socket :socket sock :stream stream))))
+
+;; Sockets and their associated streams are modelled as
+;; different objects. Be sure to close the socket stream
+;; when closing stream-sockets; it makes sure buffers
+;; are flushed and the socket is closed correctly afterwards.
+(defmethod socket-close ((usocket usocket))
+ "Close socket."
+ (when (wait-list usocket)
+ (remove-waiter (wait-list usocket) usocket))
+ (with-mapped-conditions (usocket)
+ (ext:close-socket (socket usocket))))
+
+(defmethod socket-close ((usocket stream-usocket))
+ "Close socket."
+ (when (wait-list usocket)
+ (remove-waiter (wait-list usocket) usocket))
+ (with-mapped-conditions (usocket)
+ (close (socket-stream usocket))))
+
+(defmethod socket-close :after ((socket datagram-usocket))
+ (setf (%open-p socket) nil))
+
+(defmethod socket-shutdown ((usocket usocket) direction)
+ (declare (ignore usocket direction))
+ (unsupported "shutdown" 'socket-shutdown))
+
+(defmethod socket-send ((usocket datagram-usocket) buffer size &key host port)
+ (let ((s (socket usocket))
+ (host (if host (host-to-hbo host)))
+ (real-buffer (if (zerop offset)
+ buffer
+ (subseq buffer offset (+ offset size)))))
+ (multiple-value-bind (result errno)
+ (ext:inet-socket-send-to s real-buffer size
+ :remote-host host :remote-port port)
+ (or result
+ (scl-map-socket-error errno :socket usocket)))))
+
+(defmethod socket-receive ((socket datagram-usocket) buffer length &key)
+ (declare (values (simple-array (unsigned-byte 8) (*)) ; buffer
+ (integer 0) ; size
+ (unsigned-byte 32) ; host
+ (unsigned-byte 16))) ; port
+ (let ((s (socket socket)))
+ (let ((real-buffer (or buffer
+ (make-array length :element-type '(unsigned-byte 8))))
+ (real-length (or length
+ (length buffer))))
+ (multiple-value-bind (result errno remote-host remote-port)
+ (ext:inet-socket-receive-from s real-buffer real-length)
+ (if result
+ (values real-buffer result remote-host remote-port)
+ (scl-map-socket-error errno :socket socket))))))
+
+(defmethod get-local-name ((usocket usocket))
+ (multiple-value-bind (address port)
+ (with-mapped-conditions (usocket)
+ (ext:get-socket-host-and-port (socket usocket)))
+ (values (hbo-to-vector-quad address) port)))
+
+(defmethod get-peer-name ((usocket stream-usocket))
+ (multiple-value-bind (address port)
+ (with-mapped-conditions (usocket)
+ (ext:get-peer-host-and-port (socket usocket)))
+ (values (hbo-to-vector-quad address) port)))
+
+(defmethod get-local-address ((usocket usocket))
+ (nth-value 0 (get-local-name usocket)))
+
+(defmethod get-peer-address ((usocket stream-usocket))
+ (nth-value 0 (get-peer-name usocket)))
+
+(defmethod get-local-port ((usocket usocket))
+ (nth-value 1 (get-local-name usocket)))
+
+(defmethod get-peer-port ((usocket stream-usocket))
+ (nth-value 1 (get-peer-name usocket)))
+
+
+(defun get-host-by-address (address)
+ (multiple-value-bind (host errno)
+ (ext:lookup-host-entry (host-byte-order address))
+ (cond (host
+ (ext:host-entry-name host))
+ (t
+ (let ((condition (cdr (assoc errno +unix-ns-error-map+))))
+ (cond (condition
+ (error condition :host-or-ip address))
+ (t
+ (error 'ns-unknown-error :host-or-ip address
+ :real-error errno))))))))
+
+(defun get-hosts-by-name (name)
+ (multiple-value-bind (host errno)
+ (ext:lookup-host-entry name)
+ (cond (host
+ (mapcar #'hbo-to-vector-quad
+ (ext:host-entry-addr-list host)))
+ (t
+ (let ((condition (cdr (assoc errno +unix-ns-error-map+))))
+ (cond (condition
+ (error condition :host-or-ip name))
+ (t
+ (error 'ns-unknown-error :host-or-ip name
+ :real-error errno))))))))
+
+(defun get-host-name ()
+ (unix:unix-gethostname))
+
+
+;;
+;;
+;; WAIT-LIST part
+;;
+
+
+(defun %add-waiter (wl waiter)
+ (declare (ignore wl waiter)))
+
+(defun %remove-waiter (wl waiter)
+ (declare (ignore wl waiter)))
+
+(defun %setup-wait-list (wl)
+ (declare (ignore wl)))
+
+(defun wait-for-input-internal (wait-list &key timeout)
+ (let* ((sockets (wait-list-waiters wait-list))
+ (pollfd-size (alien:alien-size (alien:struct unix::pollfd) :bytes))
+ (nfds (length sockets))
+ (bytes (* nfds pollfd-size)))
+ (alien:with-bytes (fds-sap bytes)
+ (do ((sockets sockets (rest sockets))
+ (base 0 (+ base 8)))
+ ((endp sockets))
+ (let ((fd (socket (first sockets))))
+ (setf (sys:sap-ref-32 fds-sap base) fd)
+ (setf (sys:sap-ref-16 fds-sap (+ base 4)) unix::pollin)))
+ (multiple-value-bind (result errno)
+ (let ((thread:*thread-whostate* "Poll wait")
+ (timeout (if timeout
+ (truncate (* timeout 1000))
+ -1)))
+ (declare (inline unix:unix-poll))
+ (unix:unix-poll (alien:sap-alien fds-sap
+ (* (alien:struct unix::pollfd)))
+ nfds timeout))
+ (cond ((not result)
+ (error "~@<Polling error: ~A~:@>"
+ (unix:get-unix-error-msg errno)))
+ (t
+ (do ((sockets sockets (rest sockets))
+ (base 0 (+ base 8)))
+ ((endp sockets))
+ (let ((flags (sys:sap-ref-16 fds-sap (+ base 6))))
+ (unless (zerop (logand flags unix::pollin))
+ (setf (state (first sockets)) :READ))))))))))
+
--- /dev/null
+;;;; $Id$
+;;;; $URL$
+
+;;;; See LICENSE for licensing information.
+
+(in-package :usocket)
+
+;; Condition signalled by operations with unsupported arguments
+;; For trivial-sockets compatibility.
+
+(define-condition insufficient-implementation (error)
+ ((feature :initarg :feature :reader feature)
+ (context :initarg :context :reader context
+ :documentation "String designator of the public API function which
+the feature belongs to."))
+ (:documentation "The ancestor of all errors usocket may generate
+because of insufficient support from the underlying implementation
+with respect to the arguments given to `function'.
+
+One call may signal several errors, if the caller allows processing
+to continue.
+"))
+
+(define-condition unsupported (insufficient-implementation)
+ ((minimum :initarg :minimum :reader minimum
+ :documentation "Indicates the minimal version of the
+implementation required to support the requested feature."))
+ (:report (lambda (c stream)
+ (format stream "~A in ~A is unsupported."
+ (feature c) (context c))
+ (when (minimum c)
+ (format stream " Minimum version (~A) is required."
+ (minimum c)))))
+ (:documentation "Signalled when the underlying implementation
+doesn't allow supporting the requested feature.
+
+When you see this error, go bug your vendor/implementation developer!"))
+
+(define-condition unimplemented (insufficient-implementation)
+ ()
+ (:report (lambda (c stream)
+ (format stream "~A in ~A is unimplemented."
+ (feature c) (context c))))
+ (:documentation "Signalled if a certain feature might be implemented,
+based on the features of the underlying implementation, but hasn't
+been implemented yet."))
+
+;; Conditions raised by sockets operations
+
+(define-condition socket-condition (condition)
+ ((socket :initarg :socket
+ :accessor usocket-socket))
+ ;;###FIXME: no slots (yet); should at least be the affected usocket...
+ (:documentation "Parent condition for all socket related conditions."))
+
+(define-condition socket-error (socket-condition error)
+ () ;; no slots (yet)
+ (:documentation "Parent error for all socket related errors"))
+
+(define-condition ns-condition (condition)
+ ((host-or-ip :initarg :host-or-ip
+ :accessor host-or-ip))
+ (:documentation "Parent condition for all name resolution conditions."))
+
+(define-condition ns-error (ns-condition error)
+ ()
+ (:documentation "Parent error for all name resolution errors."))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun define-usocket-condition-class (class &rest parents)
+ `(progn
+ (define-condition ,class ,parents ())
+ (export ',class))))
+
+(defmacro define-usocket-condition-classes (class-list parents)
+ `(progn ,@(mapcar #'(lambda (x)
+ (apply #'define-usocket-condition-class
+ x parents))
+ class-list)))
+
+;; Mass define and export our conditions
+(define-usocket-condition-classes
+ (interrupted-condition)
+ (socket-condition))
+
+(define-condition unknown-condition (socket-condition)
+ ((real-condition :initarg :real-condition
+ :accessor usocket-real-condition))
+ (:documentation "Condition raised when there's no other - more applicable -
+condition available."))
+
+
+;; Mass define and export our errors
+(define-usocket-condition-classes
+ (address-in-use-error
+ address-not-available-error
+ bad-file-descriptor-error
+ connection-refused-error
+ connection-aborted-error
+ connection-reset-error
+ invalid-argument-error
+ no-buffers-error
+ operation-not-supported-error
+ operation-not-permitted-error
+ protocol-not-supported-error
+ socket-type-not-supported-error
+ network-unreachable-error
+ network-down-error
+ network-reset-error
+ host-down-error
+ host-unreachable-error
+ shutdown-error
+ timeout-error
+ deadline-timeout-error
+ invalid-socket-error
+ invalid-socket-stream-error)
+ (socket-error))
+
+(define-condition unknown-error (socket-error)
+ ((real-error :initarg :real-error
+ :accessor usocket-real-error
+ :initform nil)
+ (errno :initarg :errno
+ :reader usocket-errno
+ :initform 0))
+ (:report (lambda (c stream)
+ (typecase c
+ (simple-condition
+ (format stream
+ (simple-condition-format-control (usocket-real-error c))
+ (simple-condition-format-arguments (usocket-real-error c))))
+ (otherwise
+ (format stream "The condition ~A occurred with errno: ~D."
+ (usocket-real-error c)
+ (usocket-errno c))))))
+ (:documentation "Error raised when there's no other - more applicable -
+error available."))
+
+(define-usocket-condition-classes
+ (ns-try-again-condition)
+ (ns-condition))
+
+(define-condition ns-unknown-condition (ns-condition)
+ ((real-condition :initarg :real-condition
+ :accessor ns-real-condition
+ :initform nil))
+ (:documentation "Condition raised when there's no other - more applicable -
+condition available."))
+
+(define-usocket-condition-classes
+ ;; the no-data error code in the Unix 98 api
+ ;; isn't really an error: there's just no data to return.
+ ;; with lisp, we just return NIL (indicating no data) instead of
+ ;; raising an exception...
+ (ns-host-not-found-error
+ ns-no-recovery-error)
+ (ns-error))
+
+(define-condition ns-unknown-error (ns-error)
+ ((real-error :initarg :real-error
+ :accessor ns-real-error
+ :initform nil))
+ (:report (lambda (c stream)
+ (typecase c
+ (simple-condition
+ (format stream
+ (simple-condition-format-control (usocket-real-error c))
+ (simple-condition-format-arguments (usocket-real-error c))))
+ (otherwise
+ (format stream "The condition ~A occurred." (usocket-real-error c))))))
+ (:documentation "Error raised when there's no other - more applicable -
+error available."))
+
+(defmacro with-mapped-conditions ((&optional socket) &body body)
+ `(handler-bind ((condition #'(lambda (c) (handle-condition c ,socket))))
+ ,@body))
+
+(defparameter +unix-errno-condition-map+
+ `(((11) . ns-try-again-condition) ;; EAGAIN
+ ((35) . ns-try-again-condition) ;; EDEADLCK
+ ((4) . interrupted-condition))) ;; EINTR
+
+(defparameter +unix-errno-error-map+
+ ;;### the first column is for non-(linux or srv4) systems
+ ;; the second for linux
+ ;; the third for srv4
+ ;;###FIXME: How do I determine on which Unix we're running
+ ;; (at least in clisp and sbcl; I know about cmucl...)
+ ;; The table below works under the assumption we'll *only* see
+ ;; socket associated errors...
+ `(((48 98) . address-in-use-error)
+ ((49 99) . address-not-available-error)
+ ((9) . bad-file-descriptor-error)
+ ((61 111) . connection-refused-error)
+ ((54 104) . connection-reset-error)
+ ((53 103) . connection-aborted-error)
+ ((22) . invalid-argument-error)
+ ((55 105) . no-buffers-error)
+ ((12) . out-of-memory-error)
+ ((45 95) . operation-not-supported-error)
+ ((1) . operation-not-permitted-error)
+ ((43 92) . protocol-not-supported-error)
+ ((44 93) . socket-type-not-supported-error)
+ ((51 101) . network-unreachable-error)
+ ((50 100) . network-down-error)
+ ((52 102) . network-reset-error)
+ ((58 108) . already-shutdown-error)
+ ((60 110) . timeout-error)
+ ((64 112) . host-down-error)
+ ((65 113) . host-unreachable-error)))
+
+(defun map-errno-condition (errno)
+ (cdr (assoc errno +unix-errno-error-map+ :test #'member)))
+
+(defun map-errno-error (errno)
+ (cdr (assoc errno +unix-errno-error-map+ :test #'member)))
+
+(defparameter +unix-ns-error-map+
+ `((1 . ns-host-not-found-error)
+ (2 . ns-try-again-condition)
+ (3 . ns-no-recovery-error)))
+
+(defmacro unsupported (feature context &key minimum)
+ `(cerror "Ignore it and continue" 'unsupported
+ :feature ,feature
+ :context ,context
+ :minimum ,minimum))
+
+(defmacro unimplemented (feature context)
+ `(signal 'unimplemented :feature ,feature :context ,context))
+
+
+;;; People may want to ignore all unsupported warnings, here it is.
+(defmacro ignore-unsupported-warnings (&body body)
+ `(handler-bind ((unsupported
+ #'(lambda (c)
+ (declare (ignore c)) (continue))))
+ (progn ,@body)))
--- /dev/null
+ -*- text -*-
+
+$Id$
+
+A document to describe which APIs a backend should implement.
+
+
+Each backend should implement:
+
+Functions:
+
+ - handle-condition
+ - socket-connect
+ - socket-listen
+ - get-hosts-by-name [ optional ]
+ - get-host-by-address [ optional ]
+
+ - wait-for-input-internal (new in 0.4.x)
+
+Methods:
+
+ - socket-close
+ - socket-accept
+ - get-local-name
+ - get-peer-name
+
+ and - for ip sockets - these methods:
+
+ - get-local-address
+ - get-local-port
+ - get-peer-address
+ - get-peer-port
+
+
+An error-handling function, resolving implementation specific errors
+to this list of errors:
+
+ - address-in-use-error
+ - address-not-available-error
+ - bad-file-descriptor-error
+ - connection-refused-error
+ - invalid-argument-error
+ - no-buffers-error
+ - operation-not-supported-error
+ - operation-not-permitted-error
+ - protocol-not-supported-error
+ - socket-type-not-supported-error
+ - network-unreachable-error
+ - network-down-error
+ - network-reset-error
+ - host-down-error
+ - host-unreachable-error
+ - shutdown-error
+ - timeout-error
+ - unkown-error
+
+and these conditions:
+
+ - interrupted-condition
+ - unkown-condition
--- /dev/null
+
+ -*- text -*-
+
+$Id$
+
+
+ usocket: Universal sockets library
+ ==================================
+
+Contents
+========
+
+ * Motivation
+ * Design goal
+ * Functional requirements
+ * Class structure
+
+
+\f
+Motivation
+==========
+
+There are 2 other portability sockets packages [that I know of]
+out there:
+
+ 1) trivial-sockets
+ 2) acl-compat (which is a *lot* broader, but contains sockets too)
+
+The first misses some functionality which is fundamental when
+the requirements stop being 'trivial', such as finding out the
+addresses of either side connected to the tcp/ip stream.
+
+The second, being a complete compatibility library for Allegro,
+contains much more than only sockets. Next to that, as the docs
+say, is it mainly directed at providing the functionality required
+to port portable-allegroserve - meaning it may be (very) incomplete
+on some platforms.
+
+So, that's why I decided to inherit Erik Enge's project to build
+a library with the intention to provide portability code in only
+1 area of programming, targeted at 'not so trivial' programming.
+
+Also, I need this library to extend cl-irc with full DCC functionality.
+
+
+\f
+Design goal
+===========
+
+To provide a portable TCP/IP socket interface for as many
+implementations as possible, while keeping the portability layer
+as thin as possible.
+
+
+\f
+Functional requirements
+=======================
+
+The interface provided should allow:
+ - 'client'/active sockets
+ - 'server'/listening sockets
+ - provide the usual stream methods to operate on the connection stream
+ (not necessarily the socket itself; maybe a socket slot too)
+
+For now, as long as there are no possibilities to have UDP sockets
+to write a DNS client library: (which in the end may work better,
+because in this respect all implementations are different...)
+ - retrieve IP addresses/ports for both sides of the connection
+
+Several relevant support functionalities will have to be provided too:
+ - long <-> quad-vector operators
+ - quad-vector <-> string operators
+ - hostname <-> quad-vector operators (hostname resolution)
+
+
+Minimally, I'd like to support:
+ - SBCL
+ - CMUCL
+ - ABCL (ArmedBear)
+ - clisp
+ - Allegro
+ - LispWorks
+ - OpenMCL
+
+
+Comments on the design above
+============================
+
+I don't think it's a good idea to implement name lookup in the
+very first of steps: we'll see if this is required to get the
+package accepted; not all implementations support it.
+
+Name resolution errors ...
+Since there is no name resolution library (yet), nor standardized
+hooks into the standard C library to do it the same way on
+all platforms, name resolution errors can manifest themselves
+in a lot of different ways. How to marshall these to the
+library users?
+
+Several solutions come to mind:
+
+1) Map them to 'unknown-error
+2) Give them their own errors and map to those
+ ... which implies that they are actually supported atm.
+3) ...
+
+Given that the library doesn't now, but may in the future,
+include name resolution officially, I tend to think (1) is the
+right answer: it leaves it all undecided.
+
+These errors can be raised by the nameresolution service
+(netdb.h) as values for 'int h_errno':
+
+- HOST_NOT_FOUND (1)
+- TRY_AGAIN (2) /* Server fail or non-authoritive Host not found */
+- NO_RECOVERY (3) /* Failed permanently */
+- NO_DATA (4) /* Valid address, no data for requested record */
+
+int *__h_errno_location(void) points to thread local h_errno on
+threaded glibc2 systems.
+
+\f
+Class structure
+===============
+
+ usocket
+ |
+ +- datagram-usocket
+ +- stream-usocket
+ \- stream-server-usocket
+
+The usocket class will have methods to query local properties, such
+as:
+
+ - get-local-name: to query to which interface the socket is bound
+ - <other socket and protocol options such as SO_REUSEADDRESS>
--- /dev/null
+
+ABCL provides a callback interface to java objects, next to these calls:
+
+ - ext:make-socket
+ - ext:socket-close
+ - ext:make-server-socket
+ - ext:socket-accept
+ - ext:get-socket-stream (returning an io-stream)
+
+abcl-swank (see SLIME) shows how to call directly into java.
+
+
+See for the sockets implementation:
+
+ - src/org/armedbear/lisp
+ * socket.lisp
+ * socket_stream.java
+ * SocketStream.java
--- /dev/null
+ -*- text -*-
+
+A document to summarizing which API's of the different implementations
+are associated with 'Step 1'.
+
+Interface to be implemented in step 1:
+
+ - socket-connect
+ - socket-close
+ - get-host-by-address
+ - get-hosts-by-name
+
+(and something to do with errors; maybe move this to step 1a?)
+
+SBCL
+====
+
+ sockets:
+ - socket-bind
+ - make-instance 'inet-socket
+ - socket-make-stream
+ - socket-connect (ip vector-quad) port
+ - socket-close
+
+ DNS name resolution:
+ - get-host-by-name
+ - get-host-by-address
+ - ::host-ent-addresses
+ - host-ent-name
+
+
+CMUCL
+=====
+
+ sockets:
+ - ext:connect-to-inet-socket (ip integer) port
+ - sys:make-fd-stream
+ - ext:close-socket
+
+ DNS name resolution:
+ - ext:host-entry-name
+ - ext::lookup-host-entry
+ - ext:host-entry-addr-list
+ - ext:lookup-host-entry
+
+
+ABCL
+====
+
+ sockets
+ - ext:socket-connect (hostname string) port
+ - ext:get-socket-stream
+ - ext:socket-close
+
+
+clisp
+=====
+
+ sockets
+ - socket-connect port (hostname string)
+ - close (socket)
+
+
+Allegro
+=======
+
+ sockets
+ - make-socket
+ - socket-connect
+ - close
+
+ DNS resolution
+ - lookup-hostname
+ - ipaddr-to-hostname
+
--- /dev/null
+
+ -*- text -*-
+
+Step 2 of the master plan: Implementing (get-local-address sock) and
+(get-peer-address sock).
+
+
+Step 2 is about implementing:
+
+ (get-local-address sock) -> ip
+ (get-peer-address sock) -> ip
+ (get-local-port sock) -> port
+ (get-peer-port sock) -> port
+ (get-local-name sock) -> ip, port
+ (get-peer-name sock) -> ip, port
+
+
+ABCL
+====
+
+ FFI / J-calls to "getLocalAddress"+"getAddress", "getLocalPort" (local)
+ FFI / J-calls to "getInetAddress"+"getAddress", "getPort" (peer)
+
+ (see SLIME / swank-abcl.lisp for an example on how to do that)
+
+
+Allegro
+=======
+
+ (values (socket:remote-host sock)
+ (socket:remote-port)) -> 32bit ip, port
+
+ (values (socket:local-host sock)
+ (socket:local-port sock)) -> 32bit ip, port
+
+CLISP
+=====
+
+ (socket:socket-stream-local sock nil) -> address (as dotted quad), port
+ (socket:socket-stream-peer sock nil) -> address (as dotted quad), port
+
+
+CMUCL
+=====
+
+ (ext:get-peer-host-and-port sock-fd) -> 32-bit-addr, port (peer)
+ (ext:get-socket-host-and-port sock-fd) -> 32-bit-addr, port (local)
+
+
+LispWorks
+=========
+
+ (comm:socket-stream-address sock-stream) -> 32-bit-addr, port
+ or: (comm:get-socket-address sock) -> 32-bit-addr, port
+
+ (comm:socket-stream-peer-address sock-stream) -> 32-bit-addr, port
+ or: (comm:get-socket-peer-address sock) -> 32-bit-addr, port
+
+
+OpenMCL
+=======
+
+ (values (ccl:local-host sock) (ccl:local-port sock)) -> 32-bit ip, port
+ (values (ccl:remote-host sock) (ccl:remote-port sock)) -> 32-bit ip, port
+
+
+SBCL
+====
+
+ (sb-bsd-sockets:socket-name sock) -> vector-quad, port
+ (sb-bsd-sockets:socket-peer-name sock) -> vector-quad, port
+
+
--- /dev/null
+
+
+(require :sock)
+
+accept-connection (sock passive-socket) &key wait Generic function.
+dotted-to-ipaddr dotted &key errorp Function.
+ipaddr-to-dotted ipaddr &key values Function.
+ipaddr-to-hostname ipaddr Function.
+lookup-hostname hostname
+lookup-port portname protocol Function.
+make-socket &key type format address-family connect &allow-other-keys Function.
+with-pending-connect &body body Macro.
+receive-from (sock datagram-socket) size &key buffer extract Generic function.
+send-to sock &key
+shutdown sock &key direction
+socket-control stream &key output-chunking output-chunking-eof input-chunking
+socket-os-fd sock Generic function.
+
+remote-host socket Generic function.
+local-host socket Generic function.
+local-port socket
+
+remote-filename socket
+local-filename socket
+remote-port socket
+socket-address-family socket
+socket-connect socket
+socket-format socket
+socket-type socket
+
+errors
+
+:address-in-use Local socket address already in use
+:address-not-available Local socket address not available
+:network-down Network is down
+:network-reset Network has been reset
+:connection-aborted Connection aborted
+:connection-reset Connection reset by peer
+:no-buffer-space No buffer space
+:shutdown Connection shut down
+:connection-timed-out Connection timed out
+:connection-refused Connection refused
+:host-down Host is down
+:host-unreachable Host is unreachable
+:unknown Unknown error
+
--- /dev/null
+http://clisp.cons.org/impnotes.html#socket
+
+(SOCKET:SOCKET-SERVER &OPTIONAL [port-or-socket])
+(SOCKET:SOCKET-SERVER-HOST socket-server)
+(SOCKET:SOCKET-SERVER-PORT socket-server)
+(SOCKET:SOCKET-WAIT socket-server &OPTIONAL [seconds [microseconds]])
+(SOCKET:SOCKET-ACCEPT socket-server &KEY :ELEMENT-TYPE :EXTERNAL-FORMAT :BUFFERED :TIMEOUT)
+(SOCKET:SOCKET-CONNECT port &OPTIONAL [host] &KEY :ELEMENT-TYPE :EXTERNAL-FORMAT :BUFFERED :TIMEOUT)
+(SOCKET:SOCKET-STATUS socket-stream-or-list &OPTIONAL [seconds [microseconds]])
+(SOCKET:SOCKET-STREAM-HOST socket-stream)
+(SOCKET:SOCKET-STREAM-PORT socket-stream)
+(SOCKET:SOCKET-SERVICE-PORT &OPTIONAL service-name (protocol "tcp"))
+(SOCKET:SOCKET-STREAM-PEER socket-stream [do-not-resolve-p])
+(SOCKET:SOCKET-STREAM-LOCAL socket-stream [do-not-resolve-p])
+(SOCKET:SOCKET-STREAM-SHUTDOWN socket-stream direction)
+(SOCKET:SOCKET-OPTIONS socket-server &REST {option}*)
+
+
+(posix:resolve-host-ipaddr &optional host)
+
+with the host-ent structure:
+
+ name - host name
+ aliases - LIST of aliases
+ addr-list - LIST of IPs as dotted quads (IPv4) or coloned octets (IPv6)
+ addrtype - INTEGER address type IPv4 or IPv6
+
+
+Errors are of type
+
+SYSTEM::SIMPLE-OS-ERROR
+ with a 1 element (integer) SYSTEM::$FORMAT-ARGUMENTS list
+
+This integer stores the OS error reported; meaning WSA* codes on Win32
+and E* codes on *nix, only: unix.lisp in CMUCL shows
+BSD, Linux and SRV4 have different number assignments for the same
+E* constant names :-(
+
--- /dev/null
+http://cvs2.cons.org/ftp-area/cmucl/doc/cmu-user/internet.html
+
+$Id$
+
+extensions:lookup-host-entry host
+
+[structure]
+host-entry
+
+ name aliases addr-type addr-list
+
+[Function]
+extensions:create-inet-listener port &optional kind &key :reuse-address :backlog :interface
+ => socket fd
+
+[Function]
+extensions:accept-tcp-connection unconnected
+ => socket fd, address
+
+[Function]
+extensions:connect-to-inet-socket host port &optional kind
+ => socket fd
+
+[Function]
+extensions:close-socket socket
+
+
+
+[Private function]
+extensions::get-peer-host-and-port socket-fd
+
+[Private function]
+extentsions::get-socket-host-and-port socket-fd
+
+
+
+There's currently only 1 condition to be raised:
+
+ SOCKET-ERROR (derived from SIMPLE-ERROR)
+ which has a SOCKET-ERRNO slot containing the unix error number.
+
+
+
+
+[Function]
+extensions:add-oob-handler fd char handler
+
+[Function]
+extensions:remove-oob-handler fd char
+
+[Function]
+extensions:remove-all-oob-handlers fd
+
+[Function]
+extensions:send-character-out-of-band fd char
+
+[Function]
+extensions:create-inet-socket &optional type
+ => socket fd
+
+[Function]
+extensions:get-socket-option socket level optname
+
+[Function]
+extensions:set-socket-option socket level optname optval
+
+[Function]
+extensions:ip-string addr
+
--- /dev/null
+EADDRINUSE 48 address-in-use-error
+EADDRNOTAVAIL 49 address-not-available-error
+EAGAIN interrupted-error ;; not 1 error code: bsd == 11; non-bsd == 35
+EBADF 9 bad-file-descriptor-error
+ECONNREFUSED 61 connection-refused-error
+EINTR 4 interrupted-error
+EINVAL 22 invalid-argument-error
+ENOBUFS 55 no-buffers-error
+ENOMEM 12 out-of-memory-error
+EOPNOTSUPP 45 operation-not-supported-error
+EPERM 1 operation-not-permitted-error
+EPROTONOSUPPORT 43 protocol-not-supported-error
+ESOCKTNOSUPPORT 44 socket-type-not-supported-error
+ENETUNREACH 51 network-unreachable-error
+ENETDOWN 50 network-down-error
+ENETRESET 52 network-reset-error
+ESHUTDOWN 58 already-shutdown-error
+ETIMEDOUT 60 connection-timeout-error
+EHOSTDOWN 64 host-down-error
+EHOSTUNREACH 65 host-unreachable-error
--- /dev/null
+
+$Id$
+
+http://www.lispworks.com/reference/lwu41/lwref/LWRM_37.HTM
+
+Package: COMM
+
+ip-address-string
+socket-stream-address
+socket-stream-peer-address
+start-up-server
+start-up-server-and-mp
+string-ip-address
+with-noticed-socket-stream
+
+Needed components for usocket:
+
+comm::get-fd-from-socket socket-fd
+ => socket-fd
+
+comm::accept-connection-to-socket socket-fd
+ => socket-fd
+
+comm::close-socket
+comm::create-tcp-socket-for-service
+ => socket-fd
+
+open-tcp-stream peer-host peer-port &key direction element-type
+ => socket-stream
+
+get-host-entry (see http://www.lispworks.com/documentation/lw445/LWRM/html/lwref-30.htm#pgfId-897837)
+get-socket-address
+
+get-socket-peer-address
+ => address, port
+
+socket-stream socket-fd
+ => stream
+
+socket socket-stream (guessed from http://www.lispworks.com/documentation/lw445/LWRM/html/lwref-43.htm)
+ => socket-fd
--- /dev/null
+http://openmcl.clozure.com/Doc/sockets.html
+
+ make-socket [Function]
+ accept-connection [Function]
+ dotted-to-ipaddr [Function]
+ ipaddr-to-dotted [Function]
+ ipaddr-to-hostname [Function]
+ lookup-hostname [Function]
+ lookup-port [Function]
+ receive-from [Function]
+ send-to [Function]
+ shutdown [Function]
+ socket-os-fd [Function]
+ remote-port [Function]
+ local-host [Function]
+ local-port [Function]
+
+ socket-address-family [Function]
+
+ socket-connect [Function]
+ socket-format [Function]
+ socket-type [Function]
+ socket-error [Class]
+ socket-error-code [Function]
+ socket-error-identifier [Function]
+ socket-error-situation [Function]
+ close [method]
--- /dev/null
+http://www.xach.com/sbcl/sb-bsd-sockets.html
+
+$Id$
+
+package: sb-bsd-sockets
+
+class: socket
+
+slots:
+
+ * file-descriptor :
+ * family :
+ * protocol :
+ * type :
+ * stream :
+
+operators:
+
+ (socket-bind (s socket) &rest address) Generic Function
+ (socket-accept (socket socket)) Method
+ (socket-connect (s socket) &rest address) Generic Function
+ (socket-peername (socket socket)) Method
+ (socket-name (socket socket)) Method
+ (socket-receive (socket socket) buffer length &key oob peek waitall (element-type 'character)) Method
+ (socket-listen (socket socket) backlog) Method
+ (socket-close (socket socket)) Method
+ (socket-make-stream (socket socket) &rest args) Method
+
+ (sockopt-reuse-address (socket socket) argument) Accessor
+ (sockopt-keep-alive (socket socket) argument) Accessor
+ (sockopt-oob-inline (socket socket) argument) Accessor
+ (sockopt-bsd-compatible (socket socket) argument) Accessor
+ (sockopt-pass-credentials (socket socket) argument) Accessor
+ (sockopt-debug (socket socket) argument) Accessor
+ (sockopt-dont-route (socket socket) argument) Accessor
+ (sockopt-broadcast (socket socket) argument) Accessor
+ (sockopt-tcp-nodelay (socket socket) argument) Accessor
+
+inet-domain sockets
+
+class: inet-socket
+
+slots:
+
+ * family :
+
+operators:
+
+ (make-inet-address dotted-quads) Function
+ (get-protocol-by-name name) Function
+ (make-inet-socket type protocol) Function
+
+file-domain sockets
+
+class: unix-socket
+
+slots:
+
+ * family :
+
+class: host-ent
+
+Slots:
+
+ * name :
+ * aliases :
+ * address-type :
+ * addresses :
+
+ (host-ent-address (host-ent host-ent)) Method
+ (get-host-by-name host-name) Function
+ (get-host-by-address address) Function
+ (name-service-error where) Function
+ (non-blocking-mode (socket socket)) Method
+
+(define-socket-condition sockint::EADDRINUSE address-in-use-error)
+(define-socket-condition sockint::EAGAIN interrupted-error)
+(define-socket-condition sockint::EBADF bad-file-descriptor-error)
+(define-socket-condition sockint::ECONNREFUSED connection-refused-error)
+(define-socket-condition sockint::EINTR interrupted-error)
+(define-socket-condition sockint::EINVAL invalid-argument-error)
+(define-socket-condition sockint::ENOBUFS no-buffers-error)
+(define-socket-condition sockint::ENOMEM out-of-memory-error)
+(define-socket-condition sockint::EOPNOTSUPP operation-not-supported-error)
+(define-socket-condition sockint::EPERM operation-not-permitted-error)
+(define-socket-condition sockint::EPROTONOSUPPORT protocol-not-supported-error)
+(define-socket-condition sockint::ESOCKTNOSUPPORT socket-type-not-supported-error)
+(define-socket-condition sockint::ENETUNREACH network-unreachable-error)
+
+Exported errors:
+* (apropos "ERROR" :sb-bsd-sockets)
+
+SB-BSD-SOCKETS:INTERRUPTED-ERROR
+SB-BSD-SOCKETS:TRY-AGAIN-ERROR
+* SB-BSD-SOCKETS:NO-RECOVERY-ERROR (EFAIL?)
+SB-BSD-SOCKETS:CONNECTION-REFUSED-ERROR
+SB-BSD-SOCKETS:INVALID-ARGUMENT-ERROR
+* SB-BSD-SOCKETS:HOST-NOT-FOUND-ERROR
+SB-BSD-SOCKETS:OPERATION-NOT-PERMITTED-ERROR
+SB-BSD-SOCKETS:OPERATION-NOT-SUPPORTED-ERROR
+SB-BSD-SOCKETS:PROTOCOL-NOT-SUPPORTED-ERROR
+SB-BSD-SOCKETS:OPERATION-TIMEOUT-ERROR
+SB-BSD-SOCKETS:SOCKET-TYPE-NOT-SUPPORTED-ERROR
+SB-BSD-SOCKETS:NO-BUFFERS-ERROR
+SB-BSD-SOCKETS:NETWORK-UNREACHABLE-ERROR
+SB-BSD-SOCKETS:BAD-FILE-DESCRIPTOR-ERROR
+SB-BSD-SOCKETS:ADDRESS-IN-USE-ERROR
+SB-BSD-SOCKETS:OUT-OF-MEMORY-ERROR
+
+And 1 non-exported error:
+
+SB-BSD-SOCKETS::NO-ADDRESS-ERROR
+
+*-ed errors aren't yet addressed in the errorlist supported by usocket
--- /dev/null
+Package:
+
+ clisp : socket
+ cmucl : extensions
+ sbcl : sb-bsd-sockets
+ lw : comm
+ openmcl: openmcl-socket
+ allegro: sock
+
+Connecting (TCP/inet only)
+
+ clisp : socket-connect port &optional [host] &key :element-type :external-format :buffered :timeout = > socket-stream
+ cmucl : connect-to-inet-socket host port &optional kind => file descriptor
+ sbcl : sb-socket-connect socket &rest address => socket
+ lw : open-tcp-stream hostname service &key direction element-type buffered => stream-object
+ openmcl: socket-connect socket => :active, :passive or nil
+ allegro: make-socket (&rest args &key type format connect address-family eol) => socket
+
+Closing
+
+ clisp : close socket
+ cmucl : close-socket socket
+ sbcl : socket-close socket
+ lw : close socket
+ openmcl: close socket
+ allegro: close socket
+
+Errors
\ No newline at end of file
--- /dev/null
+;;;; SOCKET-OPTION, a high-level socket option get/set framework
+
+;;;; See LICENSE for licensing information.
+
+(in-package :usocket)
+
+;;; Interface definition
+
+(defgeneric socket-option (socket option &key)
+ (:documentation
+ "Get a socket's internal options"))
+
+(defgeneric (setf socket-option) (new-value socket option &key)
+ (:documentation
+ "Set a socket's internal options"))
+
+;;; Handling of wrong type of arguments
+
+(defmethod socket-option ((socket usocket) (option t) &key)
+ (error 'type-error :datum option :expected-type 'keyword))
+
+(defmethod (setf socket-option) (new-value (socket usocket) (option t) &key)
+ (declare (ignore new-value))
+ (socket-option socket option))
+
+(defmethod socket-option ((socket usocket) (option symbol) &key)
+ (if (keywordp option)
+ (error 'unimplemented :feature option :context 'socket-option)
+ (error 'type-error :datum option :expected-type 'keyword)))
+
+(defmethod (setf socket-option) (new-value (socket usocket) (option symbol) &key)
+ (declare (ignore new-value))
+ (socket-option socket option))
+
+;;; Socket option: RECEIVE-TIMEOUT (SO_RCVTIMEO)
+
+(defmethod socket-option ((usocket stream-usocket)
+ (option (eql :receive-timeout)) &key)
+ (declare (ignorable option))
+ (let ((socket (socket usocket)))
+ (declare (ignorable socket))
+ #+abcl
+ () ; TODO
+ #+allegro
+ () ; TODO
+ #+clisp
+ (socket:socket-options socket :so-rcvtimeo)
+ #+clozure
+ (ccl:stream-input-timeout socket)
+ #+cmu
+ (lisp::fd-stream-timeout (socket-stream usocket))
+ #+ecl
+ (sb-bsd-sockets:sockopt-receive-timeout socket)
+ #+lispworks
+ (get-socket-receive-timeout socket)
+ #+mcl
+ () ; TODO
+ #+mocl
+ () ; unknown
+ #+sbcl
+ (sb-impl::fd-stream-timeout (socket-stream usocket))
+ #+scl
+ ())) ; TODO
+
+(defmethod (setf socket-option) (new-value (usocket stream-usocket)
+ (option (eql :receive-timeout)) &key)
+ (declare (type number new-value) (ignorable new-value option))
+ (let ((socket (socket usocket))
+ (timeout new-value))
+ (declare (ignorable socket timeout))
+ #+abcl
+ () ; TODO
+ #+allegro
+ () ; TODO
+ #+clisp
+ (socket:socket-options socket :so-rcvtimeo timeout)
+ #+clozure
+ (setf (ccl:stream-input-timeout socket) timeout)
+ #+cmu
+ (setf (lisp::fd-stream-timeout (socket-stream usocket))
+ (coerce timeout 'integer))
+ #+ecl
+ (setf (sb-bsd-sockets:sockopt-receive-timeout socket) timeout)
+ #+lispworks
+ (set-socket-receive-timeout socket timeout)
+ #+mcl
+ () ; TODO
+ #+mocl
+ () ; unknown
+ #+sbcl
+ (setf (sb-impl::fd-stream-timeout (socket-stream usocket))
+ (coerce timeout 'single-float))
+ #+scl
+ () ; TODO
+ new-value))
+
+;;; Socket option: SEND-TIMEOUT (SO_SNDTIMEO)
+
+(defmethod socket-option ((usocket stream-usocket)
+ (option (eql :send-timeout)) &key)
+ (declare (ignorable option))
+ (let ((socket (socket usocket)))
+ (declare (ignorable socket))
+ #+abcl
+ () ; TODO
+ #+allegro
+ () ; TODO
+ #+clisp
+ (socket:socket-options socket :so-sndtimeo)
+ #+clozure
+ (ccl:stream-output-timeout socket)
+ #+cmu
+ (lisp::fd-stream-timeout (socket-stream usocket))
+ #+ecl
+ (sb-bsd-sockets:sockopt-send-timeout socket)
+ #+lispworks
+ (get-socket-send-timeout socket)
+ #+mcl
+ () ; TODO
+ #+mocl
+ () ; unknown
+ #+sbcl
+ (sb-impl::fd-stream-timeout (socket-stream usocket))
+ #+scl
+ ())) ; TODO
+
+(defmethod (setf socket-option) (new-value (usocket stream-usocket)
+ (option (eql :send-timeout)) &key)
+ (declare (type number new-value) (ignorable new-value option))
+ (let ((socket (socket usocket))
+ (timeout new-value))
+ (declare (ignorable socket timeout))
+ #+abcl
+ () ; TODO
+ #+allegro
+ () ; TODO
+ #+clisp
+ (socket:socket-options socket :so-sndtimeo timeout)
+ #+clozure
+ (setf (ccl:stream-output-timeout socket) timeout)
+ #+cmu
+ (setf (lisp::fd-stream-timeout (socket-stream usocket))
+ (coerce timeout 'integer))
+ #+ecl
+ (setf (sb-bsd-sockets:sockopt-send-timeout socket) timeout)
+ #+lispworks
+ (set-socket-send-timeout socket timeout)
+ #+mcl
+ () ; TODO
+ #+mocl
+ () ; unknown
+ #+sbcl
+ (setf (sb-impl::fd-stream-timeout (socket-stream usocket))
+ (coerce timeout 'single-float))
+ #+scl
+ () ; TODO
+ new-value))
+
+;;; Socket option: REUSE-ADDRESS (SO_REUSEADDR), for TCP server
+
+(defmethod socket-option ((usocket stream-server-usocket)
+ (option (eql :reuse-address)) &key)
+ (declare (ignorable option))
+ (let ((socket (socket usocket)))
+ (declare (ignorable socket))
+ #+abcl
+ () ; TODO
+ #+allegro
+ () ; TODO
+ #+clisp
+ (int->bool (socket:socket-options socket :so-reuseaddr))
+ #+clozure
+ (int->bool (get-socket-option-reuseaddr socket))
+ #+cmu
+ () ; TODO
+ #+lispworks
+ (get-socket-reuse-address socket)
+ #+mcl
+ () ; TODO
+ #+mocl
+ () ; unknown
+ #+(or ecl sbcl)
+ (sb-bsd-sockets:sockopt-reuse-address socket)
+ #+scl
+ ())) ; TODO
+
+(defmethod (setf socket-option) (new-value (usocket stream-server-usocket)
+ (option (eql :reuse-address)) &key)
+ (declare (type boolean new-value) (ignorable new-value option))
+ (let ((socket (socket usocket)))
+ (declare (ignorable socket))
+ #+abcl
+ () ; TODO
+ #+allegro
+ (socket:set-socket-options socket option new-value)
+ #+clisp
+ (socket:socket-options socket :so-reuseaddr (bool->int new-value))
+ #+clozure
+ (set-socket-option-reuseaddr socket (bool->int new-value))
+ #+cmu
+ () ; TODO
+ #+lispworks
+ (set-socket-reuse-address socket new-value)
+ #+mcl
+ () ; TODO
+ #+mocl
+ () ; unknown
+ #+(or ecl sbcl)
+ (setf (sb-bsd-sockets:sockopt-reuse-address socket) new-value)
+ #+scl
+ () ; TODO
+ new-value))
+
+;;; Socket option: BROADCAST (SO_BROADCAST), for UDP client
+
+(defmethod socket-option ((usocket datagram-usocket)
+ (option (eql :broadcast)) &key)
+ (declare (ignorable option))
+ (let ((socket (socket usocket)))
+ (declare (ignorable socket))
+ #+abcl
+ () ; TODO
+ #+allegro
+ () ; TODO
+ #+clisp
+ (int->bool (socket:socket-options socket :so-broadcast))
+ #+clozure
+ (int->bool (get-socket-option-broadcast socket))
+ #+cmu
+ () ; TODO
+ #+ecl
+ () ; TODO
+ #+lispworks
+ () ; TODO
+ #+mcl
+ () ; TODO
+ #+mocl
+ () ; unknown
+ #+sbcl
+ (sb-bsd-sockets:sockopt-broadcast socket)
+ #+scl
+ ())) ; TODO
+
+(defmethod (setf socket-option) (new-value (usocket datagram-usocket)
+ (option (eql :broadcast)) &key)
+ (declare (type boolean new-value) (ignorable new-value option))
+ (let ((socket (socket usocket)))
+ (declare (ignorable socket))
+ #+abcl
+ () ; TODO
+ #+allegro
+ (socket:set-socket-options socket option new-value)
+ #+clisp
+ (socket:socket-options socket :so-broadcast (bool->int new-value))
+ #+clozure
+ (set-socket-option-broadcast socket (bool->int new-value))
+ #+cmu
+ () ; TODO
+ #+ecl
+ () ; TODO
+ #+lispworks
+ () ; TODO
+ #+mcl
+ () ; TODO
+ #+mocl
+ () ; unknown
+ #+sbcl
+ (setf (sb-bsd-sockets:sockopt-broadcast socket) new-value)
+ #+scl
+ () ; TODO
+ new-value))
+
+;;; Socket option: TCP-NODELAY (TCP_NODELAY), for TCP client
+
+(defmethod socket-option ((usocket stream-usocket)
+ (option (eql :tcp-no-delay)) &key)
+ (declare (ignore option))
+ (socket-option usocket :tcp-nodelay))
+
+(defmethod socket-option ((usocket stream-usocket)
+ (option (eql :tcp-nodelay)) &key)
+ (declare (ignorable option))
+ (let ((socket (socket usocket)))
+ (declare (ignorable socket))
+ #+abcl
+ () ; TODO
+ #+allegro
+ () ; TODO
+ #+clisp
+ (int->bool (socket:socket-options socket :tcp-nodelay))
+ #+clozure
+ (int->bool (get-socket-option-tcp-nodelay socket))
+ #+cmu
+ ()
+ #+ecl
+ (sb-bsd-sockets::sockopt-tcp-nodelay socket)
+ #+lispworks
+ (int->bool (get-socket-tcp-nodelay socket))
+ #+mcl
+ () ; TODO
+ #+mocl
+ () ; unknown
+ #+sbcl
+ (sb-bsd-sockets::sockopt-tcp-nodelay socket)
+ #+scl
+ ())) ; TODO
+
+(defmethod (setf socket-option) (new-value (usocket stream-usocket)
+ (option (eql :tcp-no-delay)) &key)
+ (declare (ignore option))
+ (setf (socket-option usocket :tcp-nodelay) new-value))
+
+(defmethod (setf socket-option) (new-value (usocket stream-usocket)
+ (option (eql :tcp-nodelay)) &key)
+ (declare (type boolean new-value) (ignorable new-value option))
+ (let ((socket (socket usocket)))
+ (declare (ignorable socket))
+ #+abcl
+ () ; TODO
+ #+allegro
+ (socket:set-socket-options socket :no-delay new-value)
+ #+clisp
+ (socket:socket-options socket :tcp-nodelay (bool->int new-value))
+ #+clozure
+ (set-socket-option-tcp-nodelay socket (bool->int new-value))
+ #+cmu
+ ()
+ #+ecl
+ (setf (sb-bsd-sockets::sockopt-tcp-nodelay socket) new-value)
+ #+lispworks
+ (progn
+ #-lispworks4
+ (comm::set-socket-tcp-nodelay socket new-value)
+ #+lispworks4
+ (set-socket-tcp-nodelay socket (bool->int new-value)))
+ #+mcl
+ () ; TODO
+ #+mocl
+ () ; unknown
+ #+sbcl
+ (setf (sb-bsd-sockets::sockopt-tcp-nodelay socket) new-value)
+ #+scl
+ () ; TODO
+ new-value))
--- /dev/null
+;;;; See the LICENSE file for licensing information.
+
+(defpackage :usocket
+ (:use :common-lisp #+abcl :java
+ :split-sequence)
+ (:export #:*version*
+ #:*wildcard-host*
+ #:*auto-port*
+
+ #:+max-datagram-packet-size+
+
+ #:socket-connect ; socket constructors and methods
+ #:socket-listen
+ #:socket-accept
+ #:socket-close
+ #:socket-shutdown
+ #:get-local-address
+ #:get-peer-address
+ #:get-local-port
+ #:get-peer-port
+ #:get-local-name
+ #:get-peer-name
+
+ #:socket-send ; udp function (send)
+ #:socket-receive ; udp function (receive)
+ #:socket-option ; 0.6.x
+
+ #:wait-for-input ; waiting for input-ready state (select() like)
+ #:make-wait-list
+ #:add-waiter
+ #:remove-waiter
+ #:remove-all-waiters
+
+ #:with-connected-socket ; convenience macros
+ #:with-server-socket
+ #:with-client-socket
+ #:with-socket-listener
+
+ #:usocket ; socket object and accessors
+ #:stream-usocket
+ #:stream-server-usocket
+ #:socket
+ #:socket-stream
+ #:datagram-usocket
+ #:socket-state ; 0.6.4
+
+ ;; predicates (for version 0.6 or 1.0 ?)
+ #:usocket-p
+ #:stream-usocket-p
+ #:stream-server-usocket-p
+ #:datagram-usocket-p
+
+ #:host-byte-order ; IPv4 utility functions
+ #:hbo-to-dotted-quad
+ #:hbo-to-vector-quad
+ #:vector-quad-to-dotted-quad
+ #:dotted-quad-to-vector-quad
+
+ #:vector-to-ipv6-host ; IPv6 utility functions
+ #:ipv6-host-to-vector
+
+ #:ip= ; IPv4+IPv6 utility function
+ #:ip/=
+
+ #:integer-to-octet-buffer ; Network utility functions
+ #:octet-buffer-to-integer
+ #:port-to-octet-buffer
+ #:port-from-octet-buffer
+ #:ip-to-octet-buffer
+ #:ip-from-octet-buffer
+
+ #:with-mapped-conditions
+
+ #:socket-condition ; conditions
+ #:ns-condition
+ #:socket-error ; errors
+ #:ns-error
+ #:unknown-condition
+ #:ns-unknown-condition
+ #:unknown-error
+ #:ns-unknown-error
+ #:socket-warning ; warnings (udp)
+
+ #:insufficient-implementation ; conditions regarding usocket support level
+ #:unsupported
+ #:unimplemented))
--- /dev/null
+(in-package :usocket)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (use-package :portable-threads)
+
+ (export '(socket-server
+ *remote-host*
+ *remote-port*)))
+
+(defun socket-server (host port function &optional arguments
+ &key in-new-thread (protocol :stream)
+ ;; for udp
+ (timeout 1) (max-buffer-size +max-datagram-packet-size+)
+ ;; for tcp
+ element-type reuse-address multi-threading
+ name)
+ (let* ((real-host (or host *wildcard-host*))
+ (socket (ecase protocol
+ (:stream
+ (apply #'socket-listen
+ `(,real-host ,port
+ ,@(when element-type `(:element-type ,element-type))
+ ,@(when reuse-address `(:reuse-address ,reuse-address)))))
+ (:datagram
+ (socket-connect nil nil :protocol :datagram
+ :local-host real-host
+ :local-port port)))))
+ (labels ((real-call ()
+ (ecase protocol
+ (:stream
+ (tcp-event-loop socket function arguments
+ :element-type element-type
+ :multi-threading multi-threading))
+ (:datagram
+ (udp-event-loop socket function arguments
+ :timeout timeout
+ :max-buffer-size max-buffer-size)))))
+ (if in-new-thread
+ (values (spawn-thread (or name "USOCKET Server") #'real-call) socket)
+ (real-call)))))
+
+(defvar *remote-host*)
+(defvar *remote-port*)
+
+(defun default-udp-handler (buffer) ; echo
+ (declare (type (simple-array (unsigned-byte 8) *) buffer))
+ buffer)
+
+(defun udp-event-loop (socket function &optional arguments
+ &key timeout max-buffer-size)
+ (let ((buffer (make-array max-buffer-size :element-type '(unsigned-byte 8) :initial-element 0))
+ (sockets (list socket)))
+ (unwind-protect
+ (loop do
+ (multiple-value-bind (return-sockets real-time)
+ (wait-for-input sockets :timeout timeout)
+ (declare (ignore return-sockets))
+ (when real-time
+ (multiple-value-bind (recv n *remote-host* *remote-port*)
+ (socket-receive socket buffer max-buffer-size)
+ (declare (ignore recv))
+ (if (plusp n)
+ (progn
+ (let ((reply
+ (apply function (subseq buffer 0 n) arguments)))
+ (when reply
+ (replace buffer reply)
+ (let ((n (socket-send socket buffer (length reply)
+ :host *remote-host*
+ :port *remote-port*)))
+ (when (minusp n)
+ (error "send error: ~A~%" n))))))
+ (error "receive error: ~A" n))))
+ #+scl (when thread:*quitting-lisp* (return))
+ #+(and cmu mp) (mp:process-yield)))
+ (socket-close socket)
+ (values))))
+
+(defun default-tcp-handler (stream) ; null
+ (declare (type stream stream))
+ (terpri stream))
+
+(defun echo-tcp-handler (stream)
+ (loop
+ (when (listen stream)
+ (let ((line (read-line stream nil)))
+ (write-line line stream)
+ (force-output stream)))))
+
+(defun tcp-event-loop (socket function &optional arguments
+ &key element-type multi-threading)
+ (let ((real-function #'(lambda (client-socket &rest arguments)
+ (unwind-protect
+ (multiple-value-bind (*remote-host* *remote-port*) (get-peer-name client-socket)
+ (apply function (socket-stream client-socket) arguments))
+ (close (socket-stream client-socket))
+ (socket-close client-socket)
+ nil))))
+ (unwind-protect
+ (loop do
+ (let* ((client-socket (apply #'socket-accept
+ `(,socket ,@(when element-type `(:element-type ,element-type)))))
+ (client-stream (socket-stream client-socket)))
+ (if multi-threading
+ (apply #'spawn-thread "USOCKET Client" real-function client-socket arguments)
+ (prog1 (apply real-function client-socket arguments)
+ (close client-stream)
+ (socket-close client-socket)))
+ #+scl (when thread:*quitting-lisp* (return))
+ #+(and cmu mp) (mp:process-yield)))
+ (socket-close socket)
+ (values))))
--- /dev/null
+;;;; See the LICENSE file for licensing information.
+
+(in-package :cl-user)
+
+(defpackage :usocket-test
+ (:use :common-lisp
+ :usocket
+ :regression-test)
+ (:export #:do-tests
+ #:run-usocket-tests))
--- /dev/null
+;;;; $Id$
+;;;; $URL$
+
+(in-package :usocket-test)
+
+(deftest ns-host-not-found-error.1
+ (with-caught-conditions (usocket:ns-host-not-found-error nil)
+ (usocket:socket-connect "xxx" 123)
+ t)
+ nil)
+
+(deftest timeout-error.1
+ (with-caught-conditions (usocket:timeout-error nil)
+ (usocket:socket-connect "common-lisp.net" 81 :timeout 0)
+ t)
+ nil)
+
+(deftest connection-refused-error.1
+ (with-caught-conditions (usocket:connection-refused-error nil)
+ (usocket:socket-connect "common-lisp.net" 81)
+ t)
+ nil)
+
+(deftest operation-not-permitted-error.1
+ (with-caught-conditions (usocket:operation-not-permitted-error nil)
+ (usocket:socket-listen "0.0.0.0" 81)
+ t)
+ nil)
--- /dev/null
+(in-package :usocket-test)
+
+(defvar *echo-server*)
+(defvar *echo-server-port*)
+
+(defun start-server ()
+ (multiple-value-bind (thread socket)
+ (usocket:socket-server "127.0.0.1" 0 #'identity nil
+ :in-new-thread t
+ :protocol :datagram)
+ (setq *echo-server* thread
+ *echo-server-port* (usocket:get-local-port socket))))
+
+(defparameter *max-buffer-size* 32)
+
+(defvar *send-buffer*
+ (make-array *max-buffer-size* :element-type '(unsigned-byte 8) :initial-element 0))
+
+(defvar *receive-buffer*
+ (make-array *max-buffer-size* :element-type '(unsigned-byte 8) :initial-element 0))
+
+(defun clean-buffers ()
+ (fill *send-buffer* 0)
+ (fill *receive-buffer* 0))
+
+;;; UDP Send Test #1: connected socket
+(deftest udp-send.1
+ (progn
+ (unless (and *echo-server* *echo-server-port*)
+ (start-server))
+ (let ((s (usocket:socket-connect "127.0.0.1" *echo-server-port* :protocol :datagram)))
+ (clean-buffers)
+ (replace *send-buffer* #(1 2 3 4 5))
+ (usocket:socket-send s *send-buffer* 5)
+ (usocket:wait-for-input s :timeout 3)
+ (multiple-value-bind (buffer size host port)
+ (usocket:socket-receive s *receive-buffer* *max-buffer-size*)
+ (declare (ignore buffer size host port))
+ (reduce #'+ *receive-buffer* :start 0 :end 5))))
+ 15)
+
+;;; UDP Send Test #2: unconnected socket
+(deftest udp-send.2
+ (progn
+ (unless (and *echo-server* *echo-server-port*)
+ (start-server))
+ (let ((s (usocket:socket-connect nil nil :protocol :datagram)))
+ (clean-buffers)
+ (replace *send-buffer* #(1 2 3 4 5))
+ (usocket:socket-send s *send-buffer* 5 :host "127.0.0.1" :port *echo-server-port*)
+ (usocket:wait-for-input s :timeout 3)
+ (multiple-value-bind (buffer size host port)
+ (usocket:socket-receive s *receive-buffer* *max-buffer-size*)
+ (declare (ignore buffer size host port))
+ (reduce #'+ *receive-buffer* :start 0 :end 5))))
+ 15)
+
+(deftest mark-h-david ; Mark H. David's remarkable UDP test code
+ (let* ((host "localhost")
+ (port 1111)
+ (server-sock
+ (usocket:socket-connect nil nil :protocol ':datagram :local-host host :local-port port))
+ (client-sock
+ (usocket:socket-connect host port :protocol ':datagram))
+ (octet-vector
+ (make-array 2 :element-type '(unsigned-byte 8) :initial-contents `(,(char-code #\O) ,(char-code #\K))))
+ (recv-octet-vector
+ (make-array 2 :element-type '(unsigned-byte 8))))
+ (usocket:socket-send client-sock octet-vector 2)
+ (usocket:socket-receive server-sock recv-octet-vector 2)
+ (prog1 (and (equalp octet-vector recv-octet-vector)
+ recv-octet-vector)
+ (usocket:socket-close server-sock)
+ (usocket:socket-close client-sock)))
+ #(79 75))
+
+(deftest frank-james ; Frank James' test code for LispWorks/UDP
+ (with-caught-conditions (#+win32 USOCKET:CONNECTION-RESET-ERROR
+ #-win32 USOCKET:CONNECTION-REFUSED-ERROR
+ nil)
+ (let ((sock (usocket:socket-connect "localhost" 1234
+ :protocol ':datagram :element-type '(unsigned-byte 8))))
+ (unwind-protect
+ (progn
+ (usocket:socket-send sock (make-array 16 :element-type '(unsigned-byte 8) :initial-element 0) 16)
+ (let ((buffer (make-array 16 :element-type '(unsigned-byte 8) :initial-element 0)))
+ (usocket:socket-receive sock buffer 16)))
+ (usocket:socket-close sock))))
+ nil)
+
+(defun frank-wfi-test ()
+ (let ((s (usocket:socket-connect nil nil
+ :protocol :datagram
+ :element-type '(unsigned-byte 8)
+ :local-port 8001)))
+ (unwind-protect
+ (do ((i 0 (1+ i))
+ (buffer (make-array 1024 :element-type '(unsigned-byte 8)
+ :initial-element 0))
+ (now (get-universal-time))
+ (done nil))
+ ((or done (= i 4))
+ nil)
+ (format t "~Ds ~D Waiting state ~S~%" (- (get-universal-time) now) i (usocket::state s))
+ (when (usocket:wait-for-input s :ready-only t :timeout 5)
+ (format t "~D state ~S~%" i (usocket::state s))
+ (handler-bind
+ ((error (lambda (c)
+ (format t "socket-receive error: ~A~%" c)
+ (break)
+ nil)))
+ (multiple-value-bind (buffer count remote-host remote-port)
+ (usocket:socket-receive s buffer 1024)
+ (handler-bind
+ ((error (lambda (c)
+ (format t "socket-send error: ~A~%" c)
+ (break))))
+ (when buffer
+ (usocket:socket-send s (subseq buffer 0 count) count
+ :host remote-host
+ :port remote-port)))))))
+ (usocket:socket-close s))))
--- /dev/null
+;;;; $Id$
+;;;; $URL$
+
+;;;; See LICENSE for licensing information.
+
+;;;; Usage: (usoct:run-usocket-tests) or (usoct:do-tests)
+
+(in-package :usocket-test)
+
+(defparameter +non-existing-host+ "1.2.3.4")
+(defparameter +unused-local-port+ 15213)
+
+(defparameter *fake-usocket*
+ (usocket::make-stream-socket :socket :my-socket
+ :stream :my-stream))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defvar *common-lisp-net*
+ #.(first (usocket::get-hosts-by-name "common-lisp.net"))))
+
+(defvar *local-ip*)
+
+(defmacro with-caught-conditions ((expect throw) &body body)
+ `(catch 'caught-error
+ (handler-case
+ (handler-bind ((usocket:unsupported
+ #'(lambda (c)
+ (declare (ignore c)) (continue))))
+ (progn ,@body))
+ (usocket:unknown-error (c) (if (typep c ',expect)
+ (throw 'caught-error ,throw)
+ (progn
+ (describe c)
+ (describe
+ (usocket::usocket-real-error c))
+ c)))
+ (error (c) (if (typep c ',expect)
+ (throw 'caught-error ,throw)
+ (progn
+ (describe c)
+ c)))
+ (usocket:unknown-condition (c) (if (typep c ',expect)
+ (throw 'caught-error ,throw)
+ (progn
+ (describe c)
+ (describe
+ (usocket::usocket-real-condition c))
+ c)))
+ (condition (c) (if (typep c ',expect)
+ (throw 'caught-error ,throw)
+ (progn
+ (describe c)
+ c))))))
+
+(deftest make-socket.1 (usocket:socket *fake-usocket*) :my-socket)
+(deftest make-socket.2 (usocket:socket-stream *fake-usocket*) :my-stream)
+
+(deftest socket-no-connect.1
+ (with-caught-conditions (usocket:socket-error nil)
+ (usocket:socket-connect "127.0.0.0" +unused-local-port+ :timeout 1)
+ t)
+ nil)
+
+(deftest socket-no-connect.2
+ (with-caught-conditions (usocket:socket-error nil)
+ (usocket:socket-connect #(127 0 0 0) +unused-local-port+ :timeout 1)
+ t)
+ nil)
+
+(deftest socket-no-connect.3
+ (with-caught-conditions (usocket:socket-error nil)
+ (usocket:socket-connect 2130706432 +unused-local-port+ :timeout 1) ;; == #(127 0 0 0)
+ t)
+ nil)
+
+(deftest socket-failure.1
+ (with-caught-conditions (usocket:timeout-error nil)
+ (usocket:socket-connect 2130706432 +unused-local-port+ :timeout 1) ;; == #(127 0 0 0)
+ :unreach)
+ nil)
+
+(deftest socket-failure.2
+ (with-caught-conditions (usocket:timeout-error nil)
+ (usocket:socket-connect +non-existing-host+ 80 :timeout 1) ;; 80 = just a port
+ :unreach)
+ nil)
+
+;; let's hope c-l.net doesn't move soon, or that people start to
+;; test usocket like crazy..
+(deftest socket-connect.1
+ (with-caught-conditions (nil nil)
+ (let ((sock (usocket:socket-connect "common-lisp.net" 80)))
+ (unwind-protect
+ (when (typep sock 'usocket:usocket) t)
+ (usocket:socket-close sock))))
+ t)
+
+(deftest socket-connect.2
+ (with-caught-conditions (nil nil)
+ (let ((sock (usocket:socket-connect *common-lisp-net* 80)))
+ (unwind-protect
+ (when (typep sock 'usocket:usocket) t)
+ (usocket:socket-close sock))))
+ t)
+
+(deftest socket-connect.3
+ (with-caught-conditions (nil nil)
+ (let ((sock (usocket:socket-connect (usocket::host-byte-order *common-lisp-net*) 80)))
+ (unwind-protect
+ (when (typep sock 'usocket:usocket) t)
+ (usocket:socket-close sock))))
+ t)
+
+;; let's hope c-l.net doesn't change its software any time soon
+(deftest socket-stream.1
+ (with-caught-conditions (nil nil)
+ (let ((sock (usocket:socket-connect "common-lisp.net" 80)))
+ (unwind-protect
+ (progn
+ (format (usocket:socket-stream sock)
+ "GET / HTTP/1.0~2%")
+ (force-output (usocket:socket-stream sock))
+ (subseq (read-line (usocket:socket-stream sock)) 0 15))
+ (usocket:socket-close sock))))
+ "HTTP/1.1 200 OK")
+
+(deftest socket-name.1
+ (with-caught-conditions (nil nil)
+ (let ((sock (usocket:socket-connect *common-lisp-net* 80)))
+ (unwind-protect
+ (usocket::get-peer-address sock)
+ (usocket:socket-close sock))))
+ #.*common-lisp-net*)
+
+(deftest socket-name.2
+ (with-caught-conditions (nil nil)
+ (let ((sock (usocket:socket-connect *common-lisp-net* 80)))
+ (unwind-protect
+ (usocket::get-peer-port sock)
+ (usocket:socket-close sock))))
+ 80)
+
+(deftest socket-name.3
+ (with-caught-conditions (nil nil)
+ (let ((sock (usocket:socket-connect *common-lisp-net* 80)))
+ (unwind-protect
+ (usocket::get-peer-name sock)
+ (usocket:socket-close sock))))
+ #.*common-lisp-net* 80)
+
+#+ignore
+(deftest socket-name.4
+ (with-caught-conditions (nil nil)
+ (let ((sock (usocket:socket-connect *common-lisp-net* 80)))
+ (unwind-protect
+ (equal (usocket::get-local-address sock) *local-ip*)
+ (usocket:socket-close sock))))
+ t)
+
+(deftest socket-shutdown.1
+ (with-caught-conditions (nil nil)
+ (let ((sock (usocket:socket-connect *common-lisp-net* 80)))
+ (unwind-protect
+ (usocket::ignore-unsupported-warnings
+ (usocket:socket-shutdown sock :input))
+ (usocket:socket-close sock))
+ t))
+ t)
+
+(deftest socket-shutdown.2
+ (with-caught-conditions (nil nil)
+ (let ((sock (usocket:socket-connect *common-lisp-net* 80)))
+ (unwind-protect
+ (usocket::ignore-unsupported-warnings
+ (usocket:socket-shutdown sock :output))
+ (usocket:socket-close sock))
+ t))
+ t)
+
+(defun run-usocket-tests ()
+ (do-tests))
--- /dev/null
+;;;; $Id$
+;;;; $URL$
+
+;;;; See LICENSE for licensing information.
+(in-package :usocket-test)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defparameter *wait-for-input-timeout* 2))
+
+(deftest wait-for-input.1
+ (with-caught-conditions (nil nil)
+ (let ((sock (usocket:socket-connect *common-lisp-net* 80))
+ (time (get-universal-time)))
+ (unwind-protect
+ (progn (usocket:wait-for-input sock :timeout *wait-for-input-timeout*)
+ (- (get-universal-time) time))
+ (usocket:socket-close sock))))
+ #.*wait-for-input-timeout*)
+
+(deftest wait-for-input.2
+ (with-caught-conditions (nil nil)
+ (let ((sock (usocket:socket-connect *common-lisp-net* 80))
+ (time (get-universal-time)))
+ (unwind-protect
+ (progn (usocket:wait-for-input sock :timeout *wait-for-input-timeout* :ready-only t)
+ (- (get-universal-time) time))
+ (usocket:socket-close sock))))
+ #.*wait-for-input-timeout*)
+
+(deftest wait-for-input.3
+ (with-caught-conditions (nil nil)
+ (let ((sock (usocket:socket-connect *common-lisp-net* 80)))
+ (unwind-protect
+ (progn
+ (format (usocket:socket-stream sock)
+ "GET / HTTP/1.0~2%")
+ (force-output (usocket:socket-stream sock))
+ (usocket:wait-for-input sock :timeout *wait-for-input-timeout*)
+ (subseq (read-line (usocket:socket-stream sock)) 0 15))
+ (usocket:socket-close sock))))
+ "HTTP/1.1 200 OK")
+
+;;; Advanced W-F-I tests by Elliott Slaughter <elliottslaughter@gmail.com>
+
+(defvar *socket-server-port* 0)
+(defvar *socket-server-listen* nil)
+(defvar *socket-server-connection*)
+(defvar *socket-client-connection*)
+(defvar *output-p* t)
+
+(defun stage-1 ()
+ (unless *socket-server-listen*
+ (setf *socket-server-listen*
+ (socket-listen *wildcard-host* 0 :element-type '(unsigned-byte 8)))
+ (setf *socket-server-port* (get-local-port *socket-server-listen*)))
+
+ (setf *socket-server-connection*
+ (when (wait-for-input *socket-server-listen* :timeout 0 :ready-only t)
+ (socket-accept *socket-server-listen*)))
+
+ (when *output-p* ; should be NIL
+ (format t "First time (before client connects) is ~s.~%"
+ *socket-server-connection*))
+
+ *socket-server-connection*)
+
+;; TODO: original test code have addition (:TIMEOUT 0) when doing the SOCKET-CONNECT,
+;; it seems cannot work on SBCL/Windows, need to investigate, but here we ignore it.
+
+(defun stage-2 ()
+ (setf *socket-client-connection*
+ (socket-connect "localhost" *socket-server-port* :protocol :stream
+ :element-type '(unsigned-byte 8)))
+ (setf *socket-server-connection*
+ (when (wait-for-input *socket-server-listen* :timeout 0 :ready-only t)
+ #+(and win32 (or lispworks ecl sbcl))
+ (when *output-p*
+ (format t "%READY-P: ~D~%" (usocket::%ready-p *socket-server-listen*)))
+ (socket-accept *socket-server-listen*)))
+
+ (when *output-p* ; should be a usocket object
+ (format t "Second time (after client connects) is ~s.~%"
+ *socket-server-connection*))
+
+ *socket-server-connection*)
+
+(defun stage-3 ()
+ (setf *socket-server-connection*
+ (when (wait-for-input *socket-server-listen* :timeout 0 :ready-only t)
+ #+(and win32 (or lispworks ecl sbcl))
+ (when *output-p*
+ (format t "%READY-P: ~D~%" (usocket::%ready-p *socket-server-listen*)))
+ (socket-accept *socket-server-listen*)))
+
+ (when *output-p* ; should be NIL again
+ (format t "Third time (before second client) is ~s.~%"
+ *socket-server-connection*))
+
+ *socket-server-connection*)
+
+(deftest elliott-slaughter.1
+ (let ((*output-p* nil))
+ (let* ((s-1 (stage-1)) (s-2 (stage-2)) (s-3 (stage-3)))
+ (prog1 (and (null s-1) (usocket::usocket-p s-2) (null s-3))
+ (socket-close *socket-server-listen*)
+ (setf *socket-server-listen* nil))))
+ t)
+
+#|
+
+Issue elliott-slaughter.2 (WAIT-FOR-INPUT/win32 on TCP socket)
+
+W-F-I correctly found the inputs, but :READY-ONLY didn't work.
+
+|#
+(defun receive-each (connections)
+ (let ((ready (usocket:wait-for-input connections :timeout 0 :ready-only t)))
+ (loop for connection in ready
+ collect (read-line (usocket:socket-stream connection)))))
+
+(defun receive-all (connections)
+ (loop for messages = (receive-each connections)
+ then (receive-each connections)
+ while messages append messages))
+
+(defun send (connection message)
+ (format (usocket:socket-stream connection) "~a~%" message)
+ (force-output (usocket:socket-stream connection)))
+
+(defun server ()
+ (let* ((listen (usocket:socket-listen usocket:*wildcard-host* 12345))
+ (connection (usocket:socket-accept listen)))
+ (loop for messages = (receive-all connection) then (receive-all connection)
+ do (format t "Got messages:~%~s~%" messages)
+ do (sleep 1/50))))
+
+(defun client ()
+ (let ((connection (usocket:socket-connect "localhost" 12345)))
+ (loop for i from 0
+ do (send connection (format nil "This is message ~a." i))
+ do (sleep 1/100))))
--- /dev/null
+;;;; -*- Mode: Lisp -*-
+;;;;
+;;;; See the LICENSE file for licensing information.
+
+(in-package :asdf)
+
+(defsystem usocket-server
+ :name "usocket (server)"
+ :author "Chun Tian (binghe)"
+ :version "0.7.0"
+ :licence "MIT"
+ :description "Universal socket library for Common Lisp (server side)"
+ :depends-on (:usocket :portable-threads)
+ :components ((:file "server")))
--- /dev/null
+;;;; -*- Mode: Lisp -*-
+;;;; $Id: usocket-test.asd 46 2006-02-06 20:50:07Z ehuelsmann $
+;;;; $URL: svn+ssh://common-lisp.net/project/usocket/svn/usocket/trunk/test/usocket-test.asd $
+
+;;;; See the LICENSE file for licensing information.
+
+(defsystem usocket-test
+ :name "usocket test"
+ :author "Erik Enge"
+ :maintainer "Chun Tian (binghe)"
+ :version "0.2.0"
+ :licence "MIT"
+ :description "Tests for usocket"
+ :depends-on (:usocket
+ :rt)
+ :components ((:module "test"
+ :serial t
+ :components ((:file "package")
+ (:file "test-usocket")
+ (:file "test-condition")
+ (:file "test-datagram")
+ (:file "wait-for-input")))))
+
+(defmethod perform ((op test-op) (c (eql (find-system :usocket-test))))
+ (funcall (intern "DO-TESTS" "USOCKET-TEST")))
--- /dev/null
+;;;; -*- Mode: Lisp -*-
+;;;;
+;;;; See the LICENSE file for licensing information.
+
+(in-package :asdf)
+
+(defsystem usocket
+ :name "usocket (client)"
+ :author "Erik Enge & Erik Huelsmann"
+ :maintainer "Chun Tian (binghe) & Hans Huebner"
+ :version "0.7.0"
+ :licence "MIT"
+ :description "Universal socket library for Common Lisp"
+ :depends-on (#+(or sbcl ecl) :sb-bsd-sockets
+ :split-sequence)
+ :components ((:file "package")
+ (:module "vendor" :depends-on ("package")
+ :components (#+mcl (:file "kqueue")
+ #+mcl (:file "OpenTransportUDP")))
+ (:file "usocket" :depends-on ("vendor"))
+ (:file "condition" :depends-on ("usocket"))
+ (:module "backend" :depends-on ("condition")
+ :components (#+abcl (:file "abcl")
+ #+(or allegro cormanlisp)
+ (:file "allegro")
+ #+clisp (:file "clisp")
+ #+clozure (:file "clozure" :depends-on ("openmcl"))
+ #+cmu (:file "cmucl")
+ #+ecl (:file "ecl" :depends-on ("sbcl"))
+ #+lispworks (:file "lispworks")
+ #+mcl (:file "mcl")
+ #+mocl (:file "mocl")
+ #+openmcl (:file "openmcl")
+ #+(or ecl sbcl) (:file "sbcl")
+ #+scl (:file "scl")))
+ (:file "option" :depends-on ("backend"))))
+
+(defmethod perform ((op test-op) (c (eql (find-system :usocket))))
+ (oos 'load-op :usocket-server)
+ (oos 'load-op :usocket-test)
+ (oos 'test-op :usocket-test))
--- /dev/null
+;;;; See LICENSE for licensing information.
+
+(in-package :usocket)
+
+(defparameter *wildcard-host* #(0 0 0 0)
+ "Hostname to pass when all interfaces in the current system are to
+ be bound. If this variable is passed to socket-listen, IPv6 capable
+ systems will also listen for IPv6 connections.")
+
+(defparameter *auto-port* 0
+ "Port number to pass when an auto-assigned port number is wanted.")
+
+(defparameter *version* #.(asdf:component-version (asdf:find-system :usocket)))
+
+(defconstant +max-datagram-packet-size+ 65507
+ "The theoretical maximum amount of data in a UDP datagram.
+
+The IPv4 UDP packets have a 16-bit length constraint, and IP+UDP header has 28-byte.
+
+IP_MAXPACKET = 65535, /* netinet/ip.h */
+sizeof(struct ip) = 20, /* netinet/ip.h */
+sizeof(struct udphdr) = 8, /* netinet/udp.h */
+
+65535 - 20 - 8 = 65507
+
+(But for UDP broadcast, the maximum message size is limited by the MTU size of the underlying link)")
+
+(defclass usocket ()
+ ((socket
+ :initarg :socket
+ :accessor socket
+ :documentation "Implementation specific socket object instance.'")
+ (wait-list
+ :initform nil
+ :accessor wait-list
+ :documentation "WAIT-LIST the object is associated with.")
+ (state
+ :initform nil
+ :accessor state
+ :documentation "Per-socket return value for the `wait-for-input' function.
+
+The value stored in this slot can be any of
+ NIL - not ready
+ :READ - ready to read
+ :READ-WRITE - ready to read and write
+ :WRITE - ready to write
+
+The last two remain unused in the current version.
+")
+ #+(and win32 (or sbcl ecl lispworks))
+ (%ready-p
+ :initform nil
+ :accessor %ready-p
+ :documentation "Indicates whether the socket has been signalled
+as ready for reading a new connection.
+
+The value will be set to T by `wait-for-input-internal' (given the
+right conditions) and reset to NIL by `socket-accept'.
+
+Don't modify this slot or depend on it as it is really intended
+to be internal only.
+
+Note: Accessed, but not used for 'stream-usocket'.
+"
+ ))
+ (:documentation
+"The main socket class.
+
+Sockets should be closed using the `socket-close' method."))
+
+(defgeneric socket-state (socket)
+ (:documentation "NIL - not ready
+:READ - ready to read
+:READ-WRITE - ready to read and write
+:WRITE - ready to write"))
+
+(defmethod socket-state ((socket usocket))
+ (state socket))
+
+(defclass stream-usocket (usocket)
+ ((stream
+ :initarg :stream
+ :accessor socket-stream
+ :documentation "Stream instance associated with the socket."
+;;
+;;Iff an external-format was passed to `socket-connect' or `socket-listen'
+;;the stream is a flexi-stream. Otherwise the stream is implementation
+;;specific."
+))
+ (:documentation
+"Stream socket class.
+'
+Contrary to other sockets, these sockets may be closed either
+with the `socket-close' method or by closing the associated stream
+(which can be retrieved with the `socket-stream' accessor)."))
+
+(defclass stream-server-usocket (usocket)
+ ((element-type
+ :initarg :element-type
+ :initform #-lispworks 'character
+ #+lispworks 'base-char
+ :reader element-type
+ :documentation "Default element type for streams created by
+`socket-accept'."))
+ (:documentation "Socket which listens for stream connections to
+be initiated from remote sockets."))
+
+(defclass datagram-usocket (usocket)
+ ((connected-p :type boolean
+ :accessor connected-p
+ :initarg :connected-p)
+ #+(or cmu scl lispworks mcl
+ (and clisp ffi (not rawsock)))
+ (%open-p :type boolean
+ :accessor %open-p
+ :initform t
+ :documentation "Flag to indicate if usocket is open,
+for GC on implementions operate on raw socket fd.")
+ #+(or lispworks mcl
+ (and clisp ffi (not rawsock)))
+ (recv-buffer :documentation "Private RECV buffer.")
+ #+(or lispworks mcl)
+ (send-buffer :documentation "Private SEND buffer."))
+ (:documentation "UDP (inet-datagram) socket"))
+
+(defun usocket-p (socket)
+ (typep socket 'usocket))
+
+(defun stream-usocket-p (socket)
+ (typep socket 'stream-usocket))
+
+(defun stream-server-usocket-p (socket)
+ (typep socket 'stream-server-usocket))
+
+(defun datagram-usocket-p (socket)
+ (typep socket 'datagram-usocket))
+
+(defun make-socket (&key socket)
+ "Create a usocket socket type from implementation specific socket."
+ (unless socket
+ (error 'invalid-socket-error))
+ (make-stream-socket :socket socket))
+
+(defun make-stream-socket (&key socket stream)
+ "Create a usocket socket type from implementation specific socket
+and stream objects.
+
+Sockets returned should be closed using the `socket-close' method or
+by closing the stream associated with the socket.
+"
+ (unless socket
+ (error 'invalid-socket-error))
+ (unless stream
+ (error 'invalid-socket-stream-error))
+ (make-instance 'stream-usocket
+ :socket socket
+ :stream stream))
+
+(defun make-stream-server-socket (socket &key (element-type
+ #-lispworks 'character
+ #+lispworks 'base-char))
+ "Create a usocket-server socket type from an
+implementation-specific socket object.
+
+The returned value is a subtype of `stream-server-usocket'.
+"
+ (unless socket
+ (error 'invalid-socket-error))
+ (make-instance 'stream-server-usocket
+ :socket socket
+ :element-type element-type))
+
+(defun make-datagram-socket (socket &key connected-p)
+ (unless socket
+ (error 'invalid-socket-error))
+ (make-instance 'datagram-usocket
+ :socket socket
+ :connected-p connected-p))
+
+(defgeneric socket-accept (socket &key element-type)
+ (:documentation
+ "Accepts a connection from `socket', returning a `stream-socket'.
+
+The stream associated with the socket returned has `element-type' when
+explicitly specified, or the element-type passed to `socket-listen' otherwise."))
+
+(defgeneric socket-close (usocket)
+ (:documentation "Close a previously opened `usocket'."))
+
+;; also see http://stackoverflow.com/questions/4160347/close-vs-shutdown-socket
+(defgeneric socket-shutdown (usocket direction)
+ (:documentation "Shutdown communication on the socket in DIRECTION.
+
+After a shutdown no input and/or output of the indicated DIRECTION
+can be performed on the `usocket'.
+
+DIRECTION should be either :INPUT or :OUTPUT or :IO"))
+
+(defgeneric socket-send (usocket buffer length &key host port)
+ (:documentation "Send packets through a previously opend `usocket'."))
+
+(defgeneric socket-receive (usocket buffer length &key)
+ (:documentation "Receive packets from a previously opend `usocket'.
+
+Returns 4 values: (values buffer size host port)"))
+
+(defgeneric get-local-address (socket)
+ (:documentation "Returns the IP address of the socket."))
+
+(defgeneric get-peer-address (socket)
+ (:documentation
+ "Returns the IP address of the peer the socket is connected to."))
+
+(defgeneric get-local-port (socket)
+ (:documentation "Returns the IP port of the socket.
+
+This function applies to both `stream-usocket' and `server-stream-usocket'
+type objects."))
+
+(defgeneric get-peer-port (socket)
+ (:documentation "Returns the IP port of the peer the socket to."))
+
+(defgeneric get-local-name (socket)
+ (:documentation "Returns the IP address and port of the socket as values.
+
+This function applies to both `stream-usocket' and `server-stream-usocket'
+type objects."))
+
+(defgeneric get-peer-name (socket)
+ (:documentation
+ "Returns the IP address and port of the peer
+the socket is connected to as values."))
+
+(defmacro with-connected-socket ((var socket) &body body)
+ "Bind `socket' to `var', ensuring socket destruction on exit.
+
+`body' is only evaluated when `var' is bound to a non-null value.
+
+The `body' is an implied progn form."
+ `(let ((,var ,socket))
+ (unwind-protect
+ (when ,var
+ (with-mapped-conditions (,var)
+ ,@body))
+ (when ,var
+ (socket-close ,var)))))
+
+(defmacro with-client-socket ((socket-var stream-var &rest socket-connect-args)
+ &body body)
+ "Bind the socket resulting from a call to `socket-connect' with
+the arguments `socket-connect-args' to `socket-var' and if `stream-var' is
+non-nil, bind the associated socket stream to it."
+ `(with-connected-socket (,socket-var (socket-connect ,@socket-connect-args))
+ ,(if (null stream-var)
+ `(progn ,@body)
+ `(let ((,stream-var (socket-stream ,socket-var)))
+ ,@body))))
+
+(defmacro with-server-socket ((var server-socket) &body body)
+ "Bind `server-socket' to `var', ensuring socket destruction on exit.
+
+`body' is only evaluated when `var' is bound to a non-null value.
+
+The `body' is an implied progn form."
+ `(with-connected-socket (,var ,server-socket)
+ ,@body))
+
+(defmacro with-socket-listener ((socket-var &rest socket-listen-args)
+ &body body)
+ "Bind the socket resulting from a call to `socket-listen' with arguments
+`socket-listen-args' to `socket-var'."
+ `(with-server-socket (,socket-var (socket-listen ,@socket-listen-args))
+ ,@body))
+
+(defstruct (wait-list (:constructor %make-wait-list))
+ %wait ;; implementation specific
+ waiters ;; the list of all usockets
+ map) ;; maps implementation sockets to usockets
+
+;; Implementation specific:
+;;
+;; %setup-wait-list
+;; %add-waiter
+;; %remove-waiter
+
+(defun make-wait-list (waiters)
+ (let ((wl (%make-wait-list)))
+ (setf (wait-list-map wl) (make-hash-table))
+ (%setup-wait-list wl)
+ (dolist (x waiters wl)
+ (add-waiter wl x))))
+
+(defun add-waiter (wait-list input)
+ (setf (gethash (socket input) (wait-list-map wait-list)) input
+ (wait-list input) wait-list)
+ (pushnew input (wait-list-waiters wait-list))
+ (%add-waiter wait-list input))
+
+(defun remove-waiter (wait-list input)
+ (%remove-waiter wait-list input)
+ (setf (wait-list-waiters wait-list)
+ (remove input (wait-list-waiters wait-list))
+ (wait-list input) nil)
+ (remhash (socket input) (wait-list-map wait-list)))
+
+(defun remove-all-waiters (wait-list)
+ (dolist (waiter (wait-list-waiters wait-list))
+ (%remove-waiter wait-list waiter))
+ (setf (wait-list-waiters wait-list) nil)
+ (clrhash (wait-list-map wait-list)))
+
+(defun wait-for-input (socket-or-sockets &key timeout ready-only)
+ "Waits for one or more streams to become ready for reading from
+the socket. When `timeout' (a non-negative real number) is
+specified, wait `timeout' seconds, or wait indefinitely when
+it isn't specified. A `timeout' value of 0 (zero) means polling.
+
+Returns two values: the first value is the list of streams which
+are readable (or in case of server streams acceptable). NIL may
+be returned for this value either when waiting timed out or when
+it was interrupted (EINTR). The second value is a real number
+indicating the time remaining within the timeout period or NIL if
+none.
+
+Without the READY-ONLY arg, WAIT-FOR-INPUT will return all sockets in
+the original list you passed it. This prevents a new list from being
+consed up. Some users of USOCKET were reluctant to use it if it
+wouldn't behave that way, expecting it to cost significant performance
+to do the associated garbage collection.
+
+Without the READY-ONLY arg, you need to check the socket STATE slot for
+the values documented in usocket.lisp in the usocket class."
+
+ ;; for NULL sockets, return NIL with respect of TIMEOUT.
+ (when (null socket-or-sockets)
+ (when timeout
+ (sleep timeout))
+ (return-from wait-for-input nil))
+
+ (unless (wait-list-p socket-or-sockets)
+ (let ((wl (make-wait-list (if (listp socket-or-sockets)
+ socket-or-sockets (list socket-or-sockets)))))
+ (multiple-value-bind
+ (socks to)
+ (wait-for-input wl :timeout timeout :ready-only ready-only)
+ (return-from wait-for-input
+ (values (if ready-only socks socket-or-sockets) to)))))
+ (let* ((start (get-internal-real-time))
+ (sockets-ready 0))
+ (dolist (x (wait-list-waiters socket-or-sockets))
+ (when (setf (state x)
+ #+(and win32 (or sbcl ecl)) nil ; they cannot rely on LISTEN
+ #-(and win32 (or sbcl ecl))
+ (if (and (stream-usocket-p x)
+ (listen (socket-stream x)))
+ :read
+ nil))
+ (incf sockets-ready)))
+ ;; the internal routine is responsibe for
+ ;; making sure the wait doesn't block on socket-streams of
+ ;; which theready- socket isn't ready, but there's space left in the
+ ;; buffer
+ (wait-for-input-internal socket-or-sockets
+ :timeout (if (zerop sockets-ready) timeout 0))
+ (let ((to-result (when timeout
+ (let ((elapsed (/ (- (get-internal-real-time) start)
+ internal-time-units-per-second)))
+ (when (< elapsed timeout)
+ (- timeout elapsed))))))
+ (values (if ready-only
+ (remove-if #'null (wait-list-waiters socket-or-sockets) :key #'state)
+ socket-or-sockets)
+ to-result))))
+
+;;
+;; Data utility functions
+;;
+
+(defun integer-to-octet-buffer (integer buffer octets &key (start 0))
+ (do ((b start (1+ b))
+ (i (ash (1- octets) 3) ;; * 8
+ (- i 8)))
+ ((> 0 i) buffer)
+ (setf (aref buffer b)
+ (ldb (byte 8 i) integer))))
+
+(defun octet-buffer-to-integer (buffer octets &key (start 0))
+ (let ((integer 0))
+ (do ((b start (1+ b))
+ (i (ash (1- octets) 3) ;; * 8
+ (- i 8)))
+ ((> 0 i)
+ integer)
+ (setf (ldb (byte 8 i) integer)
+ (aref buffer b)))))
+
+(defmacro port-to-octet-buffer (port buffer &key (start 0))
+ `(integer-to-octet-buffer ,port ,buffer 2 :start ,start))
+
+(defmacro ip-to-octet-buffer (ip buffer &key (start 0))
+ `(integer-to-octet-buffer (host-byte-order ,ip) ,buffer 4 :start ,start))
+
+(defmacro port-from-octet-buffer (buffer &key (start 0))
+ `(octet-buffer-to-integer ,buffer 2 :start ,start))
+
+(defmacro ip-from-octet-buffer (buffer &key (start 0))
+ `(octet-buffer-to-integer ,buffer 4 :start ,start))
+
+;;
+;; IPv4 utility functions
+;;
+
+(defun list-of-strings-to-integers (list)
+ "Take a list of strings and return a new list of integers (from
+parse-integer) on each of the string elements."
+ (let ((new-list nil))
+ (dolist (element (reverse list))
+ (push (parse-integer element) new-list))
+ new-list))
+
+(defun ip-address-string-p (string)
+ "Return a true value if the given string could be an IP address."
+ (every (lambda (char)
+ (or (digit-char-p char)
+ (eql char #\.)))
+ string))
+
+(defun hbo-to-dotted-quad (integer)
+ "Host-byte-order integer to dotted-quad string conversion utility."
+ (let ((first (ldb (byte 8 24) integer))
+ (second (ldb (byte 8 16) integer))
+ (third (ldb (byte 8 8) integer))
+ (fourth (ldb (byte 8 0) integer)))
+ (format nil "~A.~A.~A.~A" first second third fourth)))
+
+(defun hbo-to-vector-quad (integer)
+ "Host-byte-order integer to dotted-quad string conversion utility."
+ (let ((first (ldb (byte 8 24) integer))
+ (second (ldb (byte 8 16) integer))
+ (third (ldb (byte 8 8) integer))
+ (fourth (ldb (byte 8 0) integer)))
+ (vector first second third fourth)))
+
+(defun vector-quad-to-dotted-quad (vector)
+ (format nil "~A.~A.~A.~A"
+ (aref vector 0)
+ (aref vector 1)
+ (aref vector 2)
+ (aref vector 3)))
+
+(defun dotted-quad-to-vector-quad (string)
+ (let ((list (list-of-strings-to-integers (split-sequence #\. string))))
+ (vector (first list) (second list) (third list) (fourth list))))
+
+(defgeneric host-byte-order (address))
+(defmethod host-byte-order ((string string))
+ "Convert a string, such as 192.168.1.1, to host-byte-order,
+such as 3232235777."
+ (let ((list (list-of-strings-to-integers (split-sequence #\. string))))
+ (+ (* (first list) 256 256 256) (* (second list) 256 256)
+ (* (third list) 256) (fourth list))))
+
+(defmethod host-byte-order ((vector vector))
+ "Convert a vector, such as #(192 168 1 1), to host-byte-order, such as
+3232235777."
+ (+ (* (aref vector 0) 256 256 256) (* (aref vector 1) 256 256)
+ (* (aref vector 2) 256) (aref vector 3)))
+
+(defmethod host-byte-order ((int integer))
+ int)
+
+;;
+;; IPv6 utility functions
+;;
+
+(defun vector-to-ipv6-host (vector)
+ (with-output-to-string (*standard-output*)
+ (loop with zeros-collapsed-p
+ with collapsing-zeros-p
+ for i below 16 by 2
+ for word = (+ (ash (aref vector i) 8)
+ (aref vector (1+ i)))
+ do (cond
+ ((and (zerop word)
+ (not collapsing-zeros-p)
+ (not zeros-collapsed-p))
+ (setf collapsing-zeros-p t))
+ ((or (not (zerop word))
+ zeros-collapsed-p)
+ (when collapsing-zeros-p
+ (write-string ":")
+ (setf collapsing-zeros-p nil
+ zeros-collapsed-p t))
+ (format t "~:[~;:~]~X" (plusp i) word)))
+ finally (when collapsing-zeros-p
+ (write-string "::")))))
+
+(defun split-ipv6-address (string)
+ (let ((pos 0)
+ word
+ double-colon-seen-p
+ words-before-double-colon
+ words-after-double-colon)
+ (loop
+ (multiple-value-setq (word pos) (parse-integer string :radix 16 :junk-allowed t :start pos))
+ (labels ((at-end-p ()
+ (= pos (length string)))
+ (looking-at-colon-p ()
+ (char= (char string pos) #\:))
+ (ensure-colon ()
+ (unless (looking-at-colon-p)
+ (error "unsyntactic IPv6 address string ~S, expected a colon at position ~D"
+ string pos))
+ (incf pos)))
+ (cond
+ ((null word)
+ (when double-colon-seen-p
+ (error "unsyntactic IPv6 address string ~S, can only have one double-colon filler mark"
+ string))
+ (setf double-colon-seen-p t))
+ (double-colon-seen-p
+ (push word words-after-double-colon))
+ (t
+ (push word words-before-double-colon)))
+ (if (at-end-p)
+ (return (list (nreverse words-before-double-colon) (nreverse words-after-double-colon)))
+ (ensure-colon))))))
+
+(defun ipv6-host-to-vector (string)
+ (assert (> (length string) 2) ()
+ "Unsyntactic IPv6 address literal ~S, expected at least three characters" string)
+ (destructuring-bind (words-before-double-colon words-after-double-colon)
+ (split-ipv6-address (concatenate 'string
+ (when (eql (char string 0) #\:)
+ "0")
+ string
+ (when (eql (char string (1- (length string))) #\:)
+ "0")))
+ (let ((number-of-words-specified (+ (length words-before-double-colon) (length words-after-double-colon))))
+ (assert (<= number-of-words-specified 8) ()
+ "Unsyntactic IPv6 address literal ~S, too many colon separated address components" string)
+ (assert (or (= number-of-words-specified 8) words-after-double-colon) ()
+ "Unsyntactic IPv6 address literal ~S, too few address components and no double-colon filler found" string)
+ (loop with vector = (make-array 16 :element-type '(unsigned-byte 8))
+ for i below 16 by 2
+ for word in (append words-before-double-colon
+ (make-list (- 8 number-of-words-specified) :initial-element 0)
+ words-after-double-colon)
+ do (setf (aref vector i) (ldb (byte 8 8) word)
+ (aref vector (1+ i)) (ldb (byte 8 0) word))
+ finally (return vector)))))
+
+(defun host-to-hostname (host)
+ "Translate a string, vector quad or 16 byte IPv6 address to a
+stringified hostname."
+ (etypecase host
+ (string host)
+ ((or (vector t 4)
+ (array (unsigned-byte 8) (4)))
+ (vector-quad-to-dotted-quad host))
+ ((or (vector t 16)
+ (array (unsigned-byte 8) (16)))
+ (vector-to-ipv6-host host))
+ (integer (hbo-to-dotted-quad host))
+ (null "0.0.0.0")))
+
+(defun ip= (ip1 ip2)
+ (etypecase ip1
+ (string (string= ip1 (host-to-hostname ip2)))
+ ((or (vector t 4)
+ (array (unsigned-byte 8) (4))
+ (vector t 16)
+ (array (unsigned-byte 8) (16)))
+ (equalp ip1 ip2))
+ (integer (= ip1 (host-byte-order ip2)))))
+
+(defun ip/= (ip1 ip2)
+ (not (ip= ip1 ip2)))
+
+;;
+;; DNS helper functions
+;;
+
+(defun get-host-by-name (name)
+ (let ((hosts (get-hosts-by-name name)))
+ (car hosts)))
+
+(defun get-random-host-by-name (name)
+ (let ((hosts (get-hosts-by-name name)))
+ (when hosts
+ (elt hosts (random (length hosts))))))
+
+(defun host-to-vector-quad (host)
+ "Translate a host specification (vector quad, dotted quad or domain name)
+to a vector quad."
+ (etypecase host
+ (string (let* ((ip (when (ip-address-string-p host)
+ (dotted-quad-to-vector-quad host))))
+ (if (and ip (= 4 (length ip)))
+ ;; valid IP dotted quad?
+ ip
+ (get-random-host-by-name host))))
+ ((or (vector t 4)
+ (array (unsigned-byte 8) (4)))
+ host)
+ (integer (hbo-to-vector-quad host))))
+
+(defun host-to-hbo (host)
+ (etypecase host
+ (string (let ((ip (when (ip-address-string-p host)
+ (dotted-quad-to-vector-quad host))))
+ (if (and ip (= 4 (length ip)))
+ (host-byte-order ip)
+ (host-to-hbo (get-host-by-name host)))))
+ ((or (vector t 4)
+ (array (unsigned-byte 8) (4)))
+ (host-byte-order host))
+ (integer host)))
+
+;;
+;; Other utility functions
+;;
+
+(defun split-timeout (timeout &optional (fractional 1000000))
+ "Split real value timeout into seconds and microseconds.
+Optionally, a different fractional part can be specified."
+ (multiple-value-bind
+ (secs sec-frac)
+ (truncate timeout 1)
+ (values secs
+ (truncate (* fractional sec-frac) 1))))
+
+;;
+;; Setting of documentation for backend defined functions
+;;
+
+;; Documentation for the function
+;;
+;; (defun SOCKET-CONNECT (host port &key element-type nodelay some-other-keys...) ..)
+;;
+(setf (documentation 'socket-connect 'function)
+ "Connect to `host' on `port'. `host' is assumed to be a string or
+an IP address represented in vector notation, such as #(192 168 1 1).
+`port' is assumed to be an integer.
+
+`element-type' specifies the element type to use when constructing the
+stream associated with the socket. The default is 'character.
+
+`nodelay' Allows to disable/enable Nagle's algorithm (http://en.wikipedia.org/wiki/Nagle%27s_algorithm).
+If this parameter is omitted, the behaviour is inherited from the
+CL implementation (in most cases, Nagle's algorithm is
+enabled by default, but for example in ACL it is disabled).
+If the parmeter is specified, one of these three values is possible:
+ T - Disable Nagle's algorithm; signals an UNSUPPORTED
+ condition if the implementation does not support explicit
+ manipulation with that option.
+ NIL - Leave Nagle's algorithm enabled on the socket;
+ signals an UNSUPPORTED condition if the implementation does
+ not support explicit manipulation with that option.
+ :IF-SUPPORTED - Disables Nagle's algorithm if the implementation
+ allows this, otherwises just ignore this option.
+
+Returns a usocket object.")
+
+;; Documentation for the function
+;;
+;; (defun SOCKET-LISTEN (host port &key reuseaddress backlog element-type) ..)
+;;###FIXME: extend with default-element-type
+(setf (documentation 'socket-listen 'function)
+ "Bind to interface `host' on `port'. `host' should be the
+representation of an ready-interface address. The implementation is
+not required to do an address lookup, making no guarantees that
+hostnames will be correctly resolved. If `*wildcard-host*' or NIL is
+passed for `host', the socket will be bound to all available
+interfaces for the system. `port' can be selected by the IP stack by
+passing `*auto-port*'.
+
+Returns an object of type `stream-server-usocket'.
+
+`reuse-address' and `backlog' are advisory parameters for setting socket
+options at creation time. `element-type' is the element type of the
+streams to be created by `socket-accept'. `reuseaddress' is supported for
+backward compatibility (but deprecated); when both `reuseaddress' and
+`reuse-address' have been specified, the latter takes precedence.
+")
+
+;;; Small utility functions mapping true/false to 1/0, moved here from option.lisp
+
+(proclaim '(inline bool->int int->bool))
+
+(defun bool->int (bool) (if bool 1 0))
+(defun int->bool (int) (= 1 int))
--- /dev/null
+;;;-*-Mode: LISP; Package: CCL -*-
+;;
+;;; OpenTransportUDP.lisp
+;;; Copyright 2012 Chun Tian (binghe) <binghe.lisp@gmail.com>
+
+;;; UDP extension to OpenTransport.lisp (with some TCP patches)
+
+(in-package "CCL")
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (require :opentransport))
+
+;; MCL Issue 28: Passive TCP streams should be able to listen to the loopback interface
+;; see http://code.google.com/p/mcl/issues/detail?id=28 for details
+
+(defparameter *passive-interface-address* NIL
+ "Address to use for passive connections - optionally bind to loopback address while opening a tcp stream")
+
+(advise local-interface-ip-address
+ (or *passive-interface-address* (:do-it))
+ :when :around :name 'override-local-interface-ip-address)
+
+;; MCL Issue 29: Passive TCP connections on OS assigned ports
+;; see http://code.google.com/p/mcl/issues/detail?id=29 for details
+(advise ot-conn-tcp-passive-connect
+ (destructuring-bind (conn port &optional (allow-reuse t)) arglist
+ (declare (ignore allow-reuse))
+ (if (eql port #$kOTAnyInetAddress)
+ ;; Avoids registering a proxy for port 0 but instead registers one for the true port:
+ (multiple-value-bind (proxy result)
+ (let* ((*opentransport-class-proxies* NIL) ; makes ot-find-proxy return NIL
+ (result (:do-it)) ;; pushes onto *opentransport-class-proxies*
+ (proxy (prog1
+ (pop *opentransport-class-proxies*)
+ (assert (not *opentransport-class-proxies*))))
+ (context (cdr proxy))
+ (tmpconn (make-ot-conn :context context
+ :endpoint (pref context :ot-context.ref)))
+ (localaddress (ot-conn-tcp-get-addresses tmpconn)))
+ (declare (dynamic-extent tmpconn))
+ ;; replace original set in body of function
+ (setf (ot-conn-local-address conn) localaddress)
+ (values
+ (cons localaddress context)
+ result))
+ ;; need to be outside local binding of *opentransport-class-proxies*
+ (without-interrupts
+ (push proxy *opentransport-class-proxies*))
+ result)
+ (:do-it)))
+ :when :around :name 'ot-conn-tcp-passive-connect-any-address)
+
+(defun open-udp-socket (&key local-address local-port)
+ (init-opentransport)
+ (let (endpoint ; TODO: opentransport-alloc-endpoint-from-freelist
+ (err #$kOTNoError)
+ (configptr (ot-cloned-configuration traps::$kUDPName)))
+ (rlet ((errP :osstatus))
+ (setq endpoint #+carbon-compat (#_OTOpenEndpointInContext configptr 0 (%null-ptr) errP *null-ptr*)
+ #-carbon-compat (#_OTOpenEndpoint configptr 0 (%null-ptr) errP)
+ err (pref errP :osstatus))
+ (if (eql err #$kOTNoError)
+ (let* ((context (ot-make-endpoint-context endpoint nil nil)) ; no notifier, not minimal
+ (conn (make-ot-conn :context context :endpoint endpoint)))
+ (macrolet ((check-ot-error-return (error-context)
+ `(unless (eql (setq err (pref errP :osstatus)) #$kOTNoError)
+ (values (ot-error err ,error-context)))))
+ (setf (ot-conn-bindreq conn)
+ #-carbon-compat (#_OTAlloc endpoint #$T_BIND #$T_ADDR errP)
+ #+carbon-compat (#_OTAllocInContext endpoint #$T_BIND #$T_ADDR errP *null-ptr*)
+ )
+ (check-ot-error-return :alloc)
+ (setf (ot-conn-bindret conn)
+ #-carbon-compat (#_OTAlloc endpoint #$T_BIND #$T_ADDR errP)
+ #+carbon-compat (#_OTAllocInContext endpoint #$T_BIND #$T_ADDR errP *null-ptr*)
+ )
+ (check-ot-error-return :alloc)
+ (setf (ot-conn-options conn)
+ #-carbon-compat (#_OTAlloc endpoint #$T_OPTMGMT #$T_OPT errP)
+ #+carbon-compat (#_OTAllocInContext endpoint #$T_OPTMGMT #$T_OPT errP *null-ptr*)
+ )
+ (check-ot-error-return :alloc))
+ ;; BIND to local address (for UDP server)
+ (when local-port ; local-address
+ (let* ((host (or local-address (local-interface-ip-address)))
+ (port (tcp-service-port-number local-port))
+ (localaddress `(:tcp ,host ,port))
+ (bindreq (ot-conn-bindreq conn))
+ (bindret (ot-conn-bindret conn)))
+ (let* ((netbuf (pref bindreq :tbind.addr)))
+ (declare (dynamic-extent netbuf))
+ (setf (pref netbuf :tnetbuf.len) (record-length :inetaddress)
+ (pref bindreq :tbind.qlen) 5) ; arbitrary qlen
+ (#_OTInitInetAddress (pref netbuf :tnetbuf.buf) port host)
+ (setf (pref context :ot-context.completed) nil)
+ (unless (= (setq err (#_OTBind endpoint bindreq bindret)) #$kOTNoError)
+ (ot-error err :bind)))
+ (setf (ot-conn-local-address conn) localaddress)))
+ conn)
+ (ot-error err :create)))))
+
+(defun make-TUnitData (endpoint)
+ "create the send/recv buffer for UDP sockets"
+ (let ((err #$kOTNoError))
+ (rlet ((errP :osstatus))
+ (macrolet ((check-ot-error-return (error-context)
+ `(unless (eql (setq err (pref errP :osstatus)) #$kOTNoError)
+ (values (ot-error err ,error-context)))))
+ (let ((udata #-carbon-compat (#_OTAlloc endpoint #$T_UNITDATA #$T_ALL errP)
+ #+carbon-compat (#_OTAllocInContext endpoint #$T_UNITDATA #$T_ALL errP *null-ptr*)))
+ (check-ot-error-return :alloc)
+ udata)))))
+
+(defun send-message (conn data buffer size host port &optional (offset 0))
+ ;; prepare dest address
+ (let ((addr (pref data :tunitdata.addr)))
+ (declare (dynamic-extent addr))
+ (setf (pref addr :tnetbuf.len) (record-length :inetaddress))
+ (#_OTInitInetAddress (pref addr :tnetbuf.buf) port host))
+ ;; prepare data buffer
+ (let* ((udata (pref data :tunitdata.udata))
+ (outptr (pref udata :tnetbuf.buf)))
+ (declare (dynamic-extent udata))
+ (%copy-ivector-to-ptr buffer offset outptr 0 size)
+ (setf (pref udata :tnetbuf.len) size))
+ ;; send the packet
+ (let* ((endpoint (ot-conn-endpoint conn))
+ (result (#_OTSndUData endpoint data)))
+ (the fixnum result)))
+
+(defun receive-message (conn data buffer length)
+ (let* ((endpoint (ot-conn-endpoint conn))
+ (err (#_OTRcvUData endpoint data *null-ptr*)))
+ (if (eql err #$kOTNoError)
+ (let* (;(addr (pref data :tunitdata.addr))
+ (udata (pref data :tunitdata.udata))
+ (inptr (pref udata :tnetbuf.buf))
+ (read-bytes (pref udata :tnetbuf.len))
+ (buffer (or buffer (make-array read-bytes :element-type '(unsigned-byte 8))))
+ (length (or length (length buffer)))
+ (actual-size (min read-bytes length)))
+ (%copy-ptr-to-ivector inptr 0 buffer 0 actual-size)
+ (values buffer
+ actual-size
+ 0 0)) ; TODO: retrieve address and port
+ (ot-error err :receive)))) ; TODO: use OTRcvUDErr instead
--- /dev/null
+;;;-*-Mode: LISP; Package: CCL -*-\r;;\r;; KQUEUE.LISP\r;;\r;; KQUEUE - BSD kernel event notification mechanism support for Common LISP.\r;; Copyright (C) 2007 Terje Norderhaug <terje@in-progress.com>\r;; Released under LGPL - see <http://www.gnu.org>.\r;; Alternative licensing available upon request.\r;; \r;; DISCLAIMER: The user of this module should understand that executing code is a potentially hazardous \r;; activity, and that many dangers and obstacles, marked or unmarked, may exist within this code.\r;; As a condition of your use of the module, you assume all risk of personal injury, death, or property\r;; loss, and all other bad things that may happen, even if caused by negligence, ignorance or stupidity.\r;; The author is is no way responsible, and besides, does not have "deep pockets" nor any spare change.\r;;\r;; Version: 0.20 alpha (July 26, 2009) - subject to major revisions, so consider yourself warned.\r;; Tested with Macintosh Common LISP 5.1 and 5.2, but is intended to be platform and system independent in the future.\r;;\r;; Email feedback and improvements to <terje@in-progress.com>.\r;; Updated versions will be available from <http://www.in-progress.com/src/>.\r;;\r;; RELATED IMPLEMENTATIONS\r;; There is another kevent.lisp for other platforms by Risto Laakso (merge?).\r;; Also a Scheme kevent.ss by Jose Antonio Ortega.\r;;\r;; SEE ALSO:\r;; http://people.freebsd.org/~jlemon/papers/kqueue.pdf\r;; http://developer.apple.com/samplecode/FileNotification/index.html\r;; The Man page for kqueue() or kevent().\r;; PyKQueue - Python OO interface to KQueue.\r;; LibEvent - an event notification library in C by Niels Provos.\r;; Liboop - another abstract library in C on top of kevent or other kernel notification.\r\r#| HISTORY:\r\r2007-Oct-18 terje version 0.1 released on the Info-MCL mailing list.\r2008-Aug-21 terje load-framework-bundle is not needed under MCL 5.2\r2008-Aug-21 terje rename get-addr to lookup-function-in-bundle (only for pre MCL 5.2)\r2009-Jul-19 terje uses kevent-error condition and strerror.\r2009-Jul-24 terje reports errors unless nil-if-not-found in lookup-function-in-bundle. \r2009-Jul-24 terje kevent :variant for C's intptr_t type for 64bit (and osx 10.5) compatibility.\r2009-Jul-25 terje 64bit support, dynamically determined for PPC. Kudos to Glen Foy for helping out.\r2009-Jul-25 terje make-kevent function.\r|#\r\r#| IMPLEMENTATION NOTES:\r\rkevents are copied into and from the kernel, so the records don't have to be kept in the app!\rkevents does not work in OSX before 10.3.\r*kevent-record* has to be explcitly set to :kevent64 to work on 64bit intel macs.\rConsider using sysctlbyname() to test for 64bit, \r combining hw.cpu64bit_capable, hw.optional.x86_64 and hw.optional.64bitops\r|#\r\r(in-package :ccl)\r\r;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\r\r#-ccl-5.2 ; has been added to MCL 5.2\r(defmethod load-framework-bundle ((framework-name string) &key (load-executable t))\r ;; FRAMWORK CALL FUNCTIONALITY FROM BSD.LISP\r ;; (C) 2003 Brendan Burns <bburns@cs.umass.edu>\r ;; Released under LGPL.\r (with-cfstrs ((framework framework-name))\r (let ((err 0)\r (baseURL nil)\r (bundleURL nil)\r (result nil))\r (rlet ((folder :fsref))\r ;; Find the folder holding the bundle\r (setf err (#_FSFindFolder #$kOnAppropriateDisk #$kFrameworksFolderType \r t folder))\r \r ;; if everything's cool, make a URL for it\r (when (zerop err)\r (setf baseURL (#_CFURLCreateFromFSRef (%null-ptr) folder))\r (if (%null-ptr-p baseURL) \r (setf err #$coreFoundationUnknownErr)))\r \r ;; if everything's cool, make a URL for the bundle\r (when (zerop err)\r (setf bundleURL (#_CFURLCreateCopyAppendingPathComponent (%null-ptr) \r baseURL framework nil))\r (if (%null-ptr-p bundleURL) \r (setf err #$coreFoundationUnknownErr)))\r \r ;; if everything's cool, load it\r (when (zerop err)\r (setf result (#_CFBundleCreate (%null-ptr) bundleURL))\r (if (%null-ptr-p result)\r (setf err #$coreFoundationUnknownErr)))\r \r ;; if everything's cool, and the user wants it loaded, load it\r (when (and load-executable (zerop err))\r (if (not (#_CFBundleLoadExecutable result))\r (setf err #$coreFoundationUnknownErr)))\r \r ;; if there's an error, but we've got a pointer, free it and clear result\r (when (and (not (zerop err)) (not (%null-ptr-p result)))\r (#_CFRelease result)\r (setf result nil))\r \r ;; free the URLs if there non-null\r (when (not (%null-ptr-p bundleURL))\r (#_CFRelease bundleURL))\r (when (not (%null-ptr-p baseURL))\r (#_CFRelease baseURL))\r \r ;; return pointer + error value\r (values result err)))))\r\r#+ignore\r(defun get-addr (bundle name)\r (let* ((addr (#_CFBundleGetFunctionPointerForName bundle name)))\r (rlet ((buf :long))\r (setf (%get-ptr buf) addr)\r (ash (%get-signed-long buf) -2))))\r\r#-ccl-5.2\r(defun lookup-function-in-bundle (name bundle &optional nil-if-not-found)\r (with-cfstrs ((str name))\r (let* ((addr (#_CFBundleGetFunctionPointerForName bundle str)))\r (if (%null-ptr-p addr)\r (unless nil-if-not-found\r (error "Couldn't resolve address of foreign function ~s" name))\r (rlet ((buf :long)) ;; mcl 5.2 uses %fixnum-from-macptr here\r (setf (%get-ptr buf) addr)\r (ash (%get-signed-long buf) -2))))))\r\r;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\r;; Convenient way to declare BSD system calls\r\r#+ignore\r(defparameter *system-bundle*\r #+ccl-5.2 (get-bundle-for-framework-name "System.framework")\r #-ccl-5.2\r (let ((bundle (load-framework-bundle "System.framework")))\r (terminate-when-unreachable bundle (lambda (b)(#_CFRelease b)))\r bundle))\r\r(defmacro declare-bundle-ff (name name-string &rest arglist &aux (fn (gensym (format nil "ff_~A_" (string name)))))\r ;; Is there an existing define-trap like macro for this? or could one be modified for use with bundles?\r `(progn\r (defloadvar ,fn\r (let* ((bundle #+ccl-5.2 (get-bundle-for-framework-name "System.framework")\r #-ccl-5.2\r (let ((bundle (load-framework-bundle "System.framework")))\r (terminate-when-unreachable bundle (lambda (b)(#_CFRelease b)))\r bundle)))\r (lookup-function-in-bundle ,name-string bundle)))\r ,(let ((args (do ((arglist arglist (cddr arglist))\r (result))\r ((not (cdr arglist)) (nreverse result))\r (push (second arglist) result)))) \r `(defun ,name ,args\r (ppc-ff-call ,fn ,@arglist)))))\r\r;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\r\r(declare-bundle-ff %system-kqueue "kqueue" \r :signed-fullword) ;; returns a file descriptor no!\r\r(defun system-kqueue ()\r (let ((kq (%system-kqueue)))\r (if (= kq -1)\r (ecase (%system-errno)\r (12 (error "The kernel failed to allocate enough memory for the kernel queue")) ; ENOMEM\r (24 (error "The per-process descriptor table is full")) ; EMFILE\r (23 (error "The system file table is full"))) ; ENFILE \r kq)))\r\r(declare-bundle-ff %system-kevent "kevent"\r :unsigned-fullword kq\r :address ke\r :unsigned-fullword nke\r :address ko\r :unsigned-fullword nko\r :address timeout\r :signed-fullword)\r\r(declare-bundle-ff %system-open "open" \r :address name \r :unsigned-fullword mode\r :unsigned-fullword arg \r :signed-fullword)\r \r(declare-bundle-ff %system-close "close"\r :unsigned-fullword fd \r :signed-fullword)\r\r(declare-bundle-ff %system-errno* "__error" \r :signed-fullword)\r\r(declare-bundle-ff %system-strerror "strerror" \r :signed-fullword errno\r :address)\r\r(defun %system-errno ()\r (%get-fixnum (%int-to-ptr (%system-errno*))))\r\r; (%system-errno)\r\r(defconstant $O-EVTONLY #x8000)\r; (defconstant $O-NONBLOCK #x800 "Non blocking mode")\r\r(defun system-open (posix-namestring)\r "Low level open function, as in C, returns an fd number"\r (with-cstrs ((name posix-namestring))\r (%system-open name $O-EVTONLY 0)))\r\r(defun system-close (fd)\r (%system-close fd))\r\r(defrecord timespec\r (sec :unsigned-long)\r (usec :unsigned-long))\r\r(defVar *kevent-record* nil)\r\r(def-ccl-pointers determine-64bit-kevents ()\r (setf *kevent-record*\r (if (ccl::gestalt #$gestaltPowerPCProcessorFeatures\r #+ccl-5.2 #$gestaltPowerPCHas64BitSupport #-ccl-5.2 6)\r :kevent32\r :kevent64)))\r\r(defrecord :kevent32\r (ident :unsigned-long) ; uintptr_t\r (filter :short)\r (flags :unsigned-short)\r (fflags :unsigned-long)\r (data :long) ; intptr_t\r (udata :pointer))\r\r(defrecord :kevent64\r (:variant ; uintptr_t\r ((ident64 :uint64))\r ((ident :unsigned-long)))\r (filter :short)\r (flags :unsigned-short)\r (fflags :unsigned-long)\r (:variant ; intptr_t\r ((data64 :sint64))\r ((data :long)))\r (:variant ; RMCL :pointer is 32bit\r ((udata64 :uint64))\r ((udata :pointer))))\r\r(defun make-kevent (&key (ident 0) (filter 0) (flags 0) (fflags 0) (data 0) (udata *null-ptr*))\r (ecase *kevent-record*\r (:kevent64 \r (make-record kevent64\r :ident ident\r :filter filter \r :flags flags\r :fflags fflags\r :data data \r :udata udata))\r (:kevent32\r (make-record kevent32\r :ident ident\r :filter filter \r :flags flags\r :fflags fflags\r :data data \r :udata udata))))\r\r(defun kevent-rref (ke field)\r (ecase *kevent-record*\r (:kevent32\r (ecase field\r (:ident (rref ke :kevent32.ident))\r (:filter (rref ke :kevent32.filter))\r (:flags (rref ke :kevent32.flags))\r (:fflags (rref ke :kevent32.fflags))\r (:data (rref ke :kevent32.data))\r (:udata (rref ke :kevent32.udata))))\r (:kevent64\r (ecase field\r (:ident (rref ke :kevent64.ident))\r (:filter (rref ke :kevent64.filter))\r (:flags (rref ke :kevent64.flags))\r (:fflags (rref ke :kevent64.fflags))\r (:data (rref ke :kevent64.data))\r (:udata (rref ke :kevent64.udata))))))\r\r(defun kevent-filter (ke)\r (kevent-rref ke :filter))\r\r(defun kevent-flags (ke)\r (kevent-rref ke :flags))\r\r(defun kevent-data (ke)\r (kevent-rref ke :data))\r\r\r;; FILTER TYPES:\r\r(eval-when (:compile-toplevel :load-toplevel :execute) ; added by binghe\r\r(defconstant $kevent-read-filter -1 "Data available to read")\r(defconstant $kevent-write-filter -2 "Writing is possible")\r(defconstant $kevent-aio-filter -3 "AIO system call has been made")\r(defconstant $kevent-vnode-filter -4 "Event occured on a file descriptor")\r(defconstant $kevent-proc-filter -5 "Process performed one or more of the requested events")\r(defconstant $kevent-signal-filter -6 "Attempted to deliver a signal to a process")\r(defconstant $kevent-timer-filter -7 "Establishes an arbitrary timer")\r(defconstant $kevent-netdev-filter -8 "Event occured on a network device")\r(defconstant $kevent-filesystem-filter -9)\r\r) ; eval-when\r\r; FLAGS:\r\r(defconstant $kevent-add #x01)\r(defconstant $kevent-delete #x02)\r(defconstant $kevent-enable #x04)\r(defconstant $kevent-disable #x08)\r(defconstant $kevent-oneshot #x10)\r(defconstant $kevent-clear #x20)\r(defconstant $kevent-error #x4000)\r(defconstant $kevent-eof #x8000 "EV_EOF")\r\r;; FFLAGS:\r\r(defconstant $kevent-file-delete #x01 "The file was unlinked from the file system")\r(defconstant $kevent-file-write #x02 "A write occurred on the file")\r(defconstant $kevent-file-extend #x04 "The file was extended")\r(defconstant $kevent-file-attrib #x08 "The file had its attributes changed")\r(defconstant $kevent-file-link #x10 "The link count on the file changed")\r(defconstant $kevent-file-rename #x20 "The file was renamed")\r(defconstant $kevent-file-revoke #x40 "Access to the file was revoked or the file system was unmounted")\r(defconstant $kevent-file-all (logior $kevent-file-delete $kevent-file-write $kevent-file-extend\r $kevent-file-attrib $kevent-file-link $kevent-file-rename $kevent-file-revoke))\r\r\r(defconstant $kevent-net-linkup #x01 "Link is up")\r(defconstant $kevent-net-linkdown #x02 "Link is down")\r(defconstant $kevent-net-linkinvalid #x04 "Link state is invalid")\r(defconstant $kevent-net-added #x08 "IP adress added")\r(defconstant $kevent-net-deleted #x10 "IP adress deleted")\r\r(define-condition kevent-error (simple-error)\r ((errno :initform NIL :initarg :errno)\r (ko :initform nil :type (or null kevent) :initarg :ko)\r (syserr :initform (%system-errno)))\r (:report \r (lambda (c s)\r (with-slots (errno ko syserr) c\r (format s "kevent system call error ~A [~A]" errno syserr) \r (when errno \r (format s "(~A)" (%get-cstring (%system-strerror errno))))\r (when ko\r (format s " for ")\r (let ((*standard-output* s))\r (print-record ko *kevent-record*)))))))\r\r(defun %kevent (kq &optional ke ko (timeout 0))\r (check-type kq integer)\r (rlet ((&timeout :timespec :sec timeout :usec 1))\r (let ((num (with-timer ;; does not seem to make a difference... \r (%system-kevent kq (or ke (%null-ptr))(if ke 1 0)(or ko (%null-ptr))(if ko 1 0) &timeout))))\r ; "If an error occurs while processing an element of the changelist and there \r ; is enough room in the eventlist, then the event will be placed in the eventlist with \r ; EV_ERROR set in flags and the system error in data."\r (when (and ko (plusp (logand $kevent-error (kevent-flags ko))))\r (error 'kevent-error \r :errno (kevent-data ko)\r :ko ko))\r ; "Otherwise, -1 will be returned, and errno will be set to indicate the error condition."\r (when (= num -1)\r ;; hack - opentransport provides the constants for the errors documented for the call \r (case (%system-errno)\r (0 (error "kevent system call failed with an unspecified error")) ;; should not happen!\r (13 (error "The process does not have permission to register a filter")) \r (14 (error "There was an error reading or writing the kevent structure")) ; EFAULT\r (9 (error "The specified descriptor is invalid")) ; EBADF\r (4 (error "A signal was delivered before the timeout expired and before any events were placed on the kqueue for return.")) ; EINTR\r (22 (error "The specified time limit or filter is invalid")) ; EINVAL\r (2 (error "The event could not be found to be modified or deleted")) ; ENOENT\r (12 (error "No memory was available to register the event")) ; ENOMEM\r (78 (error "The specified process to attach to does not exist"))) ; ESRCH\r ;; shouldn't get here... \r (errchk (%system-errno))\r (error "error ~A" (%system-errno)))\r (unless (zerop num)\r (values ko num)))))\r\r;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\r;; CLOS INTERFACE\r\r(defclass kqueue ()\r ((kq :initform (system-kqueue) \r :documentation "file descriptor referencing the kqueue")\r (fds :initform NIL)) ;; ## better if kept on top level, perhaps as a hash table...\r (:documentation "A kernal event notification channel"))\r\r(defmethod initialize-instance :after ((q kqueue) &rest rest)\r (declare (ignore rest))\r (terminate-when-unreachable q 'kqueue-close))\r\r(defmethod kqueue-close ((q kqueue))\r (with-slots (kq fds) q\r (when (or kq fds) ;; allow repeated close\r (system-close kq)\r (setf fds NIL)\r (setf kq NIL))))\r\r(defmethod kqueue-poll ((q kqueue))\r "Polls a kqueue for kevents"\r ;; may not have to be cleared, but just in case:\r (flet ((kqueue-poll2 (ko)\r (let ((result (with-slots (kq) q\r (without-interrupts \r (%kevent kq NIL ko)))))\r (when result\r (let ((type (kevent-filter result)))\r (ecase type\r (0 (values))\r (#.$kevent-read-filter\r (values\r :read\r (kevent-rref result :ident)\r (kevent-rref result :flags)\r (kevent-rref result :fflags)\r (kevent-rref result :data)\r (kevent-rref result :udata)))\r (#.$kevent-write-filter :write)\r (#.$kevent-aio-filter :aio)\r (#.$kevent-vnode-filter\r (values\r :vnode\r (cdr (assoc (kevent-rref result :ident) (slot-value q 'fds)))\r (kevent-rref result :flags)\r (kevent-rref result :fflags)\r (kevent-rref result :data)\r (kevent-rref result :udata)))\r (#.$kevent-filesystem-filter :filesystem)))))))\r (ecase *kevent-record*\r (:kevent64\r (rlet ((ko :kevent64 :ident 0 :filter 0 :flags 0 :fflags 0 :data 0 :udata (%null-ptr)))\r (kqueue-poll2 ko)))\r (:kevent32\r (rlet ((ko :kevent32 :ident 0 :filter 0 :flags 0 :fflags 0 :data 0 :udata (%null-ptr)))\r (kqueue-poll2 ko))))))\r\r(defmethod kqueue-subscribe ((q kqueue) &key ident filter (flags 0) (fflags 0) (data 0) (udata (%null-ptr)))\r (let ((ke (make-kevent :ident ident\r :filter filter \r :flags flags\r :fflags fflags\r :data data \r :udata udata)))\r (with-slots (kq) q\r (without-interrupts\r (%kevent kq ke)))))\r\r(defmethod kqueue-vnode-subscribe ((q kqueue) pathname)\r "Makes the queue report an event when there is a change to a directory or file" \r (let* ((namestring (posix-namestring (full-pathname pathname)))\r (fd (system-open namestring)))\r (with-slots (fds) q\r (push (cons fd pathname) fds))\r (kqueue-subscribe q \r :ident fd \r :filter $kevent-vnode-filter \r :flags (logior $kevent-add $kevent-clear) \r :fflags $kevent-file-all)\r namestring))\r\r;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\r\r#+test\r(defun kevent-d (pathname &optional (*standard-output* (fred)))\r "Report changes to a file or directory"\r (loop\r with kqueue = (make-instance 'kqueue)\r with sub = (kqueue-vnode-subscribe kqueue pathname) \r for i from 1 to 60\r for result = (multiple-value-list (kqueue-poll kqueue))\r unless (equal result '(NIL))\r do (progn\r (format T "~A~%" result)\r (force-output))\r ; do (process-allow-schedule)\r do (sleep 1)\r finally (write-line "Done")\r ))\r\r#|\r\r; Report changes to this file in a fred window (save this document to see what happens):\r\r(process-run-function "kevent-d" #'kevent-d *loading-file-source-file*\r (fred))\r\r; Reports files added or removed from the directory of this file:\r\r(process-run-function "kevent-d" #'kevent-d \r (make-pathname :directory (pathname-directory *loading-file-source-file*))\r (fred))\r|#\r\r\r\r\r
\ No newline at end of file
projects / thetarpit.git / commitdiff
