From 8e8d18e4cfec36a8169557d14c554085f8dc6f60 Mon Sep 17 00:00:00 2001 From: Lucian Mogosanu Date: Thu, 15 Aug 2019 14:14:01 +0300 Subject: [PATCH] Import Hunchentoot wholesale Yes, the whole orchestra is fucking huge. Not my fault. --- blog.lisp | 15 +- deps/alexandria/.boring | 13 + deps/alexandria/.gitignore | 4 + deps/alexandria/AUTHORS | 9 + deps/alexandria/LICENCE | 37 + deps/alexandria/README | 52 + deps/alexandria/alexandria-tests.asd | 12 + deps/alexandria/alexandria.asd | 68 + deps/alexandria/arrays.lisp | 18 + deps/alexandria/binding.lisp | 93 + deps/alexandria/conditions.lisp | 91 + deps/alexandria/control-flow.lisp | 106 + deps/alexandria/definitions.lisp | 37 + deps/alexandria/doc/.gitignore | 3 + deps/alexandria/doc/Makefile | 28 + deps/alexandria/doc/alexandria.texinfo | 277 ++ deps/alexandria/doc/docstrings.lisp | 881 ++++ deps/alexandria/features.lisp | 14 + deps/alexandria/functions.lisp | 161 + deps/alexandria/hash-tables.lisp | 101 + deps/alexandria/io.lisp | 172 + deps/alexandria/lists.lisp | 367 ++ deps/alexandria/macros.lisp | 314 ++ deps/alexandria/numbers.lisp | 260 ++ deps/alexandria/package.lisp | 244 ++ deps/alexandria/sequences.lisp | 555 +++ deps/alexandria/strings.lisp | 6 + deps/alexandria/symbols.lisp | 65 + deps/alexandria/tests.lisp | 2029 ++++++++++ deps/alexandria/types.lisp | 137 + deps/bordeaux-threads/CONTRIBUTORS | 17 + deps/bordeaux-threads/LICENSE | 20 + deps/bordeaux-threads/README | 2 + deps/bordeaux-threads/bordeaux-threads-test.asd | 17 + deps/bordeaux-threads/bordeaux-threads.asd | 61 + deps/bordeaux-threads/src/bordeaux-threads.lisp | 110 + deps/bordeaux-threads/src/condition-variables.lisp | 34 + .../src/default-implementations.lisp | 321 ++ deps/bordeaux-threads/src/impl-abcl.lisp | 132 + deps/bordeaux-threads/src/impl-allegro.lisp | 115 + deps/bordeaux-threads/src/impl-clisp.lisp | 92 + deps/bordeaux-threads/src/impl-clozure.lisp | 98 + deps/bordeaux-threads/src/impl-cmucl.lisp | 137 + deps/bordeaux-threads/src/impl-corman.lisp | 26 + deps/bordeaux-threads/src/impl-ecl.lisp | 95 + .../src/impl-lispworks-condition-variables.lisp | 138 + deps/bordeaux-threads/src/impl-lispworks.lisp | 125 + deps/bordeaux-threads/src/impl-mcl.lisp | 63 + deps/bordeaux-threads/src/impl-mkcl.lisp | 93 + deps/bordeaux-threads/src/impl-null.lisp | 3 + deps/bordeaux-threads/src/impl-sbcl.lisp | 106 + deps/bordeaux-threads/src/impl-scl.lisp | 90 + deps/bordeaux-threads/src/pkgdcl.lisp | 62 + .../test/bordeaux-threads-test.lisp | 202 + deps/bordeaux-threads/version.lisp-expr | 2 + deps/chunga/CHANGELOG | 8 + deps/chunga/CHANGELOG.txt | 91 + deps/chunga/chunga.asd | 42 + deps/chunga/conditions.lisp | 84 + deps/chunga/docs/index.html | 736 ++++ deps/chunga/input.lisp | 185 + deps/chunga/known-words.lisp | 152 + deps/chunga/output.lisp | 137 + deps/chunga/packages.lisp | 68 + deps/chunga/read.lisp | 293 ++ deps/chunga/specials.lisp | 100 + deps/chunga/streams.lisp | 131 + deps/chunga/util.lisp | 93 + deps/cl-base64/.gitignore | 10 + deps/cl-base64/COPYING | 26 + deps/cl-base64/cl-base64.asd | 44 + deps/cl-base64/debian/changelog | 140 + deps/cl-base64/debian/compat | 1 + deps/cl-base64/debian/control | 19 + deps/cl-base64/debian/copyright | 39 + deps/cl-base64/debian/rules | 44 + deps/cl-base64/debian/upload.sh | 3 + deps/cl-base64/debian/watch | 2 + deps/cl-base64/decode.lisp | 256 ++ deps/cl-base64/encode.lisp | 322 ++ deps/cl-base64/package.lisp | 71 + deps/cl-base64/tests.lisp | 79 + deps/cl-fad/CHANGELOG | 111 + deps/cl-fad/LICENSE | 26 + deps/cl-fad/README | 34 + deps/cl-fad/cl-fad.asd | 49 + deps/cl-fad/cl-fad.system | 48 + deps/cl-fad/corman.lisp | 86 + deps/cl-fad/doc/index.html | 700 ++++ deps/cl-fad/fad.lisp | 584 +++ deps/cl-fad/fad.test.lisp | 157 + deps/cl-fad/load.lisp | 62 + deps/cl-fad/openmcl.lisp | 72 + deps/cl-fad/packages.lisp | 87 + deps/cl-fad/packages.test.lisp | 5 + deps/cl-fad/path.lisp | 32 + deps/cl-fad/temporary-files.lisp | 174 + deps/cl-fad/temporary-files.test.lisp | 49 + deps/flexi-streams/CHANGELOG | 283 ++ deps/flexi-streams/ascii.lisp | 36 + deps/flexi-streams/code-pages.lisp | 62 + deps/flexi-streams/conditions.lisp | 108 + deps/flexi-streams/decode.lisp | 471 +++ deps/flexi-streams/doc/foo.txt | Bin 0 -> 30 bytes deps/flexi-streams/doc/index.html | 1123 ++++++ deps/flexi-streams/encode.lisp | 282 ++ deps/flexi-streams/external-format.lisp | 389 ++ deps/flexi-streams/flexi-streams.asd | 73 + deps/flexi-streams/in-memory.lisp | 406 ++ deps/flexi-streams/input.lisp | 294 ++ deps/flexi-streams/io.lisp | 110 + deps/flexi-streams/iso-8859.lisp | 53 + deps/flexi-streams/koi8-r.lisp | 36 + deps/flexi-streams/length.lisp | 468 +++ deps/flexi-streams/lw-char-stream.lisp | 77 + deps/flexi-streams/mapping.lisp | 81 + deps/flexi-streams/output.lisp | 162 + deps/flexi-streams/packages.lisp | 90 + deps/flexi-streams/specials.lisp | 201 + deps/flexi-streams/stream.lisp | 241 ++ deps/flexi-streams/strings.lisp | 82 + deps/flexi-streams/test/README | 4 + deps/flexi-streams/test/hebrew_latin8_cr.txt | 1 + deps/flexi-streams/test/hebrew_latin8_crlf.txt | 68 + deps/flexi-streams/test/hebrew_latin8_lf.txt | 68 + deps/flexi-streams/test/hebrew_utf8_cr.txt | 1 + deps/flexi-streams/test/hebrew_utf8_crlf.txt | 68 + deps/flexi-streams/test/hebrew_utf8_lf.txt | 68 + deps/flexi-streams/test/kafka_cp1252_cr.txt | 1 + deps/flexi-streams/test/kafka_cp1252_crlf.txt | 11 + deps/flexi-streams/test/kafka_cp1252_lf.txt | 11 + deps/flexi-streams/test/kafka_latin1_cr.txt | 1 + deps/flexi-streams/test/kafka_latin1_crlf.txt | 11 + deps/flexi-streams/test/kafka_latin1_lf.txt | 11 + deps/flexi-streams/test/kafka_utf8_cr.txt | 1 + deps/flexi-streams/test/kafka_utf8_crlf.txt | 11 + deps/flexi-streams/test/kafka_utf8_lf.txt | 11 + deps/flexi-streams/test/packages.lisp | 41 + deps/flexi-streams/test/russian_koi8r_cr.txt | 1 + deps/flexi-streams/test/russian_koi8r_crlf.txt | 6 + deps/flexi-streams/test/russian_koi8r_lf.txt | 6 + deps/flexi-streams/test/russian_utf8_cr.txt | 1 + deps/flexi-streams/test/russian_utf8_crlf.txt | 6 + deps/flexi-streams/test/russian_utf8_lf.txt | 6 + deps/flexi-streams/test/test.lisp | 728 ++++ deps/flexi-streams/test/tilton_ascii_cr.txt | 1 + deps/flexi-streams/test/tilton_ascii_crlf.txt | 96 + deps/flexi-streams/test/tilton_ascii_lf.txt | 96 + deps/flexi-streams/test/tilton_utf8_cr.txt | 1 + deps/flexi-streams/test/tilton_utf8_crlf.txt | 96 + deps/flexi-streams/test/tilton_utf8_lf.txt | 96 + .../flexi-streams/test/unicode_demo_ucs2_cr_be.txt | Bin 0 -> 15242 bytes .../flexi-streams/test/unicode_demo_ucs2_cr_le.txt | Bin 0 -> 15242 bytes .../test/unicode_demo_ucs2_crlf_be.txt | Bin 0 -> 15666 bytes .../test/unicode_demo_ucs2_crlf_le.txt | Bin 0 -> 15666 bytes .../flexi-streams/test/unicode_demo_ucs2_lf_be.txt | Bin 0 -> 15242 bytes .../flexi-streams/test/unicode_demo_ucs2_lf_le.txt | Bin 0 -> 15242 bytes .../flexi-streams/test/unicode_demo_ucs4_cr_be.txt | Bin 0 -> 30484 bytes .../flexi-streams/test/unicode_demo_ucs4_cr_le.txt | Bin 0 -> 30484 bytes .../test/unicode_demo_ucs4_crlf_be.txt | Bin 0 -> 31332 bytes .../test/unicode_demo_ucs4_crlf_le.txt | Bin 0 -> 31332 bytes .../flexi-streams/test/unicode_demo_ucs4_lf_be.txt | Bin 0 -> 30484 bytes .../flexi-streams/test/unicode_demo_ucs4_lf_le.txt | Bin 0 -> 30484 bytes deps/flexi-streams/test/unicode_demo_utf8_cr.txt | 1 + deps/flexi-streams/test/unicode_demo_utf8_crlf.txt | 212 + deps/flexi-streams/test/unicode_demo_utf8_lf.txt | 212 + deps/flexi-streams/util.lisp | 206 + deps/hunchentoot/.gitignore | 2 + deps/hunchentoot/.pre-release.sh | 1 + deps/hunchentoot/CHANGELOG | 567 +++ deps/hunchentoot/CHANGELOG_TBNL | 340 ++ deps/hunchentoot/README | 4 + deps/hunchentoot/acceptor.lisp | 789 ++++ deps/hunchentoot/compat.lisp | 136 + deps/hunchentoot/conditions.lisp | 133 + deps/hunchentoot/cookie.lisp | 127 + deps/hunchentoot/doc/LICENSE.txt | 9 + deps/hunchentoot/doc/Makefile | 3 + deps/hunchentoot/doc/clixdoc.xsl | 466 +++ deps/hunchentoot/doc/hunchentoot.gif | Bin 0 -> 490 bytes deps/hunchentoot/doc/index.xml | 3654 +++++++++++++++++ deps/hunchentoot/easy-handlers.lisp | 347 ++ deps/hunchentoot/headers.lisp | 279 ++ deps/hunchentoot/hunchentoot.asd | 102 + deps/hunchentoot/lispworks.lisp | 145 + deps/hunchentoot/log.lisp | 66 + deps/hunchentoot/make-docstrings.lisp | 228 ++ deps/hunchentoot/mime-types.lisp | 363 ++ deps/hunchentoot/misc.lisp | 274 ++ deps/hunchentoot/packages.lisp | 295 ++ deps/hunchentoot/release-checklist.txt | 5 + deps/hunchentoot/reply.lisp | 157 + deps/hunchentoot/request.lisp | 622 +++ deps/hunchentoot/run-test.lisp | 87 + deps/hunchentoot/session.lisp | 381 ++ deps/hunchentoot/set-timeouts.lisp | 85 + deps/hunchentoot/specials.lisp | 310 ++ deps/hunchentoot/ssl.lisp | 119 + deps/hunchentoot/taskmaster.lisp | 479 +++ deps/hunchentoot/test/UTF-8-demo.html | 213 + deps/hunchentoot/test/favicon.ico | Bin 0 -> 318 bytes deps/hunchentoot/test/fz.jpg | Bin 0 -> 21001 bytes deps/hunchentoot/test/packages.lisp | 37 + deps/hunchentoot/test/script-engine.lisp | 180 + deps/hunchentoot/test/script.lisp | 194 + deps/hunchentoot/test/test-certificate.crt | 13 + deps/hunchentoot/test/test-handlers.lisp | 557 +++ deps/hunchentoot/test/test-key-no-password.key | 15 + deps/hunchentoot/url-rewrite/packages.lisp | 38 + deps/hunchentoot/url-rewrite/primitives.lisp | 154 + deps/hunchentoot/url-rewrite/specials.lisp | 66 + deps/hunchentoot/url-rewrite/url-rewrite.lisp | 293 ++ deps/hunchentoot/url-rewrite/util.lisp | 126 + deps/hunchentoot/util.lisp | 379 ++ deps/hunchentoot/www/errors/404.html | 9 + deps/hunchentoot/www/errors/500.html | 18 + deps/hunchentoot/www/favicon.ico | Bin 0 -> 1406 bytes deps/hunchentoot/www/hunchentoot-doc.html | 4237 ++++++++++++++++++++ deps/hunchentoot/www/hunchentoot.gif | Bin 0 -> 490 bytes deps/hunchentoot/www/img/made-with-lisp-logo.jpg | Bin 0 -> 12583 bytes deps/hunchentoot/www/index.html | 17 + deps/md5/.gitattributes | 2 + deps/md5/.gitignore | 12 + deps/md5/COPYING | 5 + deps/md5/NEWS | 51 + deps/md5/README | 22 + deps/md5/md5.asd | 23 + deps/md5/md5.lisp | 976 +++++ deps/rfc2388/packages.lisp | 46 + deps/rfc2388/rfc2388.asd | 40 + deps/rfc2388/rfc2388.lisp | 492 +++ deps/rfc2388/test.lisp | 85 + deps/trivial-backtrace/.gitignore | 15 + deps/trivial-backtrace/COPYING | 25 + deps/trivial-backtrace/dev/backtrace.lisp | 127 + deps/trivial-backtrace/dev/fallback.lisp | 10 + deps/trivial-backtrace/dev/map-backtrace.lisp | 105 + deps/trivial-backtrace/dev/mucking.lisp | 75 + deps/trivial-backtrace/dev/packages.lisp | 13 + deps/trivial-backtrace/dev/utilities.lisp | 104 + deps/trivial-backtrace/lift-standard.config | 35 + deps/trivial-backtrace/test/packages.lisp | 5 + deps/trivial-backtrace/test/test-setup.lisp | 4 + deps/trivial-backtrace/test/tests.lisp | 17 + deps/trivial-backtrace/trivial-backtrace-test.asd | 22 + deps/trivial-backtrace/trivial-backtrace.asd | 35 + deps/trivial-backtrace/website/source/index.md | 88 + .../website/source/resources/footer.md | 15 + .../website/source/resources/header.md | 19 + .../website/source/resources/navigation.md | 2 + deps/trivial-backtrace/website/website.tmproj | 93 + deps/trivial-gray-streams/COPYING | 22 + deps/trivial-gray-streams/Makefile | 3 + deps/trivial-gray-streams/README | 40 + deps/trivial-gray-streams/build.xcvb | 7 + deps/trivial-gray-streams/package.lisp | 77 + deps/trivial-gray-streams/streams.lisp | 277 ++ deps/trivial-gray-streams/test/package.lisp | 6 + .../test/run-on-many-lisps.lisp | 66 + deps/trivial-gray-streams/test/test-framework.lisp | 60 + deps/trivial-gray-streams/test/test.lisp | 212 + .../trivial-gray-streams-test.asd | 10 + deps/trivial-gray-streams/trivial-gray-streams.asd | 10 + deps/usocket/CHANGES | 99 + deps/usocket/LICENSE | 24 + deps/usocket/README.md | 142 + deps/usocket/TODO | 5 + deps/usocket/backend/abcl.lisp | 441 ++ deps/usocket/backend/allegro.lisp | 225 ++ deps/usocket/backend/clisp.lisp | 703 ++++ deps/usocket/backend/clozure.lisp | 73 + deps/usocket/backend/cmucl.lisp | 298 ++ deps/usocket/backend/ecl.lisp | 154 + deps/usocket/backend/lispworks.lisp | 838 ++++ deps/usocket/backend/mcl.lisp | 272 ++ deps/usocket/backend/mocl.lisp | 162 + deps/usocket/backend/openmcl.lisp | 270 ++ deps/usocket/backend/sbcl.lisp | 866 ++++ deps/usocket/backend/scl.lisp | 273 ++ deps/usocket/condition.lisp | 238 ++ deps/usocket/doc/backends.txt | 60 + deps/usocket/doc/design.txt | 136 + deps/usocket/notes/abcl-socket.txt | 18 + deps/usocket/notes/active-sockets-apis.txt | 75 + deps/usocket/notes/address-apis.txt | 73 + deps/usocket/notes/allegro-socket.txt | 46 + deps/usocket/notes/clisp-sockets.txt | 38 + deps/usocket/notes/cmucl-sockets.txt | 69 + deps/usocket/notes/errors.txt | 20 + deps/usocket/notes/lw-sockets.txt | 41 + deps/usocket/notes/openmcl-sockets.txt | 27 + deps/usocket/notes/sb-bsd-sockets.txt | 114 + deps/usocket/notes/usock-sockets.txt | 28 + deps/usocket/option.lisp | 276 ++ deps/usocket/package.lisp | 90 + deps/usocket/server.lisp | 108 + deps/usocket/test/package.lisp | 13 + deps/usocket/test/test-condition.lisp | 28 + deps/usocket/test/test-datagram.lisp | 122 + deps/usocket/test/test-usocket.lisp | 181 + deps/usocket/test/wait-for-input.lisp | 141 + deps/usocket/usocket-test.asd | 25 + deps/usocket/usocket.asd | 40 + deps/usocket/usocket.lisp | 679 ++++ deps/usocket/vendor/OpenTransportUDP.lisp | 146 + deps/usocket/vendor/kqueue.lisp | 1 + deps/usocket/vendor/spawn-thread.lisp | 78 + deps/usocket/vendor/split-sequence.lisp | 245 ++ 308 files changed, 49543 insertions(+), 1 deletion(-) create mode 100644 deps/alexandria/.boring create mode 100644 deps/alexandria/.gitignore create mode 100644 deps/alexandria/AUTHORS create mode 100644 deps/alexandria/LICENCE create mode 100644 deps/alexandria/README create mode 100644 deps/alexandria/alexandria-tests.asd create mode 100644 deps/alexandria/alexandria.asd create mode 100644 deps/alexandria/arrays.lisp create mode 100644 deps/alexandria/binding.lisp create mode 100644 deps/alexandria/conditions.lisp create mode 100644 deps/alexandria/control-flow.lisp create mode 100644 deps/alexandria/definitions.lisp create mode 100644 deps/alexandria/doc/.gitignore create mode 100644 deps/alexandria/doc/Makefile create mode 100644 deps/alexandria/doc/alexandria.texinfo create mode 100644 deps/alexandria/doc/docstrings.lisp create mode 100644 deps/alexandria/features.lisp create mode 100644 deps/alexandria/functions.lisp create mode 100644 deps/alexandria/hash-tables.lisp create mode 100644 deps/alexandria/io.lisp create mode 100644 deps/alexandria/lists.lisp create mode 100644 deps/alexandria/macros.lisp create mode 100644 deps/alexandria/numbers.lisp create mode 100644 deps/alexandria/package.lisp create mode 100644 deps/alexandria/sequences.lisp create mode 100644 deps/alexandria/strings.lisp create mode 100644 deps/alexandria/symbols.lisp create mode 100644 deps/alexandria/tests.lisp create mode 100644 deps/alexandria/types.lisp create mode 100644 deps/bordeaux-threads/CONTRIBUTORS create mode 100644 deps/bordeaux-threads/LICENSE create mode 100644 deps/bordeaux-threads/README create mode 100644 deps/bordeaux-threads/bordeaux-threads-test.asd create mode 100644 deps/bordeaux-threads/bordeaux-threads.asd create mode 100644 deps/bordeaux-threads/src/bordeaux-threads.lisp create mode 100644 deps/bordeaux-threads/src/condition-variables.lisp create mode 100644 deps/bordeaux-threads/src/default-implementations.lisp create mode 100644 deps/bordeaux-threads/src/impl-abcl.lisp create mode 100644 deps/bordeaux-threads/src/impl-allegro.lisp create mode 100644 deps/bordeaux-threads/src/impl-clisp.lisp create mode 100644 deps/bordeaux-threads/src/impl-clozure.lisp create mode 100644 deps/bordeaux-threads/src/impl-cmucl.lisp create mode 100644 deps/bordeaux-threads/src/impl-corman.lisp create mode 100644 deps/bordeaux-threads/src/impl-ecl.lisp create mode 100644 deps/bordeaux-threads/src/impl-lispworks-condition-variables.lisp create mode 100644 deps/bordeaux-threads/src/impl-lispworks.lisp create mode 100644 deps/bordeaux-threads/src/impl-mcl.lisp create mode 100644 deps/bordeaux-threads/src/impl-mkcl.lisp create mode 100644 deps/bordeaux-threads/src/impl-null.lisp create mode 100644 deps/bordeaux-threads/src/impl-sbcl.lisp create mode 100644 deps/bordeaux-threads/src/impl-scl.lisp create mode 100644 deps/bordeaux-threads/src/pkgdcl.lisp create mode 100644 deps/bordeaux-threads/test/bordeaux-threads-test.lisp create mode 100644 deps/bordeaux-threads/version.lisp-expr create mode 100644 deps/chunga/CHANGELOG create mode 100644 deps/chunga/CHANGELOG.txt create mode 100644 deps/chunga/chunga.asd create mode 100644 deps/chunga/conditions.lisp create mode 100644 deps/chunga/docs/index.html create mode 100644 deps/chunga/input.lisp create mode 100644 deps/chunga/known-words.lisp create mode 100644 deps/chunga/output.lisp create mode 100644 deps/chunga/packages.lisp create mode 100644 deps/chunga/read.lisp create mode 100644 deps/chunga/specials.lisp create mode 100644 deps/chunga/streams.lisp create mode 100644 deps/chunga/util.lisp create mode 100644 deps/cl-base64/.gitignore create mode 100644 deps/cl-base64/COPYING create mode 100644 deps/cl-base64/cl-base64.asd create mode 100644 deps/cl-base64/debian/changelog create mode 100644 deps/cl-base64/debian/compat create mode 100644 deps/cl-base64/debian/control create mode 100644 deps/cl-base64/debian/copyright create mode 100755 deps/cl-base64/debian/rules create mode 100755 deps/cl-base64/debian/upload.sh create mode 100644 deps/cl-base64/debian/watch create mode 100644 deps/cl-base64/decode.lisp create mode 100644 deps/cl-base64/encode.lisp create mode 100644 deps/cl-base64/package.lisp create mode 100644 deps/cl-base64/tests.lisp create mode 100644 deps/cl-fad/CHANGELOG create mode 100644 deps/cl-fad/LICENSE create mode 100644 deps/cl-fad/README create mode 100644 deps/cl-fad/cl-fad.asd create mode 100644 deps/cl-fad/cl-fad.system create mode 100644 deps/cl-fad/corman.lisp create mode 100644 deps/cl-fad/doc/index.html create mode 100644 deps/cl-fad/fad.lisp create mode 100644 deps/cl-fad/fad.test.lisp create mode 100644 deps/cl-fad/load.lisp create mode 100644 deps/cl-fad/openmcl.lisp create mode 100644 deps/cl-fad/packages.lisp create mode 100644 deps/cl-fad/packages.test.lisp create mode 100644 deps/cl-fad/path.lisp create mode 100644 deps/cl-fad/temporary-files.lisp create mode 100644 deps/cl-fad/temporary-files.test.lisp create mode 100644 deps/flexi-streams/CHANGELOG create mode 100644 deps/flexi-streams/ascii.lisp create mode 100644 deps/flexi-streams/code-pages.lisp create mode 100644 deps/flexi-streams/conditions.lisp create mode 100644 deps/flexi-streams/decode.lisp create mode 100644 deps/flexi-streams/doc/foo.txt create mode 100644 deps/flexi-streams/doc/index.html create mode 100644 deps/flexi-streams/encode.lisp create mode 100644 deps/flexi-streams/external-format.lisp create mode 100644 deps/flexi-streams/flexi-streams.asd create mode 100644 deps/flexi-streams/in-memory.lisp create mode 100644 deps/flexi-streams/input.lisp create mode 100644 deps/flexi-streams/io.lisp create mode 100644 deps/flexi-streams/iso-8859.lisp create mode 100644 deps/flexi-streams/koi8-r.lisp create mode 100644 deps/flexi-streams/length.lisp create mode 100644 deps/flexi-streams/lw-char-stream.lisp create mode 100644 deps/flexi-streams/mapping.lisp create mode 100644 deps/flexi-streams/output.lisp create mode 100644 deps/flexi-streams/packages.lisp create mode 100644 deps/flexi-streams/specials.lisp create mode 100644 deps/flexi-streams/stream.lisp create mode 100644 deps/flexi-streams/strings.lisp create mode 100644 deps/flexi-streams/test/README create mode 100644 deps/flexi-streams/test/hebrew_latin8_cr.txt create mode 100644 deps/flexi-streams/test/hebrew_latin8_crlf.txt create mode 100644 deps/flexi-streams/test/hebrew_latin8_lf.txt create mode 100644 deps/flexi-streams/test/hebrew_utf8_cr.txt create mode 100644 deps/flexi-streams/test/hebrew_utf8_crlf.txt create mode 100644 deps/flexi-streams/test/hebrew_utf8_lf.txt create mode 100644 deps/flexi-streams/test/kafka_cp1252_cr.txt create mode 100644 deps/flexi-streams/test/kafka_cp1252_crlf.txt create mode 100644 deps/flexi-streams/test/kafka_cp1252_lf.txt create mode 100644 deps/flexi-streams/test/kafka_latin1_cr.txt create mode 100644 deps/flexi-streams/test/kafka_latin1_crlf.txt create mode 100644 deps/flexi-streams/test/kafka_latin1_lf.txt create mode 100644 deps/flexi-streams/test/kafka_utf8_cr.txt create mode 100644 deps/flexi-streams/test/kafka_utf8_crlf.txt create mode 100644 deps/flexi-streams/test/kafka_utf8_lf.txt create mode 100644 deps/flexi-streams/test/packages.lisp create mode 100644 deps/flexi-streams/test/russian_koi8r_cr.txt create mode 100644 deps/flexi-streams/test/russian_koi8r_crlf.txt create mode 100644 deps/flexi-streams/test/russian_koi8r_lf.txt create mode 100644 deps/flexi-streams/test/russian_utf8_cr.txt create mode 100644 deps/flexi-streams/test/russian_utf8_crlf.txt create mode 100644 deps/flexi-streams/test/russian_utf8_lf.txt create mode 100644 deps/flexi-streams/test/test.lisp create mode 100644 deps/flexi-streams/test/tilton_ascii_cr.txt create mode 100644 deps/flexi-streams/test/tilton_ascii_crlf.txt create mode 100644 deps/flexi-streams/test/tilton_ascii_lf.txt create mode 100644 deps/flexi-streams/test/tilton_utf8_cr.txt create mode 100644 deps/flexi-streams/test/tilton_utf8_crlf.txt create mode 100644 deps/flexi-streams/test/tilton_utf8_lf.txt create mode 100644 deps/flexi-streams/test/unicode_demo_ucs2_cr_be.txt create mode 100644 deps/flexi-streams/test/unicode_demo_ucs2_cr_le.txt create mode 100644 deps/flexi-streams/test/unicode_demo_ucs2_crlf_be.txt create mode 100644 deps/flexi-streams/test/unicode_demo_ucs2_crlf_le.txt create mode 100644 deps/flexi-streams/test/unicode_demo_ucs2_lf_be.txt create mode 100644 deps/flexi-streams/test/unicode_demo_ucs2_lf_le.txt create mode 100644 deps/flexi-streams/test/unicode_demo_ucs4_cr_be.txt create mode 100644 deps/flexi-streams/test/unicode_demo_ucs4_cr_le.txt create mode 100644 deps/flexi-streams/test/unicode_demo_ucs4_crlf_be.txt create mode 100644 deps/flexi-streams/test/unicode_demo_ucs4_crlf_le.txt create mode 100644 deps/flexi-streams/test/unicode_demo_ucs4_lf_be.txt create mode 100644 deps/flexi-streams/test/unicode_demo_ucs4_lf_le.txt create mode 100644 deps/flexi-streams/test/unicode_demo_utf8_cr.txt create mode 100644 deps/flexi-streams/test/unicode_demo_utf8_crlf.txt create mode 100644 deps/flexi-streams/test/unicode_demo_utf8_lf.txt create mode 100644 deps/flexi-streams/util.lisp create mode 100644 deps/hunchentoot/.gitignore create mode 100755 deps/hunchentoot/.pre-release.sh create mode 100644 deps/hunchentoot/CHANGELOG create mode 100644 deps/hunchentoot/CHANGELOG_TBNL create mode 100644 deps/hunchentoot/README create mode 100644 deps/hunchentoot/acceptor.lisp create mode 100644 deps/hunchentoot/compat.lisp create mode 100644 deps/hunchentoot/conditions.lisp create mode 100644 deps/hunchentoot/cookie.lisp create mode 100644 deps/hunchentoot/doc/LICENSE.txt create mode 100644 deps/hunchentoot/doc/Makefile create mode 100644 deps/hunchentoot/doc/clixdoc.xsl create mode 100644 deps/hunchentoot/doc/hunchentoot.gif create mode 100644 deps/hunchentoot/doc/index.xml create mode 100644 deps/hunchentoot/easy-handlers.lisp create mode 100644 deps/hunchentoot/headers.lisp create mode 100644 deps/hunchentoot/hunchentoot.asd create mode 100755 deps/hunchentoot/lispworks.lisp create mode 100644 deps/hunchentoot/log.lisp create mode 100644 deps/hunchentoot/make-docstrings.lisp create mode 100644 deps/hunchentoot/mime-types.lisp create mode 100644 deps/hunchentoot/misc.lisp create mode 100644 deps/hunchentoot/packages.lisp create mode 100644 deps/hunchentoot/release-checklist.txt create mode 100644 deps/hunchentoot/reply.lisp create mode 100644 deps/hunchentoot/request.lisp create mode 100644 deps/hunchentoot/run-test.lisp create mode 100644 deps/hunchentoot/session.lisp create mode 100644 deps/hunchentoot/set-timeouts.lisp create mode 100644 deps/hunchentoot/specials.lisp create mode 100644 deps/hunchentoot/ssl.lisp create mode 100644 deps/hunchentoot/taskmaster.lisp create mode 100644 deps/hunchentoot/test/UTF-8-demo.html create mode 100755 deps/hunchentoot/test/favicon.ico create mode 100644 deps/hunchentoot/test/fz.jpg create mode 100755 deps/hunchentoot/test/packages.lisp create mode 100644 deps/hunchentoot/test/script-engine.lisp create mode 100644 deps/hunchentoot/test/script.lisp create mode 100644 deps/hunchentoot/test/test-certificate.crt create mode 100644 deps/hunchentoot/test/test-handlers.lisp create mode 100644 deps/hunchentoot/test/test-key-no-password.key create mode 100644 deps/hunchentoot/url-rewrite/packages.lisp create mode 100644 deps/hunchentoot/url-rewrite/primitives.lisp create mode 100644 deps/hunchentoot/url-rewrite/specials.lisp create mode 100644 deps/hunchentoot/url-rewrite/url-rewrite.lisp create mode 100644 deps/hunchentoot/url-rewrite/util.lisp create mode 100644 deps/hunchentoot/util.lisp create mode 100644 deps/hunchentoot/www/errors/404.html create mode 100644 deps/hunchentoot/www/errors/500.html create mode 100644 deps/hunchentoot/www/favicon.ico create mode 100644 deps/hunchentoot/www/hunchentoot-doc.html create mode 100644 deps/hunchentoot/www/hunchentoot.gif create mode 100644 deps/hunchentoot/www/img/made-with-lisp-logo.jpg create mode 100644 deps/hunchentoot/www/index.html create mode 100644 deps/md5/.gitattributes create mode 100644 deps/md5/.gitignore create mode 100644 deps/md5/COPYING create mode 100755 deps/md5/NEWS create mode 100644 deps/md5/README create mode 100755 deps/md5/md5.asd create mode 100755 deps/md5/md5.lisp create mode 100644 deps/rfc2388/packages.lisp create mode 100644 deps/rfc2388/rfc2388.asd create mode 100644 deps/rfc2388/rfc2388.lisp create mode 100644 deps/rfc2388/test.lisp create mode 100644 deps/trivial-backtrace/.gitignore create mode 100644 deps/trivial-backtrace/COPYING create mode 100644 deps/trivial-backtrace/dev/backtrace.lisp create mode 100644 deps/trivial-backtrace/dev/fallback.lisp create mode 100644 deps/trivial-backtrace/dev/map-backtrace.lisp create mode 100644 deps/trivial-backtrace/dev/mucking.lisp create mode 100644 deps/trivial-backtrace/dev/packages.lisp create mode 100644 deps/trivial-backtrace/dev/utilities.lisp create mode 100644 deps/trivial-backtrace/lift-standard.config create mode 100644 deps/trivial-backtrace/test/packages.lisp create mode 100644 deps/trivial-backtrace/test/test-setup.lisp create mode 100644 deps/trivial-backtrace/test/tests.lisp create mode 100644 deps/trivial-backtrace/trivial-backtrace-test.asd create mode 100644 deps/trivial-backtrace/trivial-backtrace.asd create mode 100644 deps/trivial-backtrace/website/source/index.md create mode 100644 deps/trivial-backtrace/website/source/resources/footer.md create mode 100644 deps/trivial-backtrace/website/source/resources/header.md create mode 100644 deps/trivial-backtrace/website/source/resources/navigation.md create mode 100644 deps/trivial-backtrace/website/website.tmproj create mode 100644 deps/trivial-gray-streams/COPYING create mode 100644 deps/trivial-gray-streams/Makefile create mode 100644 deps/trivial-gray-streams/README create mode 100644 deps/trivial-gray-streams/build.xcvb create mode 100644 deps/trivial-gray-streams/package.lisp create mode 100644 deps/trivial-gray-streams/streams.lisp create mode 100644 deps/trivial-gray-streams/test/package.lisp create mode 100644 deps/trivial-gray-streams/test/run-on-many-lisps.lisp create mode 100644 deps/trivial-gray-streams/test/test-framework.lisp create mode 100644 deps/trivial-gray-streams/test/test.lisp create mode 100644 deps/trivial-gray-streams/trivial-gray-streams-test.asd create mode 100644 deps/trivial-gray-streams/trivial-gray-streams.asd create mode 100644 deps/usocket/CHANGES create mode 100644 deps/usocket/LICENSE create mode 100644 deps/usocket/README.md create mode 100644 deps/usocket/TODO create mode 100644 deps/usocket/backend/abcl.lisp create mode 100644 deps/usocket/backend/allegro.lisp create mode 100644 deps/usocket/backend/clisp.lisp create mode 100644 deps/usocket/backend/clozure.lisp create mode 100644 deps/usocket/backend/cmucl.lisp create mode 100644 deps/usocket/backend/ecl.lisp create mode 100644 deps/usocket/backend/lispworks.lisp create mode 100644 deps/usocket/backend/mcl.lisp create mode 100644 deps/usocket/backend/mocl.lisp create mode 100644 deps/usocket/backend/openmcl.lisp create mode 100644 deps/usocket/backend/sbcl.lisp create mode 100644 deps/usocket/backend/scl.lisp create mode 100644 deps/usocket/condition.lisp create mode 100644 deps/usocket/doc/backends.txt create mode 100644 deps/usocket/doc/design.txt create mode 100644 deps/usocket/notes/abcl-socket.txt create mode 100644 deps/usocket/notes/active-sockets-apis.txt create mode 100644 deps/usocket/notes/address-apis.txt create mode 100644 deps/usocket/notes/allegro-socket.txt create mode 100644 deps/usocket/notes/clisp-sockets.txt create mode 100644 deps/usocket/notes/cmucl-sockets.txt create mode 100644 deps/usocket/notes/errors.txt create mode 100644 deps/usocket/notes/lw-sockets.txt create mode 100644 deps/usocket/notes/openmcl-sockets.txt create mode 100644 deps/usocket/notes/sb-bsd-sockets.txt create mode 100644 deps/usocket/notes/usock-sockets.txt create mode 100644 deps/usocket/option.lisp create mode 100644 deps/usocket/package.lisp create mode 100644 deps/usocket/server.lisp create mode 100644 deps/usocket/test/package.lisp create mode 100644 deps/usocket/test/test-condition.lisp create mode 100644 deps/usocket/test/test-datagram.lisp create mode 100644 deps/usocket/test/test-usocket.lisp create mode 100644 deps/usocket/test/wait-for-input.lisp create mode 100644 deps/usocket/usocket-test.asd create mode 100644 deps/usocket/usocket.asd create mode 100644 deps/usocket/usocket.lisp create mode 100644 deps/usocket/vendor/OpenTransportUDP.lisp create mode 100644 deps/usocket/vendor/kqueue.lisp create mode 100644 deps/usocket/vendor/spawn-thread.lisp create mode 100644 deps/usocket/vendor/split-sequence.lisp diff --git a/blog.lisp b/blog.lisp index c283c11..32acf0e 100644 --- a/blog.lisp +++ b/blog.lisp @@ -10,7 +10,14 @@ (eval-when (:compile-toplevel :execute :load-toplevel) ;; These are the current "external" requirements - (defvar *deplist* '("cl-who/" "cl-ppcre/" "lbs-utils/")) + (defvar *deplist* '("cl-who/" "cl-ppcre/" "lbs-utils/" + ;; Hunchentoot deps: cl-ppcre is already + ;; included here. + "chunga/" "trivial-gray-streams/" "cl-base64/" "cl-fad/" + "bordeaux-threads/" "alexandria/" "flexi-streams/" "md5/" + "rfc2388/" "trivial-backtrace/" "usocket/" + ;; Hunchentoot itself + "hunchentoot/")) ;; Set paths and change dir (SBCL-specific) (dolist (dep *deplist*) @@ -19,10 +26,16 @@ (sb-posix:chdir *lbs-base*) (setq *default-pathname-defaults* (pathname *lbs-base*)) + ;; Configure WWWisms: for now SSL is a part of the stuff we're + ;; loading, so disable it explicitly. + (pushnew :drakma-no-ssl *features*) + (pushnew :hunchentoot-no-ssl *features*) + ;; Load libraries (require 'asdf) (asdf:load-system :cl-who) (asdf:load-system :cl-ppcre) + (asdf:load-system :hunchentoot) (asdf:load-system :lbs-utils)) ; TLBS global variables diff --git a/deps/alexandria/.boring b/deps/alexandria/.boring new file mode 100644 index 0000000..dfa9e6d --- /dev/null +++ b/deps/alexandria/.boring @@ -0,0 +1,13 @@ +# Boring file regexps: +~$ +^_darcs +^\{arch\} +^.arch-ids +\# +\.dfsl$ +\.ppcf$ +\.fasl$ +\.x86f$ +\.fas$ +\.lib$ +^public_html diff --git a/deps/alexandria/.gitignore b/deps/alexandria/.gitignore new file mode 100644 index 0000000..e832e94 --- /dev/null +++ b/deps/alexandria/.gitignore @@ -0,0 +1,4 @@ +*.fasl +*~ +\#* +*.patch diff --git a/deps/alexandria/AUTHORS b/deps/alexandria/AUTHORS new file mode 100644 index 0000000..b550ea5 --- /dev/null +++ b/deps/alexandria/AUTHORS @@ -0,0 +1,9 @@ + +ACTA EST FABULA PLAUDITE + +Nikodemus Siivola +Attila Lendvai +Marco Baringer +Robert Strandh +Luis Oliveira +Tobias C. Rittweiler \ No newline at end of file diff --git a/deps/alexandria/LICENCE b/deps/alexandria/LICENCE new file mode 100644 index 0000000..b5140fb --- /dev/null +++ b/deps/alexandria/LICENCE @@ -0,0 +1,37 @@ +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. diff --git a/deps/alexandria/README b/deps/alexandria/README new file mode 100644 index 0000000..59e49ab --- /dev/null +++ b/deps/alexandria/README @@ -0,0 +1,52 @@ +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. diff --git a/deps/alexandria/alexandria-tests.asd b/deps/alexandria/alexandria-tests.asd new file mode 100644 index 0000000..8631769 --- /dev/null +++ b/deps/alexandria/alexandria-tests.asd @@ -0,0 +1,12 @@ +(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 , 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))) diff --git a/deps/alexandria/alexandria.asd b/deps/alexandria/alexandria.asd new file mode 100644 index 0000000..045c360 --- /dev/null +++ b/deps/alexandria/alexandria.asd @@ -0,0 +1,68 @@ +(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 , 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)) diff --git a/deps/alexandria/arrays.lisp b/deps/alexandria/arrays.lisp new file mode 100644 index 0000000..76c1879 --- /dev/null +++ b/deps/alexandria/arrays.lisp @@ -0,0 +1,18 @@ +(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)) diff --git a/deps/alexandria/binding.lisp b/deps/alexandria/binding.lisp new file mode 100644 index 0000000..36d92bc --- /dev/null +++ b/deps/alexandria/binding.lisp @@ -0,0 +1,93 @@ +(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)))))) + diff --git a/deps/alexandria/conditions.lisp b/deps/alexandria/conditions.lisp new file mode 100644 index 0000000..ac471cc --- /dev/null +++ b/deps/alexandria/conditions.lisp @@ -0,0 +1,91 @@ +(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 diff --git a/deps/alexandria/control-flow.lisp b/deps/alexandria/control-flow.lisp new file mode 100644 index 0000000..27a2915 --- /dev/null +++ b/deps/alexandria/control-flow.lisp @@ -0,0 +1,106 @@ +(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))) diff --git a/deps/alexandria/definitions.lisp b/deps/alexandria/definitions.lisp new file mode 100644 index 0000000..863e1f6 --- /dev/null +++ b/deps/alexandria/definitions.lisp @@ -0,0 +1,37 @@ +(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)))) diff --git a/deps/alexandria/doc/.gitignore b/deps/alexandria/doc/.gitignore new file mode 100644 index 0000000..f22577b --- /dev/null +++ b/deps/alexandria/doc/.gitignore @@ -0,0 +1,3 @@ +alexandria +include + diff --git a/deps/alexandria/doc/Makefile b/deps/alexandria/doc/Makefile new file mode 100644 index 0000000..85eb818 --- /dev/null +++ b/deps/alexandria/doc/Makefile @@ -0,0 +1,28 @@ +.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 diff --git a/deps/alexandria/doc/alexandria.texinfo b/deps/alexandria/doc/alexandria.texinfo new file mode 100644 index 0000000..89b03ac --- /dev/null +++ b/deps/alexandria/doc/alexandria.texinfo @@ -0,0 +1,277 @@ +\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 diff --git a/deps/alexandria/doc/docstrings.lisp b/deps/alexandria/doc/docstrings.lisp new file mode 100644 index 0000000..51dda07 --- /dev/null +++ b/deps/alexandria/doc/docstrings.lisp @@ -0,0 +1,881 @@ +;;; -*- 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 , 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 +\"__.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 \".texinfo\" is generated. + +The definitions can be referenced using Texinfo statements like +@ref{__.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))) diff --git a/deps/alexandria/features.lisp b/deps/alexandria/features.lisp new file mode 100644 index 0000000..67348db --- /dev/null +++ b/deps/alexandria/features.lisp @@ -0,0 +1,14 @@ +(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)))))))) diff --git a/deps/alexandria/functions.lisp b/deps/alexandria/functions.lisp new file mode 100644 index 0000000..a04b7d0 --- /dev/null +++ b/deps/alexandria/functions.lisp @@ -0,0 +1,161 @@ +(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 diff --git a/deps/alexandria/hash-tables.lisp b/deps/alexandria/hash-tables.lisp new file mode 100644 index 0000000..3a6c3eb --- /dev/null +++ b/deps/alexandria/hash-tables.lisp @@ -0,0 +1,101 @@ +(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)))))) diff --git a/deps/alexandria/io.lisp b/deps/alexandria/io.lisp new file mode 100644 index 0000000..28bf5e6 --- /dev/null +++ b/deps/alexandria/io.lisp @@ -0,0 +1,172 @@ +;; 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 "~@" '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 "~@" '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)) diff --git a/deps/alexandria/lists.lisp b/deps/alexandria/lists.lisp new file mode 100644 index 0000000..1dfc836 --- /dev/null +++ b/deps/alexandria/lists.lisp @@ -0,0 +1,367 @@ +(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))) diff --git a/deps/alexandria/macros.lisp b/deps/alexandria/macros.lisp new file mode 100644 index 0000000..0ac3447 --- /dev/null +++ b/deps/alexandria/macros.lisp @@ -0,0 +1,314 @@ +(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))) + + + diff --git a/deps/alexandria/numbers.lisp b/deps/alexandria/numbers.lisp new file mode 100644 index 0000000..ec40683 --- /dev/null +++ b/deps/alexandria/numbers.lisp @@ -0,0 +1,260 @@ +(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)) diff --git a/deps/alexandria/package.lisp b/deps/alexandria/package.lisp new file mode 100644 index 0000000..180e7e9 --- /dev/null +++ b/deps/alexandria/package.lisp @@ -0,0 +1,244 @@ +(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 + )) diff --git a/deps/alexandria/sequences.lisp b/deps/alexandria/sequences.lisp new file mode 100644 index 0000000..ef594dd --- /dev/null +++ b/deps/alexandria/sequences.lisp @@ -0,0 +1,555 @@ +(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))))) diff --git a/deps/alexandria/strings.lisp b/deps/alexandria/strings.lisp new file mode 100644 index 0000000..e9fd91c --- /dev/null +++ b/deps/alexandria/strings.lisp @@ -0,0 +1,6 @@ +(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)) diff --git a/deps/alexandria/symbols.lisp b/deps/alexandria/symbols.lisp new file mode 100644 index 0000000..5733d3e --- /dev/null +++ b/deps/alexandria/symbols.lisp @@ -0,0 +1,65 @@ +(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)))))) diff --git a/deps/alexandria/tests.lisp b/deps/alexandria/tests.lisp new file mode 100644 index 0000000..a00a700 --- /dev/null +++ b/deps/alexandria/tests.lisp @@ -0,0 +1,2029 @@ +(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) diff --git a/deps/alexandria/types.lisp b/deps/alexandria/types.lisp new file mode 100644 index 0000000..1942d0e --- /dev/null +++ b/deps/alexandria/types.lisp @@ -0,0 +1,137 @@ +(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.") diff --git a/deps/bordeaux-threads/CONTRIBUTORS b/deps/bordeaux-threads/CONTRIBUTORS new file mode 100644 index 0000000..cb7ff3c --- /dev/null +++ b/deps/bordeaux-threads/CONTRIBUTORS @@ -0,0 +1,17 @@ +-*- outline -*- + +Based on original Bordeaux-MP spec by Dan Barlow + +Contributors: + +* Attila Lendvai + - better handling of unsupported Lisps +* Vladimir Sekissov + - fixes for CMUCL implementation +* Pierre Thierry + - added license information +* Stelian Ionescu + - finished conversion from generic functions + - enabled running thread-safe code in unthreaded lisps +* Douglas Crosher + - added Scieneer Common Lisp support diff --git a/deps/bordeaux-threads/LICENSE b/deps/bordeaux-threads/LICENSE new file mode 100644 index 0000000..3ce400f --- /dev/null +++ b/deps/bordeaux-threads/LICENSE @@ -0,0 +1,20 @@ +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. diff --git a/deps/bordeaux-threads/README b/deps/bordeaux-threads/README new file mode 100644 index 0000000..1531578 --- /dev/null +++ b/deps/bordeaux-threads/README @@ -0,0 +1,2 @@ +You can find API documentation on the project's wiki: + http://trac.common-lisp.net/bordeaux-threads/wiki/ApiDocumentation diff --git a/deps/bordeaux-threads/bordeaux-threads-test.asd b/deps/bordeaux-threads/bordeaux-threads-test.asd new file mode 100644 index 0000000..ab73313 --- /dev/null +++ b/deps/bordeaux-threads/bordeaux-threads-test.asd @@ -0,0 +1,17 @@ +#| +Copyright 2006,2007 Greg Pfeil + +Distributed under the MIT license (see LICENSE file) +|# + +(asdf:defsystem :bordeaux-threads-test + :depends-on (:bordeaux-threads :fiveam) + :version #.(with-open-file + (vers (merge-pathnames "version.lisp-expr" *load-truename*)) + (read vers)) + :components ((:module "test" + :components ((:file "bordeaux-threads-test")))) + :in-order-to ((asdf:test-op (asdf:load-op bordeaux-threads-test))) + :perform (asdf:test-op :after (op c) + (describe (funcall (intern (string '#:run!) :fiveam) + :bordeaux-threads)))) diff --git a/deps/bordeaux-threads/bordeaux-threads.asd b/deps/bordeaux-threads/bordeaux-threads.asd new file mode 100644 index 0000000..655b68d --- /dev/null +++ b/deps/bordeaux-threads/bordeaux-threads.asd @@ -0,0 +1,61 @@ +;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- + +#| +Copyright 2006,2007 Greg Pfeil + +Distributed under the MIT license (see LICENSE file) +|# + +(eval-when (:compile-toplevel :load-toplevel :execute) + #+allegro (require :smputil) + #+corman (require :threads)) + +(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*)) + +(asdf:defsystem :bordeaux-threads + :author "Greg Pfeil " + :licence "MIT" + :description "Bordeaux Threads makes writing portable multi-threaded apps simple" + :version #.(with-open-file + (vers (merge-pathnames "version.lisp-expr" *load-truename*)) + (read vers)) + :depends-on (:alexandria) + :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 lispworks6)) + (:file "impl-lispworks-condition-variables") + #+(and thread-support digitool) + (:file "condition-variables") + (:file "default-implementations")))) + :in-order-to ((asdf:test-op (asdf:load-op bordeaux-threads-test))) + :perform (asdf:test-op :after (op c) + (asdf:oos 'asdf:test-op :bordeaux-threads-test))) diff --git a/deps/bordeaux-threads/src/bordeaux-threads.lisp b/deps/bordeaux-threads/src/bordeaux-threads.lisp new file mode 100644 index 0000000..d862d09 --- /dev/null +++ b/deps/bordeaux-threads/src/bordeaux-threads.lisp @@ -0,0 +1,110 @@ +;;;; -*- 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"))) diff --git a/deps/bordeaux-threads/src/condition-variables.lisp b/deps/bordeaux-threads/src/condition-variables.lisp new file mode 100644 index 0000000..99b7356 --- /dev/null +++ b/deps/bordeaux-threads/src/condition-variables.lisp @@ -0,0 +1,34 @@ +;;;; -*- 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) + (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))) + +(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))) diff --git a/deps/bordeaux-threads/src/default-implementations.lisp b/deps/bordeaux-threads/src/default-implementations.lisp new file mode 100644 index 0000000..c12dfbe --- /dev/null +++ b/deps/bordeaux-threads/src/default-implementations.lisp @@ -0,0 +1,321 @@ +;;;; -*- 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) + "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. + + However and for whatever reason the thread is resumed, the system + always reacquires LOCK before returning to the caller. It is an + error to call this unless from the thread that holds LOCK. + + In an implementation that does not support multiple threads, this + function signals an error." + (declare (ignore condition-variable lock)) + (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))) diff --git a/deps/bordeaux-threads/src/impl-abcl.lisp b/deps/bordeaux-threads/src/impl-abcl.lisp new file mode 100644 index 0000000..c904e7e --- /dev/null +++ b/deps/bordeaux-threads/src/impl-abcl.lisp @@ -0,0 +1,132 @@ +;;;; -*- 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 () + (sleep 0.01)) + +(defstruct condition-variable + (name "Anonymous condition variable")) + +(defun condition-wait (condition lock) + (threads:synchronized-on condition + (release-lock lock) + (threads:object-wait condition)) + (acquire-lock lock)) + +(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) diff --git a/deps/bordeaux-threads/src/impl-allegro.lisp b/deps/bordeaux-threads/src/impl-allegro.lisp new file mode 100644 index 0000000..40769dd --- /dev/null +++ b/deps/bordeaux-threads/src/impl-allegro.lisp @@ -0,0 +1,115 @@ +;;;; -*- 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) + (mp:make-condition-variable :name name)) + +(defun condition-wait (condition-variable lock) + (mp:condition-variable-wait condition-variable lock)) + +(defun condition-notify (condition-variable) + (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 + (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) diff --git a/deps/bordeaux-threads/src/impl-clisp.lisp b/deps/bordeaux-threads/src/impl-clisp.lisp new file mode 100644 index 0000000..22ef2c4 --- /dev/null +++ b/deps/bordeaux-threads/src/impl-clisp.lisp @@ -0,0 +1,92 @@ +;;;; -*- 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) + (mt:exemption-wait condition-variable lock)) + +(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) diff --git a/deps/bordeaux-threads/src/impl-clozure.lisp b/deps/bordeaux-threads/src/impl-clozure.lisp new file mode 100644 index 0000000..85a6d3d --- /dev/null +++ b/deps/bordeaux-threads/src/impl-clozure.lisp @@ -0,0 +1,98 @@ +;;;; -*- 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) + (release-lock lock) + (unwind-protect + (ccl:wait-on-semaphore condition-variable) + (acquire-lock lock 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) + (ccl::process-active-p thread)) + +(defun join-thread (thread) + (ccl:join-process thread)) + +(mark-supported) diff --git a/deps/bordeaux-threads/src/impl-cmucl.lisp b/deps/bordeaux-threads/src/impl-cmucl.lisp new file mode 100644 index 0000000..074646f --- /dev/null +++ b/deps/bordeaux-threads/src/impl-cmucl.lisp @@ -0,0 +1,137 @@ +;;;; -*- 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"))) + +(defun acquire-lock (lock &optional (wait-p t)) + (if wait-p + (mp::lock-wait lock "Lock") + (mp::lock-wait-with-timeout lock "Lock" 0))) + +(defun release-lock (lock) + (setf (mp::lock-process lock) nil)) + +(defmacro with-lock-held ((place) &body body) + `(mp:with-lock-held (,place) ,@body)) + +(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) + (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) + +(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) diff --git a/deps/bordeaux-threads/src/impl-corman.lisp b/deps/bordeaux-threads/src/impl-corman.lisp new file mode 100644 index 0000000..dad4524 --- /dev/null +++ b/deps/bordeaux-threads/src/impl-corman.lisp @@ -0,0 +1,26 @@ +;;;; -*- 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) diff --git a/deps/bordeaux-threads/src/impl-ecl.lisp b/deps/bordeaux-threads/src/impl-ecl.lisp new file mode 100644 index 0000000..be8cc14 --- /dev/null +++ b/deps/bordeaux-threads/src/impl-ecl.lisp @@ -0,0 +1,95 @@ +;;;; -*- 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) + (mp:condition-variable-wait condition-variable lock)) + +(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) diff --git a/deps/bordeaux-threads/src/impl-lispworks-condition-variables.lisp b/deps/bordeaux-threads/src/impl-lispworks-condition-variables.lisp new file mode 100644 index 0000000..c6dc20b --- /dev/null +++ b/deps/bordeaux-threads/src/impl-lispworks-condition-variables.lisp @@ -0,0 +1,138 @@ +;;;; -*- 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-) + (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-))) diff --git a/deps/bordeaux-threads/src/impl-lispworks.lisp b/deps/bordeaux-threads/src/impl-lispworks.lisp new file mode 100644 index 0000000..882866b --- /dev/null +++ b/deps/bordeaux-threads/src/impl-lispworks.lisp @@ -0,0 +1,125 @@ +;;;; -*- 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) +(defun make-condition-variable (&key name) + (mp:make-condition-variable :name (or name "Anonymous condition variable"))) + +#+(or lispworks6) +(defun condition-wait (condition-variable lock) + (mp:condition-variable-wait condition-variable lock)) + +#+(or lispworks6) +(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) diff --git a/deps/bordeaux-threads/src/impl-mcl.lisp b/deps/bordeaux-threads/src/impl-mcl.lisp new file mode 100644 index 0000000..3530f5d --- /dev/null +++ b/deps/bordeaux-threads/src/impl-mcl.lisp @@ -0,0 +1,63 @@ +;;;; -*- 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) diff --git a/deps/bordeaux-threads/src/impl-mkcl.lisp b/deps/bordeaux-threads/src/impl-mkcl.lisp new file mode 100644 index 0000000..dfeef97 --- /dev/null +++ b/deps/bordeaux-threads/src/impl-mkcl.lisp @@ -0,0 +1,93 @@ +;;;; -*- 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) + (mt:condition-wait condition-variable lock)) + +(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) diff --git a/deps/bordeaux-threads/src/impl-null.lisp b/deps/bordeaux-threads/src/impl-null.lisp new file mode 100644 index 0000000..2cf4bbb --- /dev/null +++ b/deps/bordeaux-threads/src/impl-null.lisp @@ -0,0 +1,3 @@ +;;;; -*- indent-tabs-mode: nil -*- + +(in-package #:bordeaux-threads) diff --git a/deps/bordeaux-threads/src/impl-sbcl.lisp b/deps/bordeaux-threads/src/impl-sbcl.lisp new file mode 100644 index 0000000..bf20a94 --- /dev/null +++ b/deps/bordeaux-threads/src/impl-sbcl.lisp @@ -0,0 +1,106 @@ +;;;; -*- 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) + (sb-thread:condition-wait condition-variable lock)) + +(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) diff --git a/deps/bordeaux-threads/src/impl-scl.lisp b/deps/bordeaux-threads/src/impl-scl.lisp new file mode 100644 index 0000000..0b798e2 --- /dev/null +++ b/deps/bordeaux-threads/src/impl-scl.lisp @@ -0,0 +1,90 @@ +;;;; -*- 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) + (thread:cond-var-wait condition-variable lock)) + +(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) diff --git a/deps/bordeaux-threads/src/pkgdcl.lisp b/deps/bordeaux-threads/src/pkgdcl.lisp new file mode 100644 index 0000000..0dd4382 --- /dev/null +++ b/deps/bordeaux-threads/src/pkgdcl.lisp @@ -0,0 +1,62 @@ +;;;; -*- 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.")) diff --git a/deps/bordeaux-threads/test/bordeaux-threads-test.lisp b/deps/bordeaux-threads/test/bordeaux-threads-test.lisp new file mode 100644 index 0000000..e400910 --- /dev/null +++ b/deps/bordeaux-threads/test/bordeaux-threads-test.lisp @@ -0,0 +1,202 @@ +#| +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))) + (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*))) + (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))) diff --git a/deps/bordeaux-threads/version.lisp-expr b/deps/bordeaux-threads/version.lisp-expr new file mode 100644 index 0000000..f9514c4 --- /dev/null +++ b/deps/bordeaux-threads/version.lisp-expr @@ -0,0 +1,2 @@ +;; -*- lisp -*- +"0.8.3" diff --git a/deps/chunga/CHANGELOG b/deps/chunga/CHANGELOG new file mode 100644 index 0000000..2821100 --- /dev/null +++ b/deps/chunga/CHANGELOG @@ -0,0 +1,8 @@ +Version 1.1.7 +2017-12-31 +Removed (safety 0) +Version 1.1.6 +2014-11-28 +add CHANGELOG (Hans Huebner) +update support info (Hans Huebner) + diff --git a/deps/chunga/CHANGELOG.txt b/deps/chunga/CHANGELOG.txt new file mode 100644 index 0000000..c632b75 --- /dev/null +++ b/deps/chunga/CHANGELOG.txt @@ -0,0 +1,91 @@ +Version 1.1.5 +2013-03-21 +Fixes to changed default for eof-error-p suggested by Edi Weitz + +Version 1.1.4 +2013-03-20 +Trivial documentation fix + +Version 1.1.3 +2013-03-20 +Change default eof-error-p in READ-CHAR* to T (reported by Xu Jingtao) + +Version 1.1.2 +2012-12-09 +Fix bug in READ-NAME-VALUE-PAIR for cookie reading in Drakma + +Version 1.1.1 +2010-05-19 +Read quoted cookie values (Red Daly) + +Version 1.1.0 +2009-12-01 +Exported TOKEN-CHAR-P +Allowed START and END keyword arguments for TRIM-WHITESPACE +Simplified cookie value parsing + +Version 1.0.0 +2009-02-19 +Switched to binary streams underneath and got rid of FLEXI-STREAMS dependency +Added conditions +Exported (an improved version of) AS-KEYWORD +Added WITH-CHARACTER-STREAM-SEMANTICS + +Version 0.4.3 +2008-05-23 +Cleanup, reduce some consing + +Version 0.4.2 +2008-05-07 +Flush stream when switching chunking off (patch by Hans Hübner) + +Version 0.4.1 +2007-10-11 +Make Chunga work with AllegroCL's "modern" mode (patch by Ross Jekel) + +Version 0.4.0 +2007-09-18 +Added *TREAT-SEMICOLON-AS-CONTINUATION* + +Version 0.3.1 +2007-09-07 +Fixed bug in STREAM-LISTEN + +Version 0.3.0 +2007-05-08 +Added *ACCEPT-BOGUS-EOLS* (suggested by Sean Ross) + +Version 0.2.4 +2007-02-08 +Allow more characters in cookie names/values according to original Netscape spec +Robustified READ-COOKIE-VALUE + +Version 0.2.3 +2007-01-17 +Guard against stray semicolons when reading name/value pairs (thanks to B?lent Murtezaoglu) + +Version 0.2.2 +2007-01-10 +Faster vesion of READ-LINE* (provided by Gabor Melis) + +Version 0.2.1 +2006-10-26 +Added explicit element types for CLISP to fix problems reported by Anton Vodonosov + +Version 0.2.0 +2006-10-06 +Only wrap inner stream with flexi stream if really needed + +Version 0.1.2 +2006-09-05 +Exported CHUNKED-STREAM-STREAM +Mentioned Gentoo port in docs +Added info about mailing lists + +Version 0.1.1 +2006-09-02 +Added missing CRLF for output chunking + +Version 0.1.0 +2006-09-01 +First public release diff --git a/deps/chunga/chunga.asd b/deps/chunga/chunga.asd new file mode 100644 index 0000000..be6b778 --- /dev/null +++ b/deps/chunga/chunga.asd @@ -0,0 +1,42 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/chunga/chunga.asd,v 1.20 2008/05/24 18:38:30 edi Exp $ + +;;; Copyright (c) 2006-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. + +(asdf:defsystem :chunga + :serial t + :version "1.1.7" + :depends-on (:trivial-gray-streams) + :components ((:file "packages") + (:file "specials") + (:file "util") + (:file "known-words") + (:file "conditions") + (:file "read") + (:file "streams") + (:file "input") + (:file "output"))) diff --git a/deps/chunga/conditions.lisp b/deps/chunga/conditions.lisp new file mode 100644 index 0000000..c04a53a --- /dev/null +++ b/deps/chunga/conditions.lisp @@ -0,0 +1,84 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: ODD-STREAMS; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/odd-streams/conditions.lisp,v 1.5 2007/12/31 01:08:45 edi Exp $ + +;;; Copyright (c) 2008-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 :chunga) + +(define-condition chunga-condition (condition) + () + (:documentation "Superclass for all conditions related to Chunga.")) + +(define-condition chunga-error (chunga-condition stream-error) + () + (:documentation "Superclass for all errors related to Chunga. This +is a subtype of STREAM-ERROR, so STREAM-ERROR-STREAM can be used to +access the offending stream.")) + +(define-condition chunga-simple-error (chunga-error simple-condition) + () + (:documentation "Like CHUNGA-ERROR but with formatting capabilities.")) + +(define-condition parameter-error (chunga-simple-error) + () + (:documentation "Signalled if a function was called with +inconsistent or illegal parameters.")) + +(define-condition syntax-error (chunga-simple-error) + () + (:documentation "Signalled if Chunga encounters wrong or unknown +syntax when reading data.")) + +(define-condition chunga-warning (chunga-condition warning) + () + (:documentation "Superclass for all warnings related to Chunga.")) + +(define-condition chunga-simple-warning (chunga-warning simple-condition) + () + (:documentation "Like CHUNGA-WARNING but with formatting capabilities.")) + +(define-condition input-chunking-unexpected-end-of-file (chunga-error) + () + (:documentation "A condition of this type is signaled if we reach an +unexpected EOF on a chunked stream with input chunking enabled.")) + +(define-condition input-chunking-body-corrupted (chunga-error) + ((last-char :initarg :last-char + :documentation "The \(unexpected) character which was read.") + (expected-chars :initarg :expected-chars + :documentation "The characters which were expected. +A list of characters or one single character.")) + (:report (lambda (condition stream) + (with-slots (last-char expected-chars) + condition + (format stream "Chunked stream ~S seems to be corrupted. +Read character ~S, but expected ~:[a member of ~S~;~S~]." + (stream-error-stream condition) + last-char (atom expected-chars) expected-chars)))) + (:documentation "A condition of this type is signaled if an +unexpected character \(octet) is read while reading from a chunked +stream with input chunking enabled.")) diff --git a/deps/chunga/docs/index.html b/deps/chunga/docs/index.html new file mode 100644 index 0000000..4d66ad3 --- /dev/null +++ b/deps/chunga/docs/index.html @@ -0,0 +1,736 @@ + + + + + + CHUNGA - Portable chunked streams for Common Lisp + + + + + +

CHUNGA - Portable chunked streams for Common Lisp

+ +
+
 

Abstract

Chunga +implements streams capable of chunked encoding on demand as defined in +RFC 2616. For an example of how these streams can be used +see Drakma. +

+The library needs a Common Lisp implementation that +supports Gray +streams and relies on David +Lichteblau's trivial-gray-streams to offer portability between different Lisps. +

+Chunga is currently not optimized towards performance - it is +rather intended to be easy to use and (if possible) to behave correctly. +

+The code comes with +a BSD-style +license so you can basically do with it whatever you want. + +

+ Download current version + or visit the project on Github. +

+ +
 

Contents

+
    +
  1. Download and installation +
  2. Support +
  3. The Chunga dictionary +
      +
    1. Chunked streams +
        +
      1. chunked-stream +
      2. chunked-input-stream +
      3. chunked-output-stream +
      4. chunked-io-stream +
      5. make-chunked-stream +
      6. chunked-stream-stream +
      7. chunked-stream-input-chunking-p +
      8. chunked-stream-output-chunking-p +
      9. chunked-input-stream-extensions +
      10. chunked-input-stream-trailers +
      +
    2. Conditions +
        +
      1. chunga-condition +
      2. chunga-error +
      3. chunga-warning +
      4. syntax-error +
      5. parameter-error +
      6. input-chunking-body-corrupted +
      7. input-chunking-unexpected-end-of-file +
      +
    3. RFC 2616 parsing +
        +
      1. with-character-stream-semantics +
      2. read-line* +
      3. read-http-headers +
      4. token-char-p +
      5. read-token +
      6. read-name-value-pair +
      7. read-name-value-pairs +
      8. assert-char +
      9. skip-whitespace +
      10. read-char* +
      11. peek-char* +
      12. trim-whitespace +
      13. *current-error-message* +
      14. *accept-bogus-eols* +
      15. *treat-semicolon-as-continuation* +
      16. as-keyword +
      17. as-capitalized-string +
      +
    +
  4. Acknowledgements +
+ +
 

Download and installation

+ +Chunga together with this documentation can be downloaded +from Github. The +current version is 1.1.7. Chunga will only +work with Lisps where +the character +codes of +all Latin-1 +characters coincide with their +Unicode code +points (which is the case for all current implementations I know). +

+The esieast way to install Chunga is with Quicklisp +

+The current development version of Chunga can be found +at https://github.com/edicl/chunga. + +
 

Support

+ +The development version of chunga can be +found on +github. Please use the github issue tracking system to submit bug +reports. Patches are welcome, please +use GitHub pull +requests. + +
 

The Chunga dictionary

+ +

Chunked streams

+ +Chunked streams are the core of the Chunga library. You +create them using the +function MAKE-CHUNKED-STREAM which +takes an open binary stream (called the underlying stream) as its single argument. +A binary stream in this context means that if it's an input +stream, you can +apply READ-SEQUENCE +to it where the sequence is an array of element +type OCTET, and similarly for WRITE-SEQUENCE and output streams. (Note that this specifically holds for bivalent streams like socket streams.) +

+A chunked stream behaves like an ordinary Lisp stream +of element +type OCTET +with the addition that you can turn chunking on and off for +input as well as for output. With chunking turned on, data is read or +written according to +the definition in RFC +2616. + + + +


[Standard class]
chunked-stream +


+ +Every chunked stream returned by +MAKE-CHUNKED-STREAM is of this type which is a subtype of +STREAM. + +
+ + + + + + +


[Standard class]
chunked-input-stream +


+ +A chunked stream is of this type if its +underlying stream is an input +stream. This is a subtype of +CHUNKED-STREAM. + +
+ + + + + + + + +


[Standard class]
chunked-output-stream +


+ +A chunked stream is of this type if its +underlying stream is an output stream. This is a subtype of +CHUNKED-STREAM. + +
+ + + + + + +


[Standard class]
chunked-io-stream +


+ +A chunked stream is of this type if it is both +a CHUNKED-INPUT-STREAM as well as a CHUNKED-OUTPUT-STREAM. + +
+ + + + + +


[Function]
make-chunked-stream stream => chunked-stream +


+ +Creates and returns a chunked stream (a stream of type +CHUNKED-STREAM) which wraps stream. stream must be an open +binary stream. + +
+ + + + + + +


[Specialized reader]
chunked-stream-stream (stream chunked-stream) => underlying-stream +


+ +Returns the underlying stream of the chunked stream stream. + +
+ + + + + + +


[Generic reader]
chunked-stream-input-chunking-p object => generalized-boolean + +


+ +Returns a true value if object is of type CHUNKED-INPUT-STREAM and if input chunking is currently enabled. + +
+ +


[Specialized writer]
(setf (chunked-stream-input-chunking-p (stream chunked-input-stream)) new-value) + +


+ +This function is used to switch input chunking +on stream on or off. Note that input chunking will +usally be turned off automatically when the last chunk is read. + +
+ + + + + + + +


[Generic reader]
chunked-stream-output-chunking-p object => generalized-boolean + +


+ +Returns a true value if object is of type CHUNKED-OUTPUT-STREAM and if output chunking is currently enabled. + +
+ +


[Specialized writer]
(setf (chunked-stream-output-chunking-p (stream chunked-output-stream)) new-value) + +


+ +This function is used to switch output chunking +on stream on or off. + +
+ + + + + + + + +


[Specialized reader]
chunked-input-stream-extensions (stream chunked-input-stream) => extensions +


+ +Returns +an alist +of attribute/value pairs corresponding to the optional "chunk +extensions" which might have been encountered when reading +from stream. + +
+ + + + + + +


[Specialized reader]
chunked-input-stream-trailers (stream chunked-input-stream) => trailers +


+ +Returns the +optional "trailer" +HTTP headers which might have been sent after the last chunk, +i.e. directly before input chunking ended on stream. +The format of trailers is identical to that returned +by READ-HTTP-HEADERS. + +
+ + + + + + +

Conditions

+ +Here are conditions which might be signalled if something bad happens +with a chunked stream. + + + +


[Condition] +
chunga-condition + +


+All conditions signalled by Chunga are of this type. This is a subtype of CONDITION. +
+ + + + + +


[Error] +
chunga-error + +


+All errors signalled by Chunga are of this type. This is a subtype of CHUNGA-CONDITION and of +STREAM-ERROR, +so STREAM-ERROR-STREAM +can be used to access the offending stream. +
+ + + + + +


[Warning] +
chunga-warning + +


+All warnings signalled by Chunga are of this type. This is a subtype of CHUNGA-CONDITION and of WARNING. +
+ + + + + +


[Error] +
syntax-error + +


An error of this type is signalled if Chunga +encounters wrong or unknown syntax when reading data. This is a +subtype of CHUNGA-ERROR. +
+ + + + + +


[Error] +
parameter-error + +


An error of this type is signalled if a function was +called with inconsistent or illegal parameters. This is a subtype +of CHUNGA-ERROR. +
+ + + + + +


[Condition type]
input-chunking-body-corrupted +


+ +A condition of this type is signaled if an +unexpected character (octet) is read while reading from a +chunked stream with input chunking enabled. This is a subtype of +CHUNGA-ERROR. + +
+ + + + + + +


[Condition type]
input-chunking-unexpected-end-of-file +


+ +A condition of this type is signaled if we +reach an unexpected EOF on a chunked stream with input chunking +enabled. This is a subtype of +CHUNGA-ERROR. + +
+ + + + + + +

RFC 2616 parsing

+ +Chunga needs to know a bit +about RFC 2616 syntax in +order to cope +with extensions +and trailers. As these +functions are in there anyway, they're exported, so they can be used +by other code like for +example Drakma. +

+Note that all of these functions are designed to work +on binary +streams, specifically on streams with element +type (UNSIGNED-BYTE 8). They will not work +with character streams. (But the "bivalent" streams offered by many +Lisp implementations will do.) They must be called within the context +of WITH-CHARACTER-STREAM-SEMANTICS. + +


[Macro] +
with-character-stream-semantics statement* => result* +


+ +Executes the statement* forms in such a way that +functions within this section can read characters from binary streams +(treating octets as the Latin-1 characters with the corresponding code +points). All the functions below must be wrapped with this +macro. If your code uses several of these functions which interact on +the same stream, all of them must be wrapped with the same macro. See +the source code of Drakma +or Hunchentoot for examples +of how to use this macro. + +
+ + + +


[Function]
read-line* stream &optional log-stream => line +


+ +Reads and assembles characters from the binary stream stream until a carriage +return +is read. Makes sure that the following character is a linefeed. If +*ACCEPT-BOGUS-EOLS* is not NIL, then the function will also accept a +lone carriage return or linefeed as a line break. Returns +the string of characters read excluding the line break. Additionally +logs this string to log-stream if it is not NIL. +

+See WITH-CHARACTER-STREAM-SEMANTICS. + +

+ + + + + + +


[Function]
read-http-headers stream &optional log-stream => headers +


+ +Reads HTTP header lines from the binary stream stream +(except for the initial status line which is supposed to be read +already) and returns a +corresponding alist +of names and values where the names are keywords and the values are +strings. Multiple lines with the same name are combined into one +value, the individual values separated by commas. Header lines which +are spread across multiple lines are recognized and treated correctly. (But see *TREAT-SEMICOLON-AS-CONTINUATION*.) +Additonally logs the header lines to +log-stream if it is not NIL. +

+See WITH-CHARACTER-STREAM-SEMANTICS. + +

+ + + + + +


[Function]
read-token stream => token +


+ +Read characters from the binary stream stream while they +are token constituents (according +to RFC 2616). It is +assumed that there's a token character at the current position. The +token read is returned as a string. Doesn't signal an error (but +simply stops reading) +if END-OF-FILE +is encountered after the first character. +

+See WITH-CHARACTER-STREAM-SEMANTICS. + +

+ + + + + +


[Function]
token-char-p char => generalized-boolean +


+ +Returns a true value if the Lisp character char is a token constituent +according to +RFC 2616. + +
+ + + + + +


[Function]
read-name-value-pair stream &key value-required-p cookie-syntax => pair +


+ +Reads a typical (in RFC +2616) name/value or +attribute/value combination from the +binary stream stream - a token followed by +a #\= character and another token or a quoted +string. Returns +a cons +of the name and the value, both as strings. +If value-required-p is NIL (the +default is T), the #\= sign and the value +are optional. If cookie-syntax is true (the +default is NIL), the value is read like the value of +a cookie header. +

+See WITH-CHARACTER-STREAM-SEMANTICS. + +

+ + + + + + +


[Function]
read-name-value-pairs stream &key value-required-p cookie-syntax => pairs +


+ +Uses READ-NAME-VALUE-PAIR to read and return an alist of +name/value pairs from the binary stream stream. It is assumed that the pairs are +separated by semicolons and that the first char read (except for +whitespace) will be a semicolon. The parameters are used as in +READ-NAME-VALUE-PAIR. +Stops reading in case +of END-OF-FILE +(instead of signaling an error). +

+See WITH-CHARACTER-STREAM-SEMANTICS. + +

+ + + + + + + +


[Function]
assert-char stream expected-char => char +


+ +Reads the next character from the binary stream stream and checks if it is the +character expected-char. Signals an error otherwise. +

+See WITH-CHARACTER-STREAM-SEMANTICS. + +

+ + + + + + +


[Function]
skip-whitespace stream => char-or-nil +


+ +Consume characters from the binary stream stream until an END-OF-FILE is +encountered or a non-whitespace (according to RFC 2616) +characters is seen. This character is returned (or NIL in case +of END-OF-FILE). +

+See WITH-CHARACTER-STREAM-SEMANTICS. + +

+ + + + + + +


[Function]
read-char* stream => char +


+ +Reads and returns the next character from the binary stream stream. +

+See WITH-CHARACTER-STREAM-SEMANTICS. + +

+ + + + + + +


[Function]
peek-char* stream &optional eof-error-p eof-value => boolean +


+ +Returns a true value if a character can be read from the binary +stream stream. If eof-error-p +has a true value, an error is signalled if no character remains to be +read. eof-value specifies the value to return +if eof-error-p is false and the end of the file +has been reached. +

+See WITH-CHARACTER-STREAM-SEMANTICS. + +

+ + + + + + +


[Function]
trim-whitespace string &key start end => string' +


+ +Returns a version of the string string (between start and end) where spaces and tab +characters are trimmed from the start and the end. + +
+ + + + + + +


[Special variable]
*current-error-message* +


+ +Used by the parsing functions in this section as +an introduction to a standardized error message. Should be bound to a +string or NIL if one of these functions is called. + +
+ + + + + +


[Special variable]
*accept-bogus-eols* +


+ +Some web servers do not respond with a correct CRLF line ending for +HTTP headers but with a lone linefeed or carriage return instead. If +this variable is bound to a true +value, READ-LINE* will treat a +lone LF or CR character as an acceptable end of line. The initial +value is NIL. + +
+ + + + +


[Special variable]
*treat-semicolon-as-continuation* +


+ +According to John Foderaro, Netscape v3 web servers bogusly split +Set-Cookie headers over multiple lines which means that we'd have to +treat Set-Cookie headers ending with a semicolon as incomplete and +combine them with the next header. This will only be done if this +variable has a true value, though. Its default value is NIL. +
+ + + +


[Function]
as-keyword string &key destructivep => keyword +


+Converts the string string to a keyword where all characters are +uppercase or lowercase, taking into account the current readtable +case. Might destructively modify string if destructivep is true which +is the default. "Knows" several HTTP header names and methods and +is optimized to not call INTERN for these. +
+ +


[Function]
as-capitalized-string keyword => capitalized-string +


+Kind of the inverse of AS-KEYWORD. Has essentially the same effect +as STRING-CAPITALIZE but is optimized for "known" keywords like +:CONTENT-LENGTH or :GET. +
+ + +
 

Acknowledgements

+ +

+Thanks to Jochen Schmidt's chunking code in ACL-COMPAT for inspiration. +This documentation was prepared with DOCUMENTATION-TEMPLATE. +

+ + + diff --git a/deps/chunga/input.lisp b/deps/chunga/input.lisp new file mode 100644 index 0000000..bed1b13 --- /dev/null +++ b/deps/chunga/input.lisp @@ -0,0 +1,185 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CHUNGA; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/chunga/input.lisp,v 1.18 2008/05/24 03:06:22 edi Exp $ + +;;; Copyright (c) 2006-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 :chunga) + +(defmethod chunked-input-stream-extensions ((object t)) + "The default method which always returns the empty list." + nil) + +(defmethod chunked-input-stream-trailers ((object t)) + "The default method which always returns the empty list." + nil) + +(defmethod chunked-stream-input-chunking-p ((object t)) + "The default method for all objects which are not of type +CHUNKED-INPUT-STREAM." + nil) + +(defmethod (setf chunked-stream-input-chunking-p) (new-value (stream chunked-input-stream)) + "Switches input chunking for STREAM on or off." + (unless (eq (not new-value) (not (chunked-stream-input-chunking-p stream))) + (with-slots (input-limit input-index expecting-crlf-p chunk-extensions chunk-trailers) + stream + (cond (new-value + (setq expecting-crlf-p nil + input-limit 0 + input-index 0 + chunk-extensions nil + chunk-trailers nil)) + (t (when (< input-index input-limit) + (error 'parameter-error + :stream stream + :format-control "Not all chunks from ~S have been read completely." + :format-arguments (list stream))))))) + (setf (slot-value stream 'input-chunking-p) new-value)) + +(defmethod stream-clear-input ((stream chunked-input-stream)) + "Implements CLEAR-INPUT by resetting the internal chunk buffer." + (when (chunked-stream-input-chunking-p stream) + (setf (chunked-stream-input-index stream) 0 + (chunked-stream-input-limit stream) 0)) + ;; clear input on inner stream + (clear-input (chunked-stream-stream stream)) + nil) + +(defmethod chunked-input-available-p ((stream chunked-input-stream)) + "Whether there's unread input waiting in the chunk buffer." + (< (chunked-stream-input-index stream) + (chunked-stream-input-limit stream))) + +(defmethod stream-listen ((stream chunked-input-stream)) + "We first check if input chunking is enabled and if there's +something in the buffer. Otherwise we poll the underlying stream." + (cond ((chunked-stream-input-chunking-p stream) + (or (chunked-input-available-p stream) + (fill-buffer stream))) + (t (listen (chunked-stream-stream stream))))) + +(defmethod fill-buffer ((stream chunked-input-stream)) + "Re-fills the chunk buffer. Returns NIL if chunking has ended." + (let ((inner-stream (chunked-stream-stream stream)) + ;; set up error function for the functions in `read.lisp' + (*current-error-function* + (lambda (last-char expected-chars) + "The function which is called when an unexpected +character is seen. Signals INPUT-CHUNKING-BODY-CORRUPTED." + (error 'input-chunking-body-corrupted + :stream stream + :last-char last-char + :expected-chars expected-chars)))) + (labels ((add-extensions () + "Reads chunk extensions \(if there are any) and stores +them into the corresponding slot of the stream." + (when-let (extensions (read-name-value-pairs inner-stream)) + (warn 'chunga-warning + :stream stream + :format-control "Adding uninterpreted extensions to stream ~S." + :format-arguments (list stream)) + (setf (slot-value stream 'chunk-extensions) + (append (chunked-input-stream-extensions stream) extensions))) + (assert-crlf inner-stream)) + (get-chunk-size () + "Reads chunk size header \(including optional +extensions) and returns the size." + (with-character-stream-semantics + (when (expecting-crlf-p stream) + (assert-crlf inner-stream)) + (setf (expecting-crlf-p stream) t) + ;; read hexadecimal number + (let (last-char) + (prog1 (loop for weight = (digit-char-p (setq last-char (read-char* inner-stream)) + 16) + for result = (if weight + (+ weight (* 16 (or result 0))) + (return (or result + (error 'input-chunking-body-corrupted + :stream stream + :last-char last-char + :expected-chars +hex-digits+))))) + ;; unread first octet which wasn't a digit + (unread-char* last-char) + (add-extensions)))))) + (let ((chunk-size (get-chunk-size))) + (with-slots (input-buffer input-limit input-index) + stream + (setq input-index 0 + input-limit chunk-size) + (cond ((zerop chunk-size) + ;; turn chunking off + (setf (chunked-stream-input-chunking-p stream) nil + (slot-value stream 'chunk-trailers) (with-character-stream-semantics + (read-http-headers inner-stream)) + input-limit 0) + ;; return NIL + (return-from fill-buffer)) + ((> chunk-size (length input-buffer)) + ;; replace buffer if it isn't big enough for the next chunk + (setq input-buffer (make-array chunk-size :element-type '(unsigned-byte 8))))) + (unless (= (read-sequence input-buffer inner-stream :start 0 :end chunk-size) + chunk-size) + (error 'input-chunking-unexpected-end-of-file + :stream stream)) + chunk-size))))) + +(defmethod stream-read-byte ((stream chunked-input-stream)) + "Reads one byte from STREAM. Checks the chunk buffer first, if +input chunking is enabled. Re-fills buffer is necessary." + (unless (chunked-stream-input-chunking-p stream) + (return-from stream-read-byte (read-byte (chunked-stream-stream stream) nil :eof))) + (unless (chunked-input-available-p stream) + (unless (fill-buffer stream) + (return-from stream-read-byte :eof))) + (with-slots (input-buffer input-index) + stream + (prog1 (aref input-buffer input-index) + (incf input-index)))) + +(defmethod stream-read-sequence ((stream chunked-input-stream) sequence start end &key) + "Fills SEQUENCE by adding data from the chunk buffer and re-filling +it until enough data was read. Works directly on the underlying +stream if input chunking is off." + (unless (chunked-stream-input-chunking-p stream) + (return-from stream-read-sequence + (read-sequence sequence (chunked-stream-stream stream) :start start :end end))) + (loop + (when (>= start end) + (return-from stream-read-sequence start)) + (unless (chunked-input-available-p stream) + (unless (fill-buffer stream) + (return-from stream-read-sequence start))) + (with-slots (input-buffer input-limit input-index) + stream + (replace sequence input-buffer + :start1 start :end1 end + :start2 input-index :end2 input-limit) + (let ((length (min (- input-limit input-index) + (- end start)))) + (incf start length) + (incf input-index length))))) diff --git a/deps/chunga/known-words.lisp b/deps/chunga/known-words.lisp new file mode 100644 index 0000000..92b391d --- /dev/null +++ b/deps/chunga/known-words.lisp @@ -0,0 +1,152 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CHUNGA; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/chunga/known-words.lisp,v 1.3 2008/05/29 22:21:09 edi Exp $ + +;;; Copyright (c) 2006-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 :chunga) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (define-constant +known-words+ + '(;; headers including WebDAV and some de facto standard headers + "Accept" + "Accept-Charset" + "Accept-Encoding" + "Accept-Language" + "Accept-Ranges" + "Age" + "Allow" + "Authorization" + "Cache-Control" + "Connection" + "Content-Encoding" + "Content-Language" + "Content-Length" + "Content-Location" + "Content-MD5" + "Content-Range" + "Content-Type" + "DAV" + "Date" + "Depth" + "Destination" + "ETag" + "Expect" + "Expires" + "From" + "Host" + "If" + "If-Match" + "If-Modified-Since" + "If-None-Match" + "If-Range" + "If-Unmodified-Since" + "Last-Modified" + "Location" + "Lock-Token" + "Max-Forwards" + "Overwrite" + "Pragma" + "Proxy-Authenticate" + "Proxy-Authorization" + "Range" + "Referer" + "Retry-After" + "Server" + "TE" + "TimeOut" + "Trailer" + "Transfer-Encoding" + "Upgrade" + "User-Agent" + "Vary" + "Via" + "WWW-Authenticate" + "Warning" + ;; methods including WebDAV + "CONNECT" + "COPY" + "DELETE" + "GET" + "HEAD" + "LOCK" + "MKCOL" + "MOVE" + "OPTIONS" + "POST" + "PROPFIND" + "PROPPATCH" + "PUT" + "TRACE" + "UNLOCK" + ;; protocols + "HTTP/1.1" + "HTTP/1.0" + ;; only a few and only the "preferred MIME names" - see + ;; for a + ;; complete list + "US-ASCII" + "ISO-8859-1" + "UTF-8" + "UTF-16" + "UTF-32BE" + "UTF-32LE") + "A list of words \(headers, methods, protocols, character sets) +that are typically seen in HTTP communication. Mostly from RFC 2616, +but includes WebDAV stuff and other things as well.")) + +(define-constant +string-to-keyword-hash+ + (let ((hash (make-hash-table :test 'equal :size (length +known-words+)))) + (loop for word in +known-words+ + do (setf (gethash word hash) (make-keyword word nil))) + hash) + "A hash table which case-insensitively maps the strings from ++KNOWN-WORDS+ to keywords.") + +(define-constant +keyword-to-string-hash+ + (let ((hash (make-hash-table :test 'eq :size (length +known-words+)))) + (loop for word in +known-words+ + do (setf (gethash (make-keyword word nil) hash) + (string-capitalize word))) + hash) + "A hash table which maps keywords derived from +KNOWN-WORDS+ to +capitalized strings.") + +(defun as-keyword (string &key (destructivep t)) + "Converts the string STRING to a keyword where all characters are +uppercase or lowercase, taking into account the current readtable +case. Might destructively modify STRING if DESTRUCTIVEP is true which +is the default. \"Knows\" several HTTP header names and methods and +is optimized to not call INTERN for these." + (or (gethash string +string-to-keyword-hash+) + (make-keyword string destructivep))) + +(defun as-capitalized-string (keyword) + "Kind of the inverse of AS-KEYWORD. Has essentially the same effect +as STRING-CAPITALIZE but is optimized for \"known\" keywords like +:CONTENT-LENGTH or :GET." + (or (gethash keyword +keyword-to-string-hash+) + (string-capitalize keyword))) diff --git a/deps/chunga/output.lisp b/deps/chunga/output.lisp new file mode 100644 index 0000000..6029aa6 --- /dev/null +++ b/deps/chunga/output.lisp @@ -0,0 +1,137 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CHUNGA; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/chunga/output.lisp,v 1.14 2008/05/24 03:06:22 edi Exp $ + +;;; Copyright (c) 2006-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 :chunga) + +(defmethod chunked-stream-output-chunking-p ((object t)) + "The default method for all objects which are not of type +CHUNKED-OUTPUT-STREAM." + nil) + +(defmethod write-chunk ((stream chunked-output-stream) sequence + &key (start 0) + (end (length sequence))) + "Writes the contents of SEQUENCE from START to END to the +underlying stream of STREAM as one chunk." + (let ((output-stream (chunked-stream-stream stream))) + ;; chunk size + (loop for char across (format nil "~X" (- end start)) + do (write-byte (char-code char) output-stream)) + (write-sequence +crlf+ output-stream) + ;; data + (write-sequence sequence output-stream :start start :end end) + (write-sequence +crlf+ output-stream))) + +(defmethod flush-buffer ((stream chunked-output-stream)) + "Uses WRITE-CHUNK to empty the output buffer unless it is +already empty." + (with-slots (output-buffer output-index) + stream + (when (plusp output-index) + (write-chunk stream output-buffer :end output-index) + (setq output-index 0)))) + +(defmethod (setf chunked-stream-output-chunking-p) (new-value (stream chunked-output-stream)) + "Switches output chunking for STREAM on or off." + (unless (eq (not new-value) (not (chunked-stream-output-chunking-p stream))) + (with-slots (real-stream output-index) + stream + (cond (new-value + ;; get rid of "old" data + (force-output real-stream) + ;; initialize output buffer as being empty + (setq output-index 0)) + (t (flush-buffer stream) + ;; last chunk to signal end of chunking + (write-byte #.(char-code #\0) real-stream) + (write-sequence +crlf+ real-stream) + (write-sequence +crlf+ real-stream) + (force-output real-stream))))) + (setf (slot-value stream 'output-chunking-p) new-value)) + +(defmethod stream-clear-output ((stream chunked-output-stream)) + "We clear output by resetting the output buffer and clearing +the underlying stream." + (when (chunked-stream-output-chunking-p stream) + (setf (slot-value stream 'output-index) 0)) + (clear-output (chunked-stream-stream stream))) + +(defmethod stream-finish-output ((stream chunked-output-stream)) + "Flush the output buffer if output chunking is on, then operate +on the underlying stream." + (when (chunked-stream-output-chunking-p stream) + (flush-buffer stream)) + (finish-output (chunked-stream-stream stream))) + +(defmethod stream-force-output ((stream chunked-output-stream)) + "Flush the output buffer if output chunking is on, then operate +on the underlying stream." + (when (chunked-stream-output-chunking-p stream) + (flush-buffer stream)) + (force-output (chunked-stream-stream stream))) + +(defmethod stream-write-byte ((stream chunked-output-stream) byte) + "Writes one byte by simply adding it to the end of the output +buffer \(if output chunking is enabled). The buffer is flushed +if necessary." + (unless (chunked-stream-output-chunking-p stream) + (return-from stream-write-byte + (write-byte byte (chunked-stream-stream stream)))) + (with-slots (output-index output-buffer) + stream + (when (>= output-index +output-buffer-size+) + (flush-buffer stream)) + (setf (aref output-buffer output-index) byte) + (incf output-index) + byte)) + +(defmethod stream-write-sequence ((stream chunked-output-stream) sequence start end &key) + "Outputs SEQUENCE by appending it to the output buffer if it's +small enough. Large sequences are written directly using +WRITE-CHUNK." + (unless (chunked-stream-output-chunking-p stream) + (return-from stream-write-sequence + (write-sequence sequence (chunked-stream-stream stream) :start start :end end))) + (with-slots (output-buffer output-index) + stream + (let ((length (- end start))) + (cond ((<= length (- +output-buffer-size+ output-index)) + (replace output-buffer sequence :start1 output-index + :start2 start :end2 end) + (incf output-index length)) + (t (flush-buffer stream) + (write-chunk stream sequence :start start :end end))))) + sequence) + +(defmethod close ((stream chunked-output-stream) &key abort) + "When a stream is closed and ABORT isn't true we have to make +sure to send the last chunk." + (unless abort + (setf (chunked-stream-output-chunking-p stream) nil)) + (call-next-method)) diff --git a/deps/chunga/packages.lisp b/deps/chunga/packages.lisp new file mode 100644 index 0000000..b2afd3d --- /dev/null +++ b/deps/chunga/packages.lisp @@ -0,0 +1,68 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/chunga/packages.lisp,v 1.19 2008/05/24 18:38:30 edi Exp $ + +;;; Copyright (c) 2006-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 :chunga + (:use :cl :trivial-gray-streams) + #+:lispworks + (:import-from :lw :when-let) + (:export :*accept-bogus-eols* + :*current-error-message* + :*treat-semicolon-as-continuation* + :assert-char + :as-keyword + :as-capitalized-string + :chunga-error + :chunga-warning + :chunked-input-stream + :chunked-input-stream-extensions + :chunked-input-stream-trailers + :chunked-io-stream + :chunked-output-stream + :chunked-stream + :chunked-stream-input-chunking-p + :chunked-stream-output-chunking-p + :chunked-stream-stream + :input-chunking-body-corrupted + :input-chunking-unexpected-end-of-file + :make-chunked-stream + :read-http-headers + :peek-char* + :read-char* + :read-line* + :read-name-value-pair + :read-name-value-pairs + :read-token + :skip-whitespace + :syntax-error + :token-char-p + :trim-whitespace + :with-character-stream-semantics)) + diff --git a/deps/chunga/read.lisp b/deps/chunga/read.lisp new file mode 100644 index 0000000..83c63bc --- /dev/null +++ b/deps/chunga/read.lisp @@ -0,0 +1,293 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CHUNGA; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/chunga/read.lisp,v 1.22 2008/05/26 08:18:00 edi Exp $ + +;;; Copyright (c) 2006-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 :chunga) + +(defun signal-unexpected-chars (stream last-char expected-chars) + "Signals an error that LAST-CHAR was read although one of +EXPECTED-CHARS was expected. \(Note that EXPECTED-CHARS, despite its +name, can also be a single character instead of a list). Calls +*CURRENT-ERROR-FUNCTION* if it's not NIL, or uses +*CURRENT-ERROR-MESSAGE* otherwise." + (cond (*current-error-function* + (funcall *current-error-function* last-char expected-chars)) + (t + (error 'syntax-error + :stream stream + :format-control "~@[~A~%~]~:[End of file~;Read character ~:*~S~], ~ +but expected ~:[a member of ~S~;~S~]." + :format-arguments (list *current-error-message* + last-char + (atom expected-chars) + expected-chars))))) + +(defun charp (char) + "Returns true if the Lisp character CHAR is a CHAR according to RFC 2616." + (<= 0 (char-code char) 127)) + +(defun controlp (char) + "Returns true if the Lisp character CHAR is a CTL according to RFC 2616." + (or (<= 0 (char-code char) 31) + (= (char-code char) 127))) + +(defun separatorp (char) + "Returns true if the Lisp character CHAR is a separator +according to RFC 2616." + (find char #.(format nil " ()<>@,;:\\\"/[]?={}~C" #\Tab) + :test #'char=)) + +(defun whitespacep (char) + "Returns true if the Lisp character CHAR is whitespace +according to RFC 2616." + (member char '(#\Space #\Tab) :test #'char=)) + +(defun token-char-p (char) + "Returns true if the Lisp character CHAR is a token constituent +according to RFC 2616." + (and (charp char) + (not (or (controlp char) + (separatorp char))))) + +(defun assert-char (stream expected-char) + "Reads the next character from STREAM and checks if it is the +character EXPECTED-CHAR. Signals an error otherwise." + (let ((char (read-char* stream))) + (unless (char= char expected-char) + (signal-unexpected-chars stream char expected-char)) + char)) + +(defun assert-crlf (stream) + "Reads the next two characters from STREAM and checks if these +are a carriage return and a linefeed. Signals an error +otherwise." + (assert-char stream #\Return) + (assert-char stream #\Linefeed)) + +(defun read-line* (stream &optional log-stream) + "Reads and assembles characters from the binary stream STREAM until +a carriage return is read. Makes sure that the following character is +a linefeed. If *ACCEPT-BOGUS-EOLS* is not NIL, then the function will +also accept a lone carriage return or linefeed as an acceptable line +break. Returns the string of characters read excluding the line +break. Returns NIL if input ends before one character was read. +Additionally logs this string to LOG-STREAM if it is not NIL." + (let ((result + (with-output-to-string (line) + (loop for char-seen-p = nil then t + for char = (read-char* stream nil) + for is-cr-p = (and char (char= char #\Return)) + until (or (null char) + is-cr-p + (and *accept-bogus-eols* + (char= char #\Linefeed))) + do (write-char char line) + finally (cond ((and (not char-seen-p) + (null char)) + (return-from read-line* nil)) + ((not *accept-bogus-eols*) + (assert-char stream #\Linefeed)) + (is-cr-p + (when (eql (peek-char* stream) #\Linefeed) + (read-char* stream)))))))) + (when log-stream + (write-line result log-stream) + (finish-output log-stream)) + result)) + +(defun trim-whitespace (string &key (start 0) (end (length string))) + "Returns a version of the string STRING \(between START and END) +where spaces and tab characters are trimmed from the start and the +end. Might return STRING." + ;; optimized version to replace STRING-TRIM, suggested by Jason Kantz + (declare (optimize + speed + (space 0) + (debug 1) + (compilation-speed 0) + #+:lispworks (hcl:fixnum-safety 0))) + (declare (string string)) + (let* ((start% (loop for i of-type fixnum from start below end + while (or (char= #\space (char string i)) + (char= #\tab (char string i))) + finally (return i))) + (end% (loop for i of-type fixnum downfrom (1- end) to start + while (or (char= #\space (char string i)) + (char= #\tab (char string i))) + finally (return (1+ i))))) + (declare (fixnum start% end%)) + (cond ((and (zerop start%) (= end% (length string))) string) + ((> start% end%) "") + (t (subseq string start% end%))))) + +(defun read-http-headers (stream &optional log-stream) + "Reads HTTP header lines from STREAM \(except for the initial +status line which is supposed to be read already) and returns a +corresponding alist of names and values where the names are +keywords and the values are strings. Multiple lines with the +same name are combined into one value, the individual values +separated by commas. Header lines which are spread across +multiple lines are recognized and treated correctly. Additonally +logs the header lines to LOG-STREAM if it is not NIL." + (let (headers + (*current-error-message* "While reading HTTP headers:")) + (labels ((read-header-line () + "Reads one header line, considering continuations." + (with-output-to-string (header-line) + (loop + (let ((line (trim-whitespace (read-line* stream log-stream)))) + (when (zerop (length line)) + (return)) + (write-sequence line header-line) + (let ((next (peek-char* stream))) + (unless (whitespacep next) + (return))) + ;; we've seen whitespace starting a continutation, + ;; so we loop + (write-char #\Space header-line))))) + (split-header (line) + "Splits line at colon and converts it into a cons. +Returns NIL if LINE consists solely of whitespace." + (unless (zerop (length (trim-whitespace line))) + (let ((colon-pos (or (position #\: line :test #'char=) + (error 'syntax-error + :stream stream + :format-control "Couldn't find colon in header line ~S." + :format-arguments (list line))))) + (cons (as-keyword (subseq line 0 colon-pos)) + (trim-whitespace (subseq line (1+ colon-pos))))))) + (add-header (pair) + "Adds the name/value cons PAIR to HEADERS. Takes +care of multiple headers with the same name." + (let* ((name (car pair)) + (existing-header (assoc name headers :test #'eq)) + (existing-value (cdr existing-header))) + (cond (existing-header + (setf (cdr existing-header) + (format nil "~A~:[,~;~]~A" + existing-value + (and *treat-semicolon-as-continuation* + (eq name :set-cookie) + (ends-with-p (trim-whitespace existing-value) ";")) + (cdr pair)))) + (t (push pair headers)))))) + (loop for header-pair = (split-header (read-header-line)) + while header-pair + do (add-header header-pair))) + (nreverse headers))) + +(defun skip-whitespace (stream) + "Consume characters from STREAM until an END-OF-FILE is +encountered or a non-whitespace \(according to RFC 2616) +characters is seen. This character is returned \(or NIL in case +of END-OF-FILE)." + (loop for char = (peek-char* stream nil) + while (and char (whitespacep char)) + do (read-char* stream) + finally (return char))) + +(defun read-token (stream) + "Read characters from STREAM while they are token constituents +\(according to RFC 2616). It is assumed that there's a token +character at the current position. The token read is returned as +a string. Doesn't signal an error \(but simply stops reading) if +END-OF-FILE is encountered after the first character." + (with-output-to-string (out) + (loop for first = t then nil + for char = (if first + (peek-char* stream) + (or (peek-char* stream nil) (return))) + while (token-char-p char) + do (write-char (read-char* stream) out)))) + +(defun read-quoted-string (stream) + "Reads a quoted string \(according to RFC 2616). It is assumed +that the character at the current position is the opening quote +character. Returns the string read without quotes and escape +characters." + (read-char* stream) + (with-output-to-string (out) + (loop for char = (read-char* stream) + until (char= char #\") + do (case char + (#\\ (write-char (read-char* stream) out)) + (#\Return (assert-char stream #\Linefeed) + (let ((char (read-char* stream))) + (unless (whitespacep char) + (signal-unexpected-chars stream char '(#\Space #\Tab))))) + (otherwise (write-char char out)))))) + +(defun read-cookie-value (stream &key (separators ";")) + "Reads a cookie parameter value from STREAM which is returned as a +string. Simply reads until a semicolon is seen \(or an element of +SEPARATORS). Also reads quoted strings if the first non-whitespace +character is a quotation mark \(as in RFC 2109)." + (if (char= #\" (peek-char* stream)) + (read-quoted-string stream) + (trim-whitespace + (with-output-to-string (out) + (loop for char = (peek-char* stream nil) + until (or (null char) (find char separators :test #'char=)) + do (write-char (read-char* stream) out)))))) + +(defun read-name-value-pair (stream &key (value-required-p t) cookie-syntax) + "Reads a typical \(in RFC 2616) name/value or attribute/value +combination from STREAM - a token followed by a #\\= character and +another token or a quoted string. Returns a cons of name and value, +both as strings. If VALUE-REQUIRED-P is NIL, the #\\= sign and the +value are optional. If COOKIE-SYNTAX is true, uses READ-COOKIE-VALUE +internally." + (skip-whitespace stream) + (let ((name (if cookie-syntax + (read-cookie-value stream :separators "=;") + (read-token stream)))) + (skip-whitespace stream) + (cons name + (when (or value-required-p + (eql (peek-char* stream nil) #\=)) + (assert-char stream #\=) + (skip-whitespace stream) + (cond (cookie-syntax (read-cookie-value stream)) + ((char= (peek-char* stream) #\") (read-quoted-string stream)) + (t (read-token stream))))))) + +(defun read-name-value-pairs (stream &key (value-required-p t) cookie-syntax) + "Uses READ-NAME-VALUE-PAIR to read and return an alist of +name/value pairs from STREAM. It is assumed that the pairs are +separated by semicolons and that the first char read \(except for +whitespace) will be a semicolon. The parameters are used as in +READ-NAME-VALUE-PAIR. Stops reading in case of END-OF-FILE +\(instead of signaling an error)." + (loop for char = (skip-whitespace stream) + while (and char (char= char #\;)) + do (read-char* stream) + ;; guard against a stray semicolon at the end + when (skip-whitespace stream) + collect (read-name-value-pair stream + :value-required-p value-required-p + :cookie-syntax cookie-syntax))) diff --git a/deps/chunga/specials.lisp b/deps/chunga/specials.lisp new file mode 100644 index 0000000..02c75d6 --- /dev/null +++ b/deps/chunga/specials.lisp @@ -0,0 +1,100 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CHUNGA; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/chunga/specials.lisp,v 1.12 2008/05/24 03:06:22 edi Exp $ + +;;; Copyright (c) 2006-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 :chunga) + +(defmacro define-constant (name value &optional doc) + "A version of DEFCONSTANT for, cough, /strict/ CL implementations." + ;; See + `(defconstant ,name (if (boundp ',name) (symbol-value ',name) ,value) + ,@(when doc (list doc)))) + +#+:lispworks +(editor:setup-indent "define-constant" 1 2 4) + +(defconstant +output-buffer-size+ 8192 + "Size of the initial output buffer for chunked output.") + +(define-constant +crlf+ + (make-array 2 :element-type '(unsigned-byte 8) + :initial-contents (mapcar 'char-code '(#\Return #\Linefeed))) + "A 2-element array consisting of the character codes for a CRLF +sequence.") + +(define-constant +hex-digits+ '#.(coerce "0123456789ABCDEF" 'list) + "The hexadecimal digits.") + +(defvar *current-error-message* nil + "Used by the parsing functions in `read.lisp' as an +introduction to a standardized error message about unexpected +characters unless it is NIL.") + +(defvar *current-error-function* nil + "Used by the functions in `read.lisp' as a function to signal +errors about unexpected characters when *CURRENT-ERROR-MESSAGE* +is NIL.") + +(defvar *accept-bogus-eols* nil + "Some web servers do not respond with a correct CRLF line ending for +HTTP headers but with a lone linefeed or carriage return instead. If +this variable is bound to a true value, READ-LINE* will treat a lone +LF or CR character as an acceptable end of line. The initial value is +NIL.") + +(defvar *treat-semicolon-as-continuation* nil + "According to John Foderaro, Netscape v3 web servers bogusly split +Set-Cookie headers over multiple lines which means that we'd have to +treat Set-Cookie headers ending with a semicolon as incomplete and +combine them with the next header. This will only be done if this +variable has a true value, though.") + +(defvar *char-buffer* nil + "A `buffer' for one character. Used by PEEK-CHAR* and +UNREAD-CHAR*.") + +(pushnew :chunga *features*) + +;; stuff for Nikodemus Siivola's HYPERDOC +;; see +;; and +;; also used by LW-ADD-ONS + +(defvar *hyperdoc-base-uri* "http://weitz.de/chunga/") + +(let ((exported-symbols-alist + (loop for symbol being the external-symbols of :chunga + collect (cons symbol + (concatenate 'string + "#" + (string-downcase symbol)))))) + (defun hyperdoc-lookup (symbol type) + (declare (ignore type)) + (cdr (assoc symbol + exported-symbols-alist + :test #'eq)))) diff --git a/deps/chunga/streams.lisp b/deps/chunga/streams.lisp new file mode 100644 index 0000000..280867d --- /dev/null +++ b/deps/chunga/streams.lisp @@ -0,0 +1,131 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CHUNGA; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/chunga/streams.lisp,v 1.10 2008/05/24 03:06:22 edi Exp $ + +;;; Copyright (c) 2006-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 :chunga) + +(defclass chunked-stream (trivial-gray-stream-mixin) + ((real-stream :initarg :real-stream + :reader chunked-stream-stream + :documentation "The actual stream that's used for +input and/or output.")) + (:documentation "Every chunked stream returned by +MAKE-CHUNKED-STREAM is of this type which is a subtype of +STREAM.")) + +(defclass chunked-input-stream (chunked-stream fundamental-binary-input-stream) + ((input-chunking-p :initform nil + :reader chunked-stream-input-chunking-p + :documentation "Whether input chunking is currently enabled.") + (input-buffer :initform nil + :documentation "A vector containing the binary +data from the most recent chunk that was read.") + (input-index :initform 0 + :accessor chunked-stream-input-index + :documentation "The current position within INPUT-BUFFER.") + (input-limit :initform 0 + :accessor chunked-stream-input-limit + :documentation "Only the content in INPUT-BUFFER +up to INPUT-LIMIT belongs to the current chunk.") + (chunk-extensions :initform nil + :reader chunked-input-stream-extensions + :documentation "An alist of attribute/value +pairs corresponding to the optional `chunk extensions' which +might be encountered when reading from a chunked stream.") + (chunk-trailers :initform nil + :reader chunked-input-stream-trailers + :documentation "An alist of attribute/value +pairs corresponding to the optional `trailer' HTTP headers which +might be encountered at the end of a chunked stream.") + (expecting-crlf-p :initform nil + :accessor expecting-crlf-p + :documentation "Whether we expect to see +CRLF before we can read the next chunk-size header part from the +stream. \(This will actually be the CRLF from the end of the +last chunk-data part.)")) + (:documentation "A chunked stream is of this type if its +underlying stream is an input stream. This is a subtype of +CHUNKED-STREAM.")) + +(defclass chunked-output-stream (chunked-stream fundamental-binary-output-stream) + ((output-chunking-p :initform nil + :reader chunked-stream-output-chunking-p + :documentation "Whether output chunking is +currently enabled.") + (output-buffer :initform (make-array +output-buffer-size+ :element-type '(unsigned-byte 8)) + :accessor output-buffer + :documentation "A vector used to temporarily +store data which will output in one chunk.") + (output-index :initform 0 + :accessor output-index + :documentation "The current end of OUTPUT-BUFFER.")) + (:documentation "A chunked stream is of this type if its +underlying stream is an output stream. This is a subtype of +CHUNKED-STREAM.")) + +(defclass chunked-io-stream (chunked-input-stream chunked-output-stream) + () + (:documentation "A chunked stream is of this type if it is both +a CHUNKED-INPUT-STREAM as well as a CHUNKED-OUTPUT-STREAM.")) + +(defmethod stream-element-type ((stream chunked-stream)) + "Chunked streams are always binary streams. Wrap them with +flexi streams if you need a character stream." + '(unsigned-byte 8)) + +(defmethod open-stream-p ((stream chunked-stream)) + "A chunked stream is open if its underlying stream is open." + (open-stream-p (chunked-stream-stream stream))) + +(defmethod close ((stream chunked-stream) &key abort) + "If a chunked stream is closed, we close the underlying stream as well." + (with-slots (real-stream) + stream + (cond ((open-stream-p real-stream) + (close real-stream :abort abort)) + (t nil)))) + +(defun make-chunked-stream (stream) + "Creates and returns a chunked stream \(a stream of type +CHUNKED-STREAM) which wraps STREAM. STREAM must be an open +binary stream." + (unless (and (streamp stream) + (open-stream-p stream)) + (error 'parameter-error + :stream stream + :format-control "~S should have been an open stream." + :format-arguments (list stream))) + (make-instance ;; actual type depends on STREAM + (cond ((and (input-stream-p stream) + (output-stream-p stream)) + 'chunked-io-stream) + ((input-stream-p stream) + 'chunked-input-stream) + ((output-stream-p stream) + 'chunked-output-stream)) + :real-stream stream)) \ No newline at end of file diff --git a/deps/chunga/util.lisp b/deps/chunga/util.lisp new file mode 100644 index 0000000..50e789d --- /dev/null +++ b/deps/chunga/util.lisp @@ -0,0 +1,93 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CHUNGA; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/chunga/util.lisp,v 1.12 2008/05/25 10:53:48 edi Exp $ + +;;; Copyright (c) 2006-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 :chunga) + +#-:lispworks +(defmacro when-let ((var expr) &body body) + "Evaluates EXPR, binds it to VAR, and executes BODY if VAR has +a true value." + `(let ((,var ,expr)) + (when ,var ,@body))) + +(defun ends-with-p (seq suffix &key (test #'char-equal)) + "Returns true if the sequence SEQ ends with the sequence +SUFFIX. Individual elements are compared with TEST." + (let ((mismatch (mismatch seq suffix :from-end t :test test))) + (or (null mismatch) + (= mismatch (- (length seq) (length suffix)))))) + +(defun make-keyword (string destructivep) + "Converts the string STRING to a keyword where all characters are +uppercase or lowercase, taking into account the current readtable +case. Destructively modifies STRING if DESTRUCTIVEP is true." + (intern (funcall + (if destructivep + (if (eq (readtable-case *readtable*) :upcase) + #'nstring-upcase + #'nstring-downcase) + (if (eq (readtable-case *readtable*) :upcase) + #'string-upcase + #'string-downcase)) + string) + :keyword)) + +(defun read-char* (stream &optional (eof-error-p t) eof-value) + "The streams we're dealing with are all binary with element type +\(UNSIGNED-BYTE 8) and we're only interested in ISO-8859-1, so we use +this to `simulate' READ-CHAR." + (cond (*char-buffer* + (prog1 *char-buffer* + (setq *char-buffer* nil))) + (t + ;; this assumes that character codes are identical to Unicode code + ;; points, at least for Latin1 + (let ((char-code (read-byte stream eof-error-p eof-value))) + (and char-code + (code-char char-code)))))) + +(defun unread-char* (char) + "Were simulating UNREAD-CHAR by putting the character into +*CHAR-BUFFER*." + ;; no error checking, only used internally + (setq *char-buffer* char) + nil) + +(defun peek-char* (stream &optional eof-error-p eof-value) + "We're simulating PEEK-CHAR by reading a character and putting it +into *CHAR-BUFFER*." + ;; no error checking, only used internally + (setq *char-buffer* (read-char* stream eof-error-p eof-value))) + +(defmacro with-character-stream-semantics (&body body) + "Binds *CHAR-BUFFER* around BODY so that within BODY we can use +READ-CHAR* and friends \(see above) to simulate a character stream +although we're reading from a binary stream." + `(let ((*char-buffer* nil)) + ,@body)) diff --git a/deps/cl-base64/.gitignore b/deps/cl-base64/.gitignore new file mode 100644 index 0000000..3413a58 --- /dev/null +++ b/deps/cl-base64/.gitignore @@ -0,0 +1,10 @@ +.bin +*.fasl* +*.dfsl +*.pfsl +*.ufsl +*.fas +*.x86f +*.sparcf +*.cfsl +*.fsl diff --git a/deps/cl-base64/COPYING b/deps/cl-base64/COPYING new file mode 100644 index 0000000..acae269 --- /dev/null +++ b/deps/cl-base64/COPYING @@ -0,0 +1,26 @@ +Copyright (c) 2002-2003 by Kevin Rosenberg + +All rights reserved. + +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. +3. The name of the Authors may not be used to endorse or promote products + derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``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 REGENTS OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR +BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE +OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN +IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/deps/cl-base64/cl-base64.asd b/deps/cl-base64/cl-base64.asd new file mode 100644 index 0000000..252389d --- /dev/null +++ b/deps/cl-base64/cl-base64.asd @@ -0,0 +1,44 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: cl-base64.asd +;;;; Purpose: ASDF definition file for Cl-Base64 +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Dec 2002 +;;;; +;;;; $Id$ +;;;; ************************************************************************* + +(in-package #:cl-user) +(defpackage #:cl-base64-system (:use #:asdf #:cl)) +(in-package #:cl-base64-system) + + +(defsystem cl-base64 + :name "cl-base64" + :author "Kevin M. Rosenberg based on initial code by Juri Pakaste" + :version "3.1" + :maintainer "Kevin M. Rosenberg " + :licence "BSD-style" + :description "Base64 encoding and decoding with URI support." + :components + ((:file "package") + (:file "encode" :depends-on ("package")) + (:file "decode" :depends-on ("package")) + )) + +(defmethod perform ((o test-op) (c (eql (find-system 'cl-base64)))) + (operate 'load-op 'cl-base64-tests) + (operate 'test-op 'cl-base64-tests :force t)) + +(defsystem cl-base64-tests + :depends-on (cl-base64 ptester kmrcl) + :components + ((:file "tests"))) + +(defmethod perform ((o test-op) (c (eql (find-system 'cl-base64-tests)))) + (operate 'load-op 'cl-base64-tests) + (or (funcall (intern (symbol-name '#:do-tests) + (find-package '#:cl-base64-tests))) + (error "test-op failed"))) diff --git a/deps/cl-base64/debian/changelog b/deps/cl-base64/debian/changelog new file mode 100644 index 0000000..7005d25 --- /dev/null +++ b/deps/cl-base64/debian/changelog @@ -0,0 +1,140 @@ +cl-base64 (3.3.3-2) unstable; urgency=low + + * Convert installation to dh-lisp + * control: Add Vcs-Browser field + + -- Kevin M. Rosenberg Mon, 03 Aug 2009 10:31:33 -0600 + +cl-base64 (3.3.3-1) unstable; urgency=low + + * New upstream + * Convert to debhelper version 7 + * debian/watch: New file + * debian/control: Change section to new lisp section. Add Vcs-Git + and Homepage fields. + * debian/rules: Change to just architecture independent rules and DH7 + * debian/{prerm,postinst}: Remove paths from binary function + + -- Kevin M. Rosenberg Sat, 01 Aug 2009 23:19:43 -0600 + +cl-base64 (3.3.2-1) unstable; urgency=low + + * Depend on kmrcl only for test package + + -- Kevin M. Rosenberg Sun, 27 Aug 2006 12:23:37 -0600 + +cl-base64 (3.3.1-5) unstable; urgency=low + + * Fix spelling mistake in package description (closes:363204) + + -- Kevin M. Rosenberg Mon, 15 May 2006 17:41:36 -0600 + +cl-base64 (3.3.1-4) unstable; urgency=low + + * New upstream URI + + -- Kevin M. Rosenberg Sat, 17 Sep 2005 15:34:55 -0600 + +cl-base64 (3.3.1-3) unstable; urgency=low + + * Fix package name in postinst/prerm + + -- Kevin M. Rosenberg Thu, 22 Apr 2004 08:53:34 -0600 + +cl-base64 (3.3.1-2) unstable; urgency=low + + * Rename package rules file (closes:244687) + + -- Kevin M. Rosenberg Mon, 19 Apr 2004 08:59:58 -0600 + +cl-base64 (3.3.1-1) unstable; urgency=low + + * Rename ASDF system to cl-base64 + + -- Kevin M. Rosenberg Sun, 18 Apr 2004 10:39:51 -0600 + +cl-base64 (3.3-1) unstable; urgency=low + + * Rework test loading + + -- Kevin M. Rosenberg Sun, 24 Aug 2003 13:40:03 -0600 + +cl-base64 (3.2.1-1) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg Thu, 12 Jun 2003 08:04:55 -0600 + +cl-base64 (3.2-1) unstable; urgency=low + + * Improve .asd file + + -- Kevin M. Rosenberg Tue, 6 May 2003 10:19:22 -0600 + +cl-base64 (3.1-1) unstable; urgency=low + + * Implement asdf:test-op. Remove old base64-test.asd file. + + -- Kevin M. Rosenberg Tue, 15 Apr 2003 09:33:01 -0600 + +cl-base64 (3.0.2-1) unstable; urgency=low + + * Change declarations from array to simple-array where feasible + * add more fixnum declarations where helpful + + -- Kevin M. Rosenberg Tue, 14 Jan 2003 04:55:48 -0700 + +cl-base64 (3.0.1-1) unstable; urgency=low + + * Fix output of base64-string-to-usb8-array + + -- Kevin M. Rosenberg Tue, 14 Jan 2003 04:35:05 -0700 + +cl-base64 (3.0.0-1) unstable; urgency=low + + * Remove src.lisp and add package.lisp, decode.lisp, encode.lisp + * Add support for usb8-arrays + * Rewrite routines as macros to create efficient functions for + converting to and from streams, strings, and usb8-arrays. + * Fix error in integer-to-base64 when using columns + * Add base64-test.asd and test.lisp regression suite + + -- Kevin M. Rosenberg Mon, 13 Jan 2003 14:41:52 -0700 + +cl-base64 (2.1.0-1) unstable; urgency=low + + * Fix broken string-to-base64 + + -- Kevin M. Rosenberg Sat, 4 Jan 2003 06:40:32 -0700 + +cl-base64 (2.0-1) unstable; urgency=low + + * Ignore whitespace in base64 strings + * Add column breaking and stream output to base64 conversion + * Rework string-to-base64 to handle columns and streams + + -- Kevin M. Rosenberg Fri, 3 Jan 2003 23:14:13 -0700 + +cl-base64 (1.2-1) unstable; urgency=low + + * Bug fix in base64-to-integer + + -- Kevin M. Rosenberg Sun, 29 Dec 2002 00:03:11 -0700 + +cl-base64 (1.1-1) unstable; urgency=low + + * Rewritten version, significant optimizations + * BSD-style license + * Adds conversion to and from integers + * Renamed functions + + -- Kevin M. Rosenberg Sat, 28 Dec 2002 21:28:42 -0700 + +cl-base64 (1.0-1) unstable; urgency=low + + * Initial upload + * Changes compared to upstream: + - Added .asd file for use with Common Lisp Controller + - Changes for Allegro's case sensitive mode + + -- Kevin M. Rosenberg Thu, 26 Dec 2002 19:17:51 -0700 diff --git a/deps/cl-base64/debian/compat b/deps/cl-base64/debian/compat new file mode 100644 index 0000000..7f8f011 --- /dev/null +++ b/deps/cl-base64/debian/compat @@ -0,0 +1 @@ +7 diff --git a/deps/cl-base64/debian/control b/deps/cl-base64/debian/control new file mode 100644 index 0000000..5fdd6e3 --- /dev/null +++ b/deps/cl-base64/debian/control @@ -0,0 +1,19 @@ +Source: cl-base64 +Section: lisp +Priority: optional +Maintainer: Kevin M. Rosenberg +Build-Depends-Indep: dh-lisp +Build-Depends: debhelper (>= 7.0.0) +Standards-Version: 3.8.2.0 +Homepage: http://files.b9.com/cl-base64/ +Vcs-Git: git://git.b9.com/cl-base64.git +Vcs-Browser: http://git.b9.com/?p=cl-base64.git + +Package: cl-base64 +Architecture: all +Depends: ${misc:Depends}, cl-kmrcl +Description: Common Lisp package to encode and decode base64 with URI support + This package provides highly optimized base64 encoding and decoding. + Besides conversion to and from strings, integer conversions are supported. + Encoding with Uniform Resource Identifiers is supported by using + a modified encoding table that uses only URI-compatible characters. diff --git a/deps/cl-base64/debian/copyright b/deps/cl-base64/debian/copyright new file mode 100644 index 0000000..4a44dc0 --- /dev/null +++ b/deps/cl-base64/debian/copyright @@ -0,0 +1,39 @@ +This package was debianized by Kevin M. Rosenberg in +Dec 2002. + +It was downloaded from http://files.b9.com/base64/ + +Upstream Author: Kevin M. Rosenberg + This code is based on code placed in the public domain by Juri Pakaste + and available for download at + http://www.helsinki.fi/~pakaste/store/dl/base64.lisp + +Copyright: + +Copyright (c) 2002-2003 by Kevin Rosenberg + +All rights reserved. + +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. +3. The name of the Authors may not be used to endorse or promote products + derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``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 REGENTS OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR +BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE +OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN +IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + diff --git a/deps/cl-base64/debian/rules b/deps/cl-base64/debian/rules new file mode 100755 index 0000000..dba8214 --- /dev/null +++ b/deps/cl-base64/debian/rules @@ -0,0 +1,44 @@ +#!/usr/bin/make -f + +pkg := cl-base64 +debpkg := cl-base64 + +clc-source := usr/share/common-lisp/source +clc-systems := usr/share/common-lisp/systems +clc-files := $(clc-source)/$(pkg) +doc-dir := usr/share/doc/$(debpkg) + +build: + +clean: + dh_testdir + dh_testroot + dh_clean + +install: build + dh_testdir + dh_testroot + dh_prep + dh_installdirs + dh_install $(pkg).asd $(clc-files) + dh_install *.lisp $(clc-files) + +binary-indep: install + dh_testdir + dh_testroot + dh_installchangelogs + dh_installdocs + dh_lisp + dh_compress + dh_fixperms + dh_installdeb + dh_gencontrol + dh_md5sums + dh_builddeb + +binary-arch: + +binary: binary-indep + + +.PHONY: build clean binary-indep binary-arch binary install diff --git a/deps/cl-base64/debian/upload.sh b/deps/cl-base64/debian/upload.sh new file mode 100755 index 0000000..ad50ce2 --- /dev/null +++ b/deps/cl-base64/debian/upload.sh @@ -0,0 +1,3 @@ +#!/bin/bash -e + +dup cl-base64 -Ufiles.b9.com -D/home/ftp/cl-base64 -C"(umask 022; /home/kevin/bin/remove-old-versions cl-base64 latest)" -su $* diff --git a/deps/cl-base64/debian/watch b/deps/cl-base64/debian/watch new file mode 100644 index 0000000..7d41af4 --- /dev/null +++ b/deps/cl-base64/debian/watch @@ -0,0 +1,2 @@ +version=3 +http://files.b9.com/cl-base64/cl-base64-(\d+.*)\.tar\.gz diff --git a/deps/cl-base64/decode.lisp b/deps/cl-base64/decode.lisp new file mode 100644 index 0000000..1649daa --- /dev/null +++ b/deps/cl-base64/decode.lisp @@ -0,0 +1,256 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: encode.lisp +;;;; Purpose: cl-base64 encoding routines +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Dec 2002 +;;;; +;;;; $Id$ +;;;; +;;;; This file implements the Base64 transfer encoding algorithm as +;;;; defined in RFC 1521 by Borensten & Freed, September 1993. +;;;; See: http://www.ietf.org/rfc/rfc1521.txt +;;;; +;;;; Based on initial public domain code by Juri Pakaste +;;;; +;;;; Copyright 2002-2003 Kevin M. Rosenberg +;;;; Permission to use with BSD-style license included in the COPYING file +;;;; ************************************************************************* + +(in-package #:cl-base64) + +(declaim (inline whitespace-p)) +(defun whitespace-p (c) + "Returns T for a whitespace character." + (or (char= c #\Newline) (char= c #\Linefeed) + (char= c #\Return) (char= c #\Space) + (char= c #\Tab))) + + +;;; Decoding + +#+ignore +(defmacro def-base64-stream-to-* (output-type) + `(defun ,(intern (concatenate 'string (symbol-name :base64-stream-to-) + (symbol-name output-type))) + (input &key (uri nil) + ,@(when (eq output-type :stream) + '(stream))) + ,(concatenate 'string "Decode base64 stream to " (string-downcase + (symbol-name output-type))) + (declare (stream input) + (optimize (speed 3) (space 0) (safety 0))) + (let ((pad (if uri *uri-pad-char* *pad-char*)) + (decode-table (if uri *uri-decode-table* *decode-table*))) + (declare (type decode-table decode-table) + (type character pad)) + (let (,@(case output-type + (:string + '((result (make-string (* 3 (truncate (length string) 4)))))) + (:usb8-array + '((result (make-array (* 3 (truncate (length string) 4)) + :element-type '(unsigned-byte 8) + :fill-pointer nil + :adjustable nil))))) + (ridx 0)) + (declare ,@(case output-type + (:string + '((simple-string result))) + (:usb8-array + '((type (simple-array (usigned-byte 8) (*)) result)))) + (fixnum ridx)) + (do* ((bitstore 0) + (bitcount 0) + (char (read-char stream nil #\null) + (read-char stream nil #\null))) + ((eq char #\null) + ,(case output-type + (:stream + 'stream) + ((:string :usb8-array) + 'result) + ;; ((:stream :string) + ;; '(subseq result 0 ridx)))) + )) + (declare (fixnum bitstore bitcount) + (character char)) + (let ((svalue (aref decode-table (the fixnum (char-code char))))) + (declare (fixnum svalue)) + (cond + ((>= svalue 0) + (setf bitstore (logior + (the fixnum (ash bitstore 6)) + svalue)) + (incf bitcount 6) + (when (>= bitcount 8) + (decf bitcount 8) + (let ((ovalue (the fixnum + (logand + (the fixnum + (ash bitstore + (the fixnum (- bitcount)))) + #xFF)))) + (declare (fixnum ovalue)) + ,(case output-type + (:string + '(setf (char result ridx) (code-char ovalue))) + (:usb8-array + '(setf (aref result ridx) ovalue)) + (:stream + '(write-char (code-char ovalue) stream))) + (incf ridx) + (setf bitstore (the fixnum (logand bitstore #xFF)))))) + ((char= char pad) + ;; Could add checks to make sure padding is correct + ;; Currently, padding is ignored + ) + ((whitespace-p char) + ;; Ignore whitespace + ) + ((minusp svalue) + (warn "Bad character ~W in base64 decode" char)) + ))))))) + +;;(def-base64-stream-to-* :string) +;;(def-base64-stream-to-* :stream) +;;(def-base64-stream-to-* :usb8-array) + +(defmacro def-base64-string-to-* (output-type) + `(defun ,(intern (concatenate 'string (symbol-name :base64-string-to-) + (symbol-name output-type))) + (input &key (uri nil) + ,@(when (eq output-type :stream) + '(stream))) + ,(concatenate 'string "Decode base64 string to " (string-downcase + (symbol-name output-type))) + (declare (string input) + (optimize (speed 3) (safety 0) (space 0))) + (let ((pad (if uri *uri-pad-char* *pad-char*)) + (decode-table (if uri *uri-decode-table* *decode-table*))) + (declare (type decode-table decode-table) + (type character pad)) + (let (,@(case output-type + (:string + '((result (make-string (* 3 (truncate (length input) 4)))))) + (:usb8-array + '((result (make-array (* 3 (truncate (length input) 4)) + :element-type '(unsigned-byte 8) + :fill-pointer nil + :adjustable nil))))) + (ridx 0)) + (declare ,@(case output-type + (:string + '((simple-string result))) + (:usb8-array + '((type (simple-array (unsigned-byte 8) (*)) result)))) + (fixnum ridx)) + (loop + for char of-type character across input + for svalue of-type fixnum = (aref decode-table + (the fixnum (char-code char))) + with bitstore of-type fixnum = 0 + with bitcount of-type fixnum = 0 + do + (cond + ((>= svalue 0) + (setf bitstore (logior + (the fixnum (ash bitstore 6)) + svalue)) + (incf bitcount 6) + (when (>= bitcount 8) + (decf bitcount 8) + (let ((ovalue (the fixnum + (logand + (the fixnum + (ash bitstore + (the fixnum (- bitcount)))) + #xFF)))) + (declare (fixnum ovalue)) + ,(case output-type + (:string + '(setf (char result ridx) (code-char ovalue))) + (:usb8-array + '(setf (aref result ridx) ovalue)) + (:stream + '(write-char (code-char ovalue) stream))) + (incf ridx) + (setf bitstore (the fixnum (logand bitstore #xFF)))))) + ((char= char pad) + ;; Could add checks to make sure padding is correct + ;; Currently, padding is ignored + ) + ((whitespace-p char) + ;; Ignore whitespace + ) + ((minusp svalue) + (warn "Bad character ~W in base64 decode" char)) + )) + ,(case output-type + (:stream + 'stream) + ((:usb8-array :string) + '(subseq result 0 ridx))))))) + +(def-base64-string-to-* :string) +(def-base64-string-to-* :stream) +(def-base64-string-to-* :usb8-array) + +;; input-mode can be :string or :stream +;; input-format can be :character or :usb8 + +(defun base64-string-to-integer (string &key (uri nil)) + "Decodes a base64 string to an integer" + (declare (string string) + (optimize (speed 3) (safety 0) (space 0))) + (let ((pad (if uri *uri-pad-char* *pad-char*)) + (decode-table (if uri *uri-decode-table* *decode-table*))) + (declare (type decode-table decode-table) + (character pad)) + (let ((value 0)) + (declare (integer value)) + (loop + for char of-type character across string + for svalue of-type fixnum = + (aref decode-table (the fixnum (char-code char))) + do + (cond + ((>= svalue 0) + (setq value (+ svalue (ash value 6)))) + ((char= char pad) + (setq value (ash value -2))) + ((whitespace-p char) + ; ignore whitespace + ) + ((minusp svalue) + (warn "Bad character ~W in base64 decode" char)))) + value))) + + +(defun base64-stream-to-integer (stream &key (uri nil)) + "Decodes a base64 string to an integer" + (declare (stream stream) + (optimize (speed 3) (space 0) (safety 0))) + (let ((pad (if uri *uri-pad-char* *pad-char*)) + (decode-table (if uri *uri-decode-table* *decode-table*))) + (declare (type decode-table decode-table) + (character pad)) + (do* ((value 0) + (char (read-char stream nil #\null) + (read-char stream nil #\null))) + ((eq char #\null) + value) + (declare (integer value) + (character char)) + (let ((svalue (aref decode-table (the fixnum (char-code char))))) + (declare (fixnum svalue)) + (cond + ((>= svalue 0) + (setq value (+ svalue (ash value 6)))) + ((char= char pad) + (setq value (ash value -2))) + ((whitespace-p char) ; ignore whitespace + ) + ((minusp svalue) + (warn "Bad character ~W in base64 decode" char))))))) diff --git a/deps/cl-base64/encode.lisp b/deps/cl-base64/encode.lisp new file mode 100644 index 0000000..dcddc1a --- /dev/null +++ b/deps/cl-base64/encode.lisp @@ -0,0 +1,322 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: encode.lisp +;;;; Purpose: cl-base64 encoding routines +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Dec 2002 +;;;; +;;;; $Id$ +;;;; +;;;; This file implements the Base64 transfer encoding algorithm as +;;;; defined in RFC 1521 by Borensten & Freed, September 1993. +;;;; See: http://www.ietf.org/rfc/rfc1521.txt +;;;; +;;;; Based on initial public domain code by Juri Pakaste +;;;; +;;;; Copyright 2002-2003 Kevin M. Rosenberg +;;;; Permission to use with BSD-style license included in the COPYING file +;;;; ************************************************************************* + +;;;; Extended by Kevin M. Rosenberg : +;;;; - .asd file +;;;; - numerous speed optimizations +;;;; - conversion to and from integers +;;;; - Renamed functions now that supporting integer conversions +;;;; - URI-compatible encoding using :uri key +;;;; +;;;; $Id$ + +(in-package #:cl-base64) + +(defun round-next-multiple (x n) + "Round x up to the next highest multiple of n." + (declare (fixnum n) + (optimize (speed 3) (safety 0) (space 0))) + (let ((remainder (mod x n))) + (declare (fixnum remainder)) + (if (zerop remainder) + x + (the fixnum (+ x (the fixnum (- n remainder))))))) + +(defmacro def-*-to-base64-* (input-type output-type) + `(defun ,(intern (concatenate 'string (symbol-name input-type) + (symbol-name :-to-base64-) + (symbol-name output-type))) + (input + ,@(when (eq output-type :stream) + '(output)) + &key (uri nil) (columns 0)) + "Encode a string array to base64. If columns is > 0, designates +maximum number of columns in a line and the string will be terminated +with a #\Newline." + (declare ,@(case input-type + (:string + '((string input))) + (:usb8-array + '((type (array (unsigned-byte 8) (*)) input)))) + (fixnum columns) + (optimize (speed 3) (safety 0) (space 0))) + (let ((pad (if uri *uri-pad-char* *pad-char*)) + (encode-table (if uri *uri-encode-table* *encode-table*))) + (declare (simple-string encode-table) + (character pad)) + (let* ((string-length (length input)) + (complete-group-count (truncate string-length 3)) + (remainder (nth-value 1 (truncate string-length 3))) + (padded-length (* 4 (truncate (+ string-length 2) 3))) + ,@(when (eq output-type :string) + '((num-lines (if (plusp columns) + (truncate (+ padded-length (1- columns)) columns) + 0)) + (num-breaks (if (plusp num-lines) + (1- num-lines) + 0)) + (strlen (+ padded-length num-breaks)) + (result (make-string strlen)) + (ioutput 0))) + (col (if (plusp columns) + 0 + (the fixnum (1+ padded-length))))) + (declare (fixnum string-length padded-length col + ,@(when (eq output-type :string) + '(ioutput))) + ,@(when (eq output-type :string) + '((simple-string result)))) + (labels ((output-char (ch) + (if (= col columns) + (progn + ,@(case output-type + (:stream + '((write-char #\Newline output))) + (:string + '((setf (schar result ioutput) #\Newline) + (incf ioutput)))) + (setq col 1)) + (incf col)) + ,@(case output-type + (:stream + '((write-char ch output))) + (:string + '((setf (schar result ioutput) ch) + (incf ioutput))))) + (output-group (svalue chars) + (declare (fixnum svalue chars)) + (output-char + (schar encode-table + (the fixnum + (logand #x3f + (the fixnum (ash svalue -18)))))) + (output-char + (schar encode-table + (the fixnum + (logand #x3f + (the fixnum (ash svalue -12)))))) + (if (> chars 2) + (output-char + (schar encode-table + (the fixnum + (logand #x3f + (the fixnum (ash svalue -6)))))) + (output-char pad)) + (if (> chars 3) + (output-char + (schar encode-table + (the fixnum + (logand #x3f svalue)))) + (output-char pad)))) + (do ((igroup 0 (the fixnum (1+ igroup))) + (isource 0 (the fixnum (+ isource 3)))) + ((= igroup complete-group-count) + (cond + ((= remainder 2) + (output-group + (the fixnum + (+ + (the fixnum + (ash + ,(case input-type + (:string + '(char-code (the character (char input isource)))) + (:usb8-array + '(the fixnum (aref input isource)))) + 16)) + (the fixnum + (ash + ,(case input-type + (:string + '(char-code (the character (char input + (the fixnum (1+ isource)))))) + (:usb8-array + '(the fixnum (aref input (the fixnum + (1+ isource)))))) + 8)))) + 3)) + ((= remainder 1) + (output-group + (the fixnum + (ash + ,(case input-type + (:string + '(char-code (the character (char input isource)))) + (:usb8-array + '(the fixnum (aref input isource)))) + 16)) + 2))) + ,(case output-type + (:string + 'result) + (:stream + 'output))) + (declare (fixnum igroup isource)) + (output-group + (the fixnum + (+ + (the fixnum + (ash + (the fixnum + ,(case input-type + (:string + '(char-code (the character (char input isource)))) + (:usb8-array + '(aref input isource)))) + 16)) + (the fixnum + (ash + (the fixnum + ,(case input-type + (:string + '(char-code (the character (char input + (the fixnum (1+ isource)))))) + (:usb8-array + '(aref input (1+ isource))))) + 8)) + (the fixnum + ,(case input-type + (:string + '(char-code (the character (char input + (the fixnum (+ 2 isource)))))) + (:usb8-array + '(aref input (+ 2 isource)))) + ))) + 4))))))) + +(def-*-to-base64-* :string :string) +(def-*-to-base64-* :string :stream) +(def-*-to-base64-* :usb8-array :string) +(def-*-to-base64-* :usb8-array :stream) + + +(defun integer-to-base64-string (input &key (uri nil) (columns 0)) + "Encode an integer to base64 format." + (declare (integer input) + (fixnum columns) + (optimize (speed 3) (space 0) (safety 0))) + (let ((pad (if uri *uri-pad-char* *pad-char*)) + (encode-table (if uri *uri-encode-table* *encode-table*))) + (declare (simple-string encode-table) + (character pad)) + (let* ((input-bits (integer-length input)) + (byte-bits (round-next-multiple input-bits 8)) + (padded-bits (round-next-multiple byte-bits 6)) + (remainder-padding (mod padded-bits 24)) + (padding-bits (if (zerop remainder-padding) + 0 + (- 24 remainder-padding))) + (padding-chars (/ padding-bits 6)) + (padded-length (/ (+ padded-bits padding-bits) 6)) + (last-line-len (if (plusp columns) + (- padded-length (* columns + (truncate + padded-length columns))) + 0)) + (num-lines (if (plusp columns) + (truncate (+ padded-length (1- columns)) columns) + 0)) + (num-breaks (if (plusp num-lines) + (1- num-lines) + 0)) + (strlen (+ padded-length num-breaks)) + (last-char (1- strlen)) + (str (make-string strlen)) + (col (if (zerop last-line-len) + columns + last-line-len))) + (declare (fixnum padded-length num-lines col last-char + padding-chars last-line-len)) + (unless (plusp columns) + (setq col -1)) ;; set to flag to optimize in loop + + (dotimes (i padding-chars) + (declare (fixnum i)) + (setf (schar str (the fixnum (- last-char i))) pad)) + + (do* ((strpos (- last-char padding-chars) (1- strpos)) + (int (ash input (/ padding-bits 3)))) + ((minusp strpos) + str) + (declare (fixnum strpos) (integer int)) + (cond + ((zerop col) + (setf (schar str strpos) #\Newline) + (setq col columns)) + (t + (setf (schar str strpos) + (schar encode-table (the fixnum (logand int #x3f)))) + (setq int (ash int -6)) + (decf col))))))) + +(defun integer-to-base64-stream (input stream &key (uri nil) (columns 0)) + "Encode an integer to base64 format." + (declare (integer input) + (fixnum columns) + (optimize (speed 3) (space 0) (safety 0))) + (let ((pad (if uri *uri-pad-char* *pad-char*)) + (encode-table (if uri *uri-encode-table* *encode-table*))) + (declare (simple-string encode-table) + (character pad)) + (let* ((input-bits (integer-length input)) + (byte-bits (round-next-multiple input-bits 8)) + (padded-bits (round-next-multiple byte-bits 6)) + (remainder-padding (mod padded-bits 24)) + (padding-bits (if (zerop remainder-padding) + 0 + (- 24 remainder-padding))) + (padding-chars (/ padding-bits 6)) + (padded-length (/ (+ padded-bits padding-bits) 6)) + (strlen padded-length) + (nonpad-chars (- strlen padding-chars)) + (last-nonpad-char (1- nonpad-chars)) + (str (make-string strlen))) + (declare (fixnum padded-length last-nonpad-char)) + (do* ((strpos 0 (the fixnum (1+ strpos))) + (int (ash input (/ padding-bits 3)) (ash int -6)) + (6bit-value (the fixnum (logand int #x3f)) + (the fixnum (logand int #x3f)))) + ((= strpos nonpad-chars) + (let ((col 0)) + (declare (fixnum col)) + (dotimes (i nonpad-chars) + (declare (fixnum i)) + (write-char (schar str i) stream) + (when (plusp columns) + (incf col) + (when (= col columns) + (write-char #\Newline stream) + (setq col 0)))) + (dotimes (ipad padding-chars) + (declare (fixnum ipad)) + (write-char pad stream) + (when (plusp columns) + (incf col) + (when (= col columns) + (write-char #\Newline stream) + (setq col 0))))) + stream) + (declare (fixnum 6bit-value strpos) + (integer int)) + (setf (schar str (- last-nonpad-char strpos)) + (schar encode-table 6bit-value)) + )))) + diff --git a/deps/cl-base64/package.lisp b/deps/cl-base64/package.lisp new file mode 100644 index 0000000..5eac241 --- /dev/null +++ b/deps/cl-base64/package.lisp @@ -0,0 +1,71 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: package.lisp +;;;; Purpose: Package definition for cl-base64 +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Dec 2002 +;;;; +;;;; $Id$ +;;;; +;;;; ************************************************************************* + +(defpackage #:cl-base64 + (:nicknames #:base64) + (:use #:cl) + (:export #:base64-stream-to-integer + #:base64-string-to-integer + #:base64-string-to-string + #:base64-stream-to-string + #:base64-string-to-stream + #:base64-stream-to-stream + #:base64-string-to-usb8-array + #:base64-stream-to-usb8-array + #:string-to-base64-string + #:string-to-base64-stream + #:usb8-array-to-base64-string + #:usb8-array-to-base64-stream + #:stream-to-base64-string + #:stream-to-base64-stream + #:integer-to-base64-string + #:integer-to-base64-stream + + ;; For creating custom encode/decode tables + #:*uri-encode-table* + #:*uri-decode-table* + #:make-decode-table + + #:test-base64 + )) + +(in-package #:cl-base64) + + +(defvar *encode-table* + "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/") +(declaim (type simple-string *encode-table*)) + +(defvar *uri-encode-table* + "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_") +(declaim (type simple-string *uri-encode-table*)) + +(deftype decode-table () '(simple-array fixnum (256))) + +(defun make-decode-table (encode-table) + (let ((dt (make-array 256 :adjustable nil :fill-pointer nil + :element-type 'fixnum + :initial-element -1))) + (declare (type decode-table dt)) + (loop for char of-type character across encode-table + for index of-type fixnum from 0 below 64 + do (setf (aref dt (the fixnum (char-code char))) index)) + dt)) + +(defvar *decode-table* (make-decode-table *encode-table*)) + +(defvar *uri-decode-table* (make-decode-table *uri-encode-table*)) + +(defvar *pad-char* #\=) +(defvar *uri-pad-char* #\.) +(declaim (type character *pad-char* *uri-pad-char*)) diff --git a/deps/cl-base64/tests.lisp b/deps/cl-base64/tests.lisp new file mode 100644 index 0000000..927e4b8 --- /dev/null +++ b/deps/cl-base64/tests.lisp @@ -0,0 +1,79 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: test.lisp +;;;; Purpose: Regression tests for cl-base64 +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Jan 2003 +;;;; +;;;; $Id$ +;;;; ************************************************************************* + +(in-package #:cl-user) + +(defpackage #:cl-base64-tests + (:use #:cl #:kmrcl #:cl-base64 #:ptester)) + +(in-package #:cl-base64-tests) + +(defun do-tests () + (with-tests (:name "cl-base64 tests") + (let ((*break-on-test-failures* t)) + (do* ((length 0 (+ 3 length)) + (string (make-string length) (make-string length)) + (usb8 (make-usb8-array length) (make-usb8-array length)) + (integer (random (expt 10 length)) (random (expt 10 length)))) + ((>= length 300)) + (dotimes (i length) + (declare (fixnum i)) + (let ((code (random 256))) + (setf (schar string i) (code-char code)) + (setf (aref usb8 i) code))) + + (do* ((columns 0 (+ columns 4))) + ((> columns length)) + ;; Test against cl-base64 routines + (test integer (base64-string-to-integer + (integer-to-base64-string integer :columns columns))) + (test string (base64-string-to-string + (string-to-base64-string string :columns columns)) + :test #'string=) + + ;; Test against AllegroCL built-in routines + #+allegro + (progn + (test integer (excl:base64-string-to-integer + (integer-to-base64-string integer :columns columns))) + (test integer (base64-string-to-integer + (excl:integer-to-base64-string integer))) + (test (string-to-base64-string string :columns columns) + (excl:usb8-array-to-base64-string usb8 + (if (zerop columns) + nil + columns)) + :test #'string=) + (test string (base64-string-to-string + (excl:usb8-array-to-base64-string + usb8 + (if (zerop columns) + nil + columns))) + :test #'string=)))))) + t) + + +(defun time-routines () + (let* ((str "abcdefghijklmnopqwertyu1234589jhwf2ff") + (usb8 (string-to-usb8-array str)) + (int 12345678901234567890) + (n 50000)) + (time-iterations n (integer-to-base64-string int)) + (time-iterations n (string-to-base64-string str)) + #+allego + (progn + (time-iterations n (excl:integer-to-base64-string int)) + (time-iterations n (excl:usb8-array-to-base64-string usb8))))) + + +;;#+run-test (test-base64) diff --git a/deps/cl-fad/CHANGELOG b/deps/cl-fad/CHANGELOG new file mode 100644 index 0000000..aa4b15e --- /dev/null +++ b/deps/cl-fad/CHANGELOG @@ -0,0 +1,111 @@ +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 diff --git a/deps/cl-fad/LICENSE b/deps/cl-fad/LICENSE new file mode 100644 index 0000000..1ca070d --- /dev/null +++ b/deps/cl-fad/LICENSE @@ -0,0 +1,26 @@ +;;; 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. diff --git a/deps/cl-fad/README b/deps/cl-fad/README new file mode 100644 index 0000000..099d514 --- /dev/null +++ b/deps/cl-fad/README @@ -0,0 +1,34 @@ +Complete documentation for CL-FAD can be found in the 'doc' +directory. + +CL-FAD also supports Nikodemus Siivola's HYPERDOC, see + and +. + +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). diff --git a/deps/cl-fad/cl-fad.asd b/deps/cl-fad/cl-fad.asd new file mode 100644 index 0000000..aafcd67 --- /dev/null +++ b/deps/cl-fad/cl-fad.asd @@ -0,0 +1,49 @@ +;;; -*- 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)) diff --git a/deps/cl-fad/cl-fad.system b/deps/cl-fad/cl-fad.system new file mode 100644 index 0000000..de147f8 --- /dev/null +++ b/deps/cl-fad/cl-fad.system @@ -0,0 +1,48 @@ +;;; -*- 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")))) diff --git a/deps/cl-fad/corman.lisp b/deps/cl-fad/corman.lisp new file mode 100644 index 0000000..fa9e90d --- /dev/null +++ b/deps/cl-fad/corman.lisp @@ -0,0 +1,86 @@ +;;; -*- 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) diff --git a/deps/cl-fad/doc/index.html b/deps/cl-fad/doc/index.html new file mode 100644 index 0000000..e5667eb --- /dev/null +++ b/deps/cl-fad/doc/index.html @@ -0,0 +1,700 @@ + + + + + + CL-FAD - A portable pathname library for Common Lisp + + + + + +

CL-FAD - A portable pathname library for Common Lisp

+ +
+
 

Abstract

+ +CL-FAD (for "Files and +Directories") 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 Practical Common Lisp. + +

+ +CL-FAD comes with a BSD-style +license so you can basically do with it whatever you want. + +

+Download shortcut: http://weitz.de/files/cl-fad.tar.gz. +

+ +
 

Contents

+
    +
  1. Download and installation +
  2. Supported Lisp implementations +
  3. The CL-FAD dictionary +
      +
    1. Querying files, directories and pathnames +
        +
      1. directory-exists-p [function] +
      2. directory-pathname-p [function] +
      3. file-exists-p [function] +
      4. pathname-absolute-p [function] +
      5. pathname-equal [function] +
      6. pathname-relative-p [function] +
      7. pathname-root-p [function] +
      2. +
    2. Manipulating pathnames +
        +
      1. canonical-pathname [function] +
      2. merge-pathnames-as-directory [function] +
      3. merge-pathnames-as-file [function] +
      4. pathname-as-directory [function] +
      5. pathname-as-file [function] +
      6. pathname-directory-pathname [function] +
      7. pathname-parent-directory [function] +
      3. +
    3. Traversing directories +
        +
      1. list-directory [function] +
      2. walk-directory [function] +
      4. +
    4. Temporary Files +
        +
      1. open-temporary [function] +
      2. with-output-to-temporary-file [macro] +
      3. with-open-temporary-file [macro] +
      4. *default-template* [variable] +
      5. cannot-create-temporary-file [condition] +
      6. invalid-temporary-pathname-template [condition] +
      7. missing-temp-environment-variable [condition] +
      8. temporary-files [logical pathname host] +
      +
      5. +
    5. Modifying the file system +
        +
      1. copy-file [function] +
      2. copy-stream [function] +
      3. delete-directory-and-files [function] +
      6. +
    6. path [package] +
    +
  4. Acknowledgements +
+ + + +
 

Download and installation

+ +CL-FAD together with this documentation can be downloaded from http://weitz.de/files/cl-fad.tar.gz. The +current version is 0.7.2. +

+CL-FAD comes with simple system definitions for MK:DEFSYSTEM and asdf 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 +(mk:compile-system "cl-fad") - or (asdf:oos 'asdf:load-op :cl-fad) for asdf - which should compile and load the whole +system. +Installation via asdf-install should as well +be possible. Plus, there are ports +for Gentoo Linux thanks to Matthew Kennedy +and for Debian Linux thanks to René van Bevern. +

+If for some reason you can't or don't want to use MK:DEFSYSTEM or asdf you +can just LOAD the file load.lisp. +

+The latest version of the source code lives in the github repository edicl/cl-fad. + +If you want to send patches, +please read this first. +Please submit your changes +as GitHub pull +request". + +
 

Supported Lisp implementations

+ +

+The following Common Lisp implementations are currently supported: +

+ +I'll gladly accepts patches to make CL-FAD work on other platforms. + + +
 

The CL-FAD dictionary

+ +

Querying files, directories and pathnames

+ +


[Function] +
directory-exists-p pathspec => generalized-boolean + +


+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. +
+ +


[Function] +
directory-pathname-p pathspec => generalized-boolean + +


+Returns NIL if pathspec (a pathname designator) does not designate +a directory, pathspec otherwise. It is irrelevant whether the file or +directory designated by pathspec does actually exist. +
+ +


[Function] +
file-exists-p pathspec => generalized-boolean + +


+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 in directory form as if by PATHNAME-AS-DIRECTORY. +
+ +


[Function]
pathname-absolute-p a => result +

+

Returns true if a is an absolute pathname. This simply +tests if a's directory list starts with :ABSOLUTE

+
+ +


[Function]
pathname-equal a b => result +

+ +

Returns true 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= +
  • symbols (including nil and 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.

+ +
+ +


[Function]
pathname-relative-p a => result +

+

Returns true if a is a relative pathname. This simply +tests if a's directory starts +with :RELATIVE.

+
+ +


[Function]
pathname-root-p a => result +

+

Returns true if pathname is the root +directory (in other words, a directory which is its own parent).

+
+ +

Manipulating pathnames

+ +


[Function]
canonical-pathname pathname => result +

+

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.

+
+ +


[Function]
merge-pathnames-as-directory &rest pathnames => result +

+

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/"
+
+ +
+ +


[Function]
merge-pathnames-as-file &rest pathnames => result +

+

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"
+
+ +
+ +


[Function] +
pathname-as-directory pathspec => pathname +


+Converts the non-wild pathname designator pathspec to directory form, i.e. it returns a pathname which would return a true value if fed to DIRECTORY-PATHNAME-P. +
+ +


[Function] +
pathname-as-file pathspec => pathname + +


+Converts the non-wild pathname designator pathspec to file form, i.e. it returns a pathname which would return a NIL value if fed to DIRECTORY-PATHNAME-P. +
+ +


[Function]
pathname-directory-pathname pathname => result +

+

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-equal) to it.

+
+ +


[Function]
pathname-parent-directory pathname => result +

+ +

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.

+ +
+ +

Traversing directories

+ +


[Function] +
list-directory dirname &key follow-symlinks => list + +


+

+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 (which is the + default), 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. (This is currently implemented only on SBCL and CCL.) +

+
+ +


[Function] +
walk-directory dirname fn &key directories if-does-not-exist test follow-symlinks => | + +


+

+ Recursively applies the function designated by the function + designator 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. (The default value for test + always returns true.) 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 + (the default) means that an error will be signaled if the directory dirname + does not exist. +

+

+ If follow-symlinks 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 + LIST-DIRECTORY. +

+
+ +

Temporary Files

+ +
Synopsis
+ +

+ Create a temporary file and return its name: +

CL-USER> (temporary-file:with-output-to-temporary-file (foo)
+           (print "hello" foo))
+#P"/var/folders/Yu/YuNMNBNPGoqs9G-1Wmj1dk+++TI/-Tmp-/temp-yjck024x"
+

+

+ Create a temporary file, read and write it, have it be deleted + automatically: +

CL-USER> (temporary-file:with-open-temporary-file (foo :direction :io)
+           (print "hello" foo)
+           (file-position foo 0)
+           (read foo))
+"hello"
+

+ +
Default temporary file directory
+ 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 /tmp/ is used + by default. It can be overridden by setting the TMPDIR + environment variable. On Windows, the value of the environment + variable TEMP is used. If it is not set, temporary file + creation will fail. + +
Defining the temporary file directory
+

+ The Lisp application can set the default directory in which + temporary files are created by the way of the + temporary-files logical pathname host: + +

(setf (logical-pathname-translations "temporary-files") '(("*.*.*" "/var/tmp/")))
+ + This would set the directory for temporary files to + /var/tmp/. For more information about logical + pathnames, please refer to Common + Lisp the Language, 2nd Edition and the Common Lisp + HyperSpec. +

+

+ 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. +

+

+ Here are a few examples: +

CL-USER> (logical-pathname-translations "temporary-files")
+(("*.*.*" #P"/var/folders/Yu/YuNMNBNPGoqs9G-1Wmj1dk+++TI/-Tmp-/"))
+CL-USER> (temporary-file:with-open-temporary-file (foo)
+           (pathname foo))
+#P"/var/folders/Yu/YuNMNBNPGoqs9G-1Wmj1dk+++TI/-Tmp-/temp-6rdqdkd1"
+ + This used the temporary directory established in the TMPDIR + environment variable, by the way of the definition of the + temporary-files logical host definition. + +
CL-USER> (temporary-file:with-open-temporary-file (foo :template "/tmp/file.with.dots.in.name.%.txt")
+           (pathname foo))
+#P"/tmp/file.with.dots.in.name.2EF04KUJ.txt"
+ + Here, a physical pathname was used for the + :template keyword argument so that a + filename containing multiple dots could be generated. + +
CL-USER> (temporary-file:with-open-temporary-file (foo :template "temporary-files:blah-%.txt")
+           (pathname foo))
+#P"/var/folders/Yu/YuNMNBNPGoqs9G-1Wmj1dk+++TI/-Tmp-/blah-72mj450d.txt"
+ + This used the temporary-files logical pathname host, but changed + the filename slightly. + +
CL-USER> *default-pathname-defaults*
+#P"/Users/hans/"
+CL-USER> (temporary-file:with-open-temporary-file (foo :template "blah-%.txt")
+           (pathname foo))
+#P"/Users/hans/blah-5OEJELG2.txt"
+ + Here, a relative pathname was used in the template, which + caused the file to be generated in the directory established + by *default-pathname-defaults*. +

+

+ Alternatively, the *default-template* + special variable can be set to define a custom default template + for generating names. +

+ +
Security
+ 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. + +
Dictionary
+ + +

[Function]
open-temporary &rest open-arguments &key template generate-random-string max-tries &allow-other-keys + => + stream

+

+ 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. +

+

+ Any unrecognized keyword arguments are passed to the call to + open. +

+

+

[Macro]
with-output-to-temporary-file (stream &rest args) &body body + => + pathname

+ 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. +

+

[Macro]
with-open-temporary-file (stream &rest args &key keep &allow-other-keys) &body body + => + values

+ 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. +

+

+ [Special variable]
*default-template*

+ This variable can be set to a string representing the desired + default template for temporary file name generation. See + open-temporary for a description of the + template string format. +

+

+ [Condition type]
cannot-create-temporary-file

+ Signalled when an attempt to create unique temporary file name + failed after the established number of retries. +

+

+ [Condition type]
invalid-temporary-pathname-template

+ Signalled when the template argument to + open-temporary 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. +

+

+ [Condition type]
missing-temp-environment-variable

+ (Windows only) Signalled when the TEMP environment variable is + not set. +

+

+ [Logical Pathname Host]
temporary-files

+ 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 + missing-temp-environment-variable error + is signalled. +

+ + +

Modifying the file system

+ +


[Function] +
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 (the default is NIL) +overwrites the file designtated by to if it exists. +
+ +


[Function] +
copy-stream from to &optional checkp => | + +


Copies into to (a stream) +from from (also a stream) until the end +of from is reached. The streams should have the +same element +type unless they are bivalent. If checkp is +true (which is the default), the function will signal an error if the +element types aren't the same. +
+


[Function] +
delete-directory-and-files dirname&key if-does-not-exist => | + +


+

+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 (the default) means that an error will be signaled if the directory +dirname does not exist. +

+

+ Warning: this function might 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. +

+
+ +

The PATH package

+ +


[Package] +
(defpackage path) + +

+Provides a set of short names for commonly used pathname manipulation +functions (these are all functions from the cl-fad +package which are being exported under different names): +
+
dirname
pathname-as-directory
+
basename
cl:file-namestring
+
-e
file-exists-p
+
-d
directory-exists-p
+
catfile
merge-pathnames-as-file
+
catdir
merge-pathnames-as-directory
+
rm-r
delete-directory-and-files
+
=
pathname-equal
+
absolute-p
pathname-absolute-p
+
relative-p
pathname-relative-p
+
root-p
pathname-root-p
+
+
+ + +
 

Acknowledgements

+ +The original code for this library was written by Peter Seibel for his +book Practical Common +Lisp. 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. + +

+$Header: /usr/local/cvsrep/cl-fad/doc/index.html,v 1.33 2009/09/30 14:23:12 edi Exp $ +

BACK TO MY HOMEPAGE + + + + diff --git a/deps/cl-fad/fad.lisp b/deps/cl-fad/fad.lisp new file mode 100644 index 0000000..b436bb7 --- /dev/null +++ b/deps/cl-fad/fad.lisp @@ -0,0 +1,584 @@ +;;; -*- 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 "~@" + 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 +;; and +;; 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)))) diff --git a/deps/cl-fad/fad.test.lisp b/deps/cl-fad/fad.test.lisp new file mode 100644 index 0000000..8f547e1 --- /dev/null +++ b/deps/cl-fad/fad.test.lisp @@ -0,0 +1,157 @@ +;;; -*- 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.~%")) diff --git a/deps/cl-fad/load.lisp b/deps/cl-fad/load.lisp new file mode 100644 index 0000000..0fd1a15 --- /dev/null +++ b/deps/cl-fad/load.lisp @@ -0,0 +1,62 @@ +;;; -*- 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))))) diff --git a/deps/cl-fad/openmcl.lisp b/deps/cl-fad/openmcl.lisp new file mode 100644 index 0000000..ae99f77 --- /dev/null +++ b/deps/cl-fad/openmcl.lisp @@ -0,0 +1,72 @@ +;;; -*- 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)))))) + diff --git a/deps/cl-fad/packages.lisp b/deps/cl-fad/packages.lisp new file mode 100644 index 0000000..1514c99 --- /dev/null +++ b/deps/cl-fad/packages.lisp @@ -0,0 +1,87 @@ +;;; -*- 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)) diff --git a/deps/cl-fad/packages.test.lisp b/deps/cl-fad/packages.test.lisp new file mode 100644 index 0000000..90736df --- /dev/null +++ b/deps/cl-fad/packages.test.lisp @@ -0,0 +1,5 @@ +(in-package :common-lisp-user) + +(defpackage :cl-fad-test + (:use :cl :cl-fad :unit-test) + (:export :test)) diff --git a/deps/cl-fad/path.lisp b/deps/cl-fad/path.lisp new file mode 100644 index 0000000..c94a0c2 --- /dev/null +++ b/deps/cl-fad/path.lisp @@ -0,0 +1,32 @@ +(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) diff --git a/deps/cl-fad/temporary-files.lisp b/deps/cl-fad/temporary-files.lisp new file mode 100644 index 0000000..0dc20da --- /dev/null +++ b/deps/cl-fad/temporary-files.lisp @@ -0,0 +1,174 @@ +(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))))))) diff --git a/deps/cl-fad/temporary-files.test.lisp b/deps/cl-fad/temporary-files.test.lisp new file mode 100644 index 0000000..80d4403 --- /dev/null +++ b/deps/cl-fad/temporary-files.test.lisp @@ -0,0 +1,49 @@ +(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))))) + + + diff --git a/deps/flexi-streams/CHANGELOG b/deps/flexi-streams/CHANGELOG new file mode 100644 index 0000000..75a326b --- /dev/null +++ b/deps/flexi-streams/CHANGELOG @@ -0,0 +1,283 @@ +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 diff --git a/deps/flexi-streams/ascii.lisp b/deps/flexi-streams/ascii.lisp new file mode 100644 index 0000000..f333094 --- /dev/null +++ b/deps/flexi-streams/ascii.lisp @@ -0,0 +1,36 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: FLEXI-STREAMS; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/flexi-streams/ascii.lisp,v 1.9 2008/05/18 21:32:15 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) + +(defconstant +ascii-table+ + ;; currently not used, but we leave it in here just in case... + (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)) + "An array enumerating the character codes for the US-ASCII +encoding.") diff --git a/deps/flexi-streams/code-pages.lisp b/deps/flexi-streams/code-pages.lisp new file mode 100644 index 0000000..a0d7427 --- /dev/null +++ b/deps/flexi-streams/code-pages.lisp @@ -0,0 +1,62 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: FLEXI-STREAMS; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/flexi-streams/code-pages.lisp,v 1.7 2008/05/18 21:32:15 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) + +;;; the following code was auto-generated with LWW + +(defconstant +code-page-tables+ + `((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))) + (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))) + (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))) + (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))) + (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))) + (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))) + (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))) + (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))) + (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))) + (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))) + (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))) + (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))) + (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))) + (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))) + (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))) + (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))) + (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))) + (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))) + (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))) + (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))) + (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))) + (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))) + (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))) + (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))) + (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)))) + "A list of 8-bit Windows code pages where each element is a +cons with the car being the ID of the code page and the cdr being +a vector enumerating the corresponding character codes.") diff --git a/deps/flexi-streams/conditions.lisp b/deps/flexi-streams/conditions.lisp new file mode 100644 index 0000000..602ac6f --- /dev/null +++ b/deps/flexi-streams/conditions.lisp @@ -0,0 +1,108 @@ +;;; -*- 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)) diff --git a/deps/flexi-streams/decode.lisp b/deps/flexi-streams/decode.lisp new file mode 100644 index 0000000..ffca853 --- /dev/null +++ b/deps/flexi-streams/decode.lisp @@ -0,0 +1,471 @@ +;;; -*- 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

) which has to be replaced by the correct code to +`unread' the octets for the character designated by ." + (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)))) + diff --git a/deps/flexi-streams/doc/foo.txt b/deps/flexi-streams/doc/foo.txt new file mode 100644 index 0000000000000000000000000000000000000000..e596ded6019181f66d2e46b26a697bb59d09a046 GIT binary patch literal 30 ocmV+(0O9|`gu|A@oG}dw#Maz03hSe!r2xbL)&Sf9GXM<$3hKoSkpKVy literal 0 HcmV?d00001 diff --git a/deps/flexi-streams/doc/index.html b/deps/flexi-streams/doc/index.html new file mode 100644 index 0000000..941e8e3 --- /dev/null +++ b/deps/flexi-streams/doc/index.html @@ -0,0 +1,1123 @@ + + + + + + FLEXI-STREAMS - Flexible bivalent streams for Common Lisp + + + + + +

FLEXI-STREAMS - Flexible bivalent streams for Common Lisp

+ +
+
 

Abstract

+ +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 +in-memory binary streams which are similar to string streams. +

+The library needs a Common Lisp implementation that +supports Gray +streams and relies on David +Lichteblau's trivial-gray-streams +to offer portability between different Lisps. +

+The code comes with +a BSD-style +license so you can basically do with it whatever you want. + +

+Download shortcut: http://weitz.de/files/flexi-streams.tar.gz. +

+ +
 

Contents

+
    +
  1. Example usage +
  2. Download and installation +
  3. Support +
  4. The FLEXI-STREAMS dictionary +
      +
    1. External formats +
        +
      1. make-external-format +
      2. external-format-name +
      3. external-format-eol-style +
      4. external-format-little-endian +
      5. external-format-id +
      6. external-format-equal +
      7. *default-eol-style* +
      8. *default-little-endian* +
      9. external-format-condition +
      10. external-format-condition-external-format +
      11. external-format-error +
      12. external-format-encoding-error +
      13. *substitution-char* +
      14. accept-overlong-sequence +
      +
    2. Flexi streams +
        +
      1. flexi-stream +
      2. flexi-input-stream +
      3. flexi-output-stream +
      4. flexi-io-stream +
      5. make-flexi-stream +
      6. flexi-stream-external-format +
      7. flexi-stream-element-type +
      8. flexi-stream-column +
      9. flexi-stream-position +
      10. flexi-stream-bound +
      11. flexi-stream-stream +
      12. unread-byte +
      13. peek-byte +
      14. octet +
      15. flexi-stream-error +
      16. flexi-stream-out-of-sync-error +
      17. flexi-stream-element-type-error +
      18. flexi-stream-element-type-error-element-type +
      +
    3. In-memory streams +
        +
      1. in-memory-stream +
      2. in-memory-input-stream +
      3. in-memory-output-stream +
      4. list-stream +
      5. vector-stream +
      6. make-in-memory-input-stream +
      7. make-in-memory-output-stream +
      8. get-output-stream-sequence +
      9. output-stream-sequence-length +
      10. with-input-from-sequence +
      11. with-output-to-sequence +
      12. in-memory-stream-error +
      13. in-memory-stream-closed-error +
      14. in-memory-stream-position-spec-error +
      15. in-memory-stream-position-spec-error-position-spec +
      +
    4. Strings +
        +
      1. string-to-octets +
      2. octets-to-string +
      3. octet-length +
      4. char-length +
      +
    +
  5. File positions +
  6. Acknowledgements +
+ +
 

Example usage

+ +The examples were created with LispWorks 4.4.6 pro on Windows. The following two functions create the same file: + +
+(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 flexi stream."
+  (with-open-file (out pathspec
+                       :direction :output
+                       :if-exists :supersede
+                       :external-format '(:latin-1 :eol-style :lf))
+    (setq out (make-flexi-stream out :external-format :utf-8))
+    (write-line "ÄÖÜ1" out)
+    (setf (flexi-stream-external-format 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)))
+
+ +

+And applying this function +

+(defun baz (pathspec)
+  (let (result)
+    (with-open-file (in pathspec :element-type 'octet)
+      (setq in (make-flexi-stream in :external-format :utf-8))
+      (push (read-line in) result)
+      (push (read-byte in) result)
+      (setf (flexi-stream-external-format 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)))
+
+to the file created above will yield the list +
+("ÄÖÜ1" 196 "ÖÜ2" #\λ "£€¥" #(0 196) "ÖÜ3")
+
+ +

+For more examples see the source code +of +CL-RFC2047, +Drakma, Chunga, +or CL-WBXML. + +
 

Download and installation

+ +Before you try to install FLEXI-STREAMS, first check that in your Lisp +each character's +character +code is equal to +its Unicode code point and +that (CHAR-CODE #\Newline) +and (CHAR-CODE #\Linefeed) 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 not mandated by the ANSI standard, though.) +

+FLEXI-STREAMS together with this documentation can be downloaded from http://weitz.de/files/flexi-streams.tar.gz. The +current version is 1.0.12. +

+Before you install FLEXI-STREAMS you first need to +install the trivial-gray-streams library +unless you already have it. +

+FLEXI-STREAMS comes with a system definition for ASDF so you can install the library with +

+(asdf:oos 'asdf:load-op :flexi-streams)
+
+if you've unpacked it in a place where ASDF can find it. Installation +via asdf-install +should also be possible, and there's a port +to Gentoo Lisp thanks to +Matthew Kennedy. +

+You can run a test suite which tests some (but +not all) aspects of the library with +

+(asdf:oos 'asdf:test-op :flexi-streams)
+
+This might take a while... +

+The current development version of FLEXI-STREAMS can be found +at http://bknr.net/trac/browser/trunk/thirdparty. +This is the one to send patches against. Use at +your own risk. +

+Luís Oliveira maintains a darcs +repository of FLEXI-STREAMS +at http://common-lisp.net/~loliveira/ediware/. +

+A Mercurial +repository of older versions is available +at http://arcanes.fr.eu.org/~pierre/2007/02/weitz/ +thanks to Pierre Thierry. + +
 

Support

+ +The development version of flexi-streams can be +found on +github. Please use the github issue tracking system to submit bug +reports. Patches are welcome, please +use GitHub pull +requests. If you want to make a change, +please read this +first. + +
 

The FLEXI-STREAMS dictionary

+ +

External formats

+ +EXTERNAL-FORMAT objects are used to denote the external +formats of flexi streams. These objects are created using +the MAKE-EXTERNAL-FORMAT +function, and there are various +readers to query their attributes. Once such an object is +created it can't be changed. +

+An external format consists of a basic encoding +(like ISO 8859-1 +or UTF-8), 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 endianess +of the encoding. +

+The following encodings are currently supported by FLEXI-STREAMS: +

    +
  • UTF-8 (denoted by the keyword :UTF-8), +
  • UTF-16 (denoted by the keyword :UTF-16), +
  • UTF-32 (denoted by the keyword :UTF-32), +
  • all ISO 8859 character sets (denoted by keywords like :ISO-8859-15), +
  • KOI8-R (denoted by the keyword :KOI8-R), +
  • a couple +of Windows code +pages (denoted by the keyword :CODE-PAGE and an +obligatory :ID argument), and +
  • US-ASCII. +
+

+A couple of alternative names are allowed that are listed below: +

+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
:UTF-8:UTF8
:UTF-16:UTF16
:UCS-2
:UCS2
:UNICODE
:UTF-32:UTF32
:UCS-4
:UCS4
:ISO-8859-1:LATIN-1
:LATIN1
:ISO-8859-2:LATIN-2
:LATIN2
:ISO-8859-3:LATIN-3
:LATIN3
:ISO-8859-4:LATIN-4
:LATIN4
:ISO-8859-5:CYRILLIC
:ISO-8859-6:ARABIC
:ISO-8859-7:GREEK
:ISO-8859-8:HEBREW
:ISO-8859-9:LATIN-5
:LATIN5
:ISO-8859-10:LATIN-6
:LATIN6
:ISO-8859-11:THAI
:ISO-8859-13:LATIN-7
:LATIN7
:ISO-8859-14:LATIN-8
:LATIN8
:ISO-8859-15:LATIN-9
:LATIN9
:LATIN-0
:LATIN0
:ISO-8859-16:LATIN-10
:LATIN10
:CODE-PAGE:CODEPAGE
WIN32:CODE-PAGE
(only on LWW)
:KOI8-R:KOI8R
:US-ASCII:ASCII
+

+(Note that we treat UCS-2 exactly like UTF-16 although there +are subtle +differences. Also note that even though we support encodings like +UTF-32 some Lisps only supports characters contained within +the Basic +Multilingual Plane (like LispWorks) or even less (like CMUCL), so +if other characters are read from a +flexi +stream, READ-CHAR +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 READ-LINE, though.) + +

+Whenever a FLEXI-STREAMS function accepts an external format as one of +its arguments, you can provide either an EXTERNAL-FORMAT +object or a shortcut which can be a list or a symbol. The list +shortcuts have a syntax similar +to the +one used by LispWorks - the cars are the names of and encoding +and the cdrs of these lists correspond to the keyword arguments +to MAKE-EXTERNAL-FORMAT, so +for example +

(:latin-1 :eol-style :crlf)
+is equivalent to +
(make-external-format :latin-1 :eol-style :crlf)
The +symbol shortcuts are equivalent to +calling MAKE-EXTERNAL-FORMAT +without keyword arguments, i.e. +
:thai
+behaves like +
(make-external-format :thai)
+Finally, the following expansions are +available: +

+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
: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)
+

+Note that if you provide a shortcut, it +will be converted to an EXTERNAL-FORMAT object first. +So, if you're concerned about efficiency, create these objects once and +re-use them. + +


[Function] +
make-external-format name &key eol-style little-endian id => external-format + +


Creates and returns +an EXTERNAL-FORMAT +object. name is a +symbol, eol-style is one of the +keywords :CR, :LF, or :CRLF, +and little-endian is +a generalized +boolean. The default value for eol-style is the value of *DEFAULT-EOL-STYLE* except for Windows code pages where it is :CRLF. The default value +for little-endian is the value of *DEFAULT-LITTLE-ENDIAN* - this value is ignored unless name denotes one of UTF-16 or UTF-32. +id must be an integer denoting a Windows code page +known by FLEXI-STREAMS if name +is :CODE-PAGE or WIN32:CODE-PAGE, otherwise +the value is ignored. See the section +about external formats for more info. +

+Examples (run on Windows): + +

+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>
+
+
+ +


[Readers] +
external-format-name external-format => name +
external-format-eol-style external-format => eol-style +
external-format-little-endian external-format => little-endian +
external-format-id external-format => id + +


+These methods can be used to query an EXTERNAL-FORMAT object for its attributes. +
+ +


[Functions] +
external-format-equal external-format-1 external-format-2 => generalized-boolean + +


+Checks whether the two external formats external-format-1 and external-format-2 are equivalent with respect to their effects on flexi streams. +

+Examples (run on Windows): + +

+CL-USER 1 > (make-external-format :ucs-4le)
+#<FLEXI-STREAMS::EXTERNAL-FORMAT (:UTF-32 :EOL-STYLE :CRLF :LITTLE-ENDIAN T) 2067FB74>
+
+CL-USER 2 > (external-format-equal * (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
+
+ +
+ +


[Special variable] +
*default-eol-style* + +


+The default value for the eol-style keyword argument of MAKE-EXTERNAL-FORMAT. Its initial value is :CRLF on Windows and :LF on other operating systems. +
+ +


[Special variable] +
*default-little-endian* + +


+The default value for the little-endian keyword argument of MAKE-EXTERNAL-FORMAT. Its initial value corresponds to the endianess of the platform FLEXI-STREAMS is used on as revealed by the :LITTLE-ENDIAN feature. +
+ +


[Condition] +
external-format-condition + +


+All conditions related to external formats are of this type. +There's a slot for the external format which can be accessed with EXTERNAL-FORMAT-CONDITION-EXTERNAL-FORMAT. +
+ +


[Reader] +
external-format-condition-external-format condition => external-format + +


If condition is of +type EXTERNAL-FORMAT-CONDITION, +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 NIL. +
+ +


[Condition] +
external-format-error + +


+All errors related to external formats are of this type. +This is a subtype of EXTERNAL-FORMAT-CONDITION. +
+ +


[Condition] +
external-format-encoding-error + +


+All errors related to encoding problems with external formats 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, USE-VALUE +restart is provided. See also *SUBSTITUTION-CHAR* and the example for it. EXTERNAL-FORMAT-ENCODING-ERROR is a subtype of EXTERNAL-FORMAT-ERROR. +
+ +


[Special variable] +
*substitution-char* + +


+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 EXTERNAL-FORMAT-ENCODING-ERROR would have been signalled otherwise. + +
+CL-USER 1 > (defun foo ()
+              ;; not a valid UTF-8 sequence
+              (with-input-from-sequence (in '(#xe4 #xf6 #xfc))
+                (setq in (make-flexi-stream 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 > (handler-bind ((external-format-encoding-error (lambda (condition)
+                                                          (use-value #\-))))
+              (foo))
+"--"
+T
+
+CL-USER 6 > (let ((*substitution-char* #\?))
+              (foo))
+"??"
+T
+
+
+ +


[Restart] +
accept-overlong-sequence + +


This is +a restart +which is established whenever a UTF-8 "overlong" sequence is +encountered. If +you invoke +this restart, the corresponding code point will be accepted although +it was encoded in an illegal way. +
+ +

Flexi streams

+ +Flexi streams are the core of the FLEXI-STREAMS library. You +create them using the +function MAKE-FLEXI-STREAM which +takes an open binary stream (called the underlying stream) as its only required argument. +A binary stream in this context means that if it's an input +stream, you can read from it with +READ-BYTE +(or, as a workaround for LispWorks, you can at least apply +READ-SEQUENCE +to it where the sequence is an array of element +type OCTET), and similarly for +WRITE-BYTE +(WRITE-SEQUENCE +for LispWorks) +and output +streams. (Note that this specifically holds +for bivalent +streams like socket streams.) +

+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 octets to an output flexi stream and similarly +you can read characters and octets from an input flexi stream. +

+A flexi stream always has an external +format associated with it which is deployed whenever you read +characters from the stream or write characters to it. You +can change the external +format while you use the stream. +

+Once you're using a flexi stream you should not read from or +write to the underlying stream directly anymore. +

+If +you close +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 IN is implicitly closed at the end) is OK: +

+(with-open-file (in "/foo/bar/baz.txt")
+  (let ((flexi (make-flexi-stream in :external-format :hebrew)))
+    (read-line flexi)))
+
+

+Output flexi streams will try to keep track of +the column +they're in but you can also set the +column directly. This value will be incremented by one for each +character written to the stream and it will be set to 0 +if you send a #\Newline character. The column will be +set to NIL if an OCTET +is sent to the stream. Once the column is NIL it'll stay +like that unless it is explicitly set to another value. +

+Input flexi streams keep track of +their position within the stream. +This value is incremented by one for +each OCTET 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 #\ä (a-umlaut) will advance the position by two. +If the encoding is UTF-32 and the end-of-line style +is :CRLF, reading a #\Newline will advance +the position by eight. +

+You can also set the bound of an +input flexi stream. Initially it is NIL, but when it's +an integer and the +stream's position has gone beyond +this bound, the stream will behave as if no more input is available. +

+Caveat: You can +only unread +a character from a flexi stream if you haven't changed the external format after you read it. +

+Caveat: The underlying stream should either be a binary stream (i.e. have an element type that is a subtype of integer) or it should explicitly use an external format with :LF as its end-of-line style. Otherwise it might perform unwanted conversion of line endings on its own. (LispWorks does this even if you write binary data to the stream using WRITE-SEQUENCE.) + +


[Standard class] +
flexi-stream + +


+Every flexi stream returned by MAKE-FLEXI-STREAM is of this type which is a subtype of STREAM. +
+ +


[Standard class] +
flexi-input-stream + +


+A flexi stream is of this type if its underlying stream is an input stream. This is a subtype of FLEXI-STREAM. +
+ +


[Standard class] +
flexi-output-stream + +


+A flexi stream is of this type if its underlying stream is an output stream. This is a subtype of FLEXI-STREAM. +
+ +


[Standard class] +
flexi-io-stream + +


+A flexi stream is of this type if it is both a FLEXI-INPUT-STREAM as well as a FLEXI-OUTPUT-STREAM. +
+ +


[Function] +
make-flexi-stream stream &key external-format element-type column position bound => flexi-stream + +


+Creates and returns a flexi stream, i.e. an object of type FLEXI-STREAM. stream is the underlying Lisp stream. external-format is the initial external format to be used by the stream, the default is the value of evaluating (MAKE-EXTERNAL-FORMAT :LATIN1). element-type is the initial element type of the flexi stream the default of which is LW:SIMPLE-CHAR for LispWorks and CHARACTER otherwise. column is the initial column of the stream and should only be provided for output streams, the default is 0. position is the initial octet position of the stream and must only be provided for input streams, the default is 0. bound should be NIL (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 the section about flexi streams for more information. +
+ +


[Accessors] +
flexi-stream-external-format flexi-stream => external-format +
(setf (flexi-stream-external-format flexi-stream) external-format) +
flexi-stream-element-type flexi-stream => element-type +
(setf (flexi-stream-element-type flexi-stream) element-type) +
flexi-stream-column flexi-output-stream => column +
(setf (flexi-stream-column flexi-output-stream) column) +
flexi-stream-position flexi-input-stream => position +
(setf (flexi-stream-position flexi-input-stream) position) +
flexi-stream-bound flexi-input-stream => bound +
(setf (flexi-stream-bound flexi-input-stream) bound) + +


+These methods can be used to get and set the corresponding attributes of a flexi stream. +

+(SETF +FLEXI-STREAM-EXTERNAL-FORMAT) accepts keyword symbols +(names of external formats), lists +(which should be valid lists of parameters +to MAKE-EXTERNAL-FORMAT), or EXTERNAL-FORMAT objects: +

+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>
+
+
+ +


[Reader] +
flexi-stream-stream flexi-stream => stream + +


+This method returns the underlying stream of a flexi stream. +
+ +


[Generic function] +
unread-byte byte stream => nil + +


+Similar to UNREAD-CHAR in that it "unreads" the last octet from +stream which must be a flexi stream. Note that you can only call UNREAD-BYTE after a corresponding +READ-BYTE, not after READ-CHAR. +
+ +


[Generic function] +
peek-byte stream &optional peek-type eof-error-p eof-value => byte + +


+PEEK-BYTE is like PEEK-CHAR, i.e. it returns an octet from stream (which must be a flexi 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. +

+Note that the parameters aren't in the same order as with PEEK-CHAR because it doesn't make much sense to make stream an optional argument. +

+ +


[Type] +
octet + +


+Just a shortcut for (UNSIGNED-BYTE 8). +
+ +


[Condition] +
flexi-stream-error + +


+All errors related to flexi streams are of this type. This is a subtype of STREAM-ERROR. +
+ +


[Condition] +
flexi-stream-out-of-sync-error + +


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. +
+ +


[Condition] +
flexi-stream-element-type-error + +


+All errors related to problems with the element type of flexi streams are of this type. This is a subtype of FLEXI-STREAM-ERROR and has an additional slot for the element type which can be accessed with FLEXI-STREAM-ELEMENT-TYPE-ERROR-ELEMENT-TYPE. +
+ +


[Reader] +
flexi-stream-element-type-error-element-type condition => element-type + +


+If condition is of type FLEXI-STREAM-ELEMENT-TYPE-ERROR, this function will return the offending element type. +
+ +

In-memory streams

+ +The library also provides in-memory binary streams which are modeled after string streams and behave very similar only that they deal with octets 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 flexi streams. + +


[Standard class] +
in-memory-stream + +


+Every in-memory stream returned by MAKE-IN-MEMORY-INPUT-STREAM or MAKE-IN-MEMORY-OUTPUT-STREAM is of this type which is a subtype of STREAM. +
+ +


[Standard class] +
in-memory-input-stream + +


+Every in-memory stream returned by MAKE-IN-MEMORY-INPUT-STREAM is of this type which is a subtype of IN-MEMORY-STREAM. +
+ +


[Standard class] +
in-memory-output-stream + +


+Every in-memory stream returned by MAKE-IN-MEMORY-OUTPUT-STREAM is of this type which is a subtype of IN-MEMORY-STREAM. +
+ +


[Standard class] +
list-stream + +


+Every in-memory input stream is of this type if it reads from a list. +
+ +


[Standard class] +
vector-stream + +


+Every in-memory stream is of this type if it reads from or writes to a vector. +
+ +


[Generic function] +
make-in-memory-input-stream sequence &key start end transformer => in-memory-input-stream + +


+Returns a binary input stream (of type IN-MEMORY-INPUT-STREAM) which will supply, in order, the +octets in the subsequence of sequence bounded by start (the default is 0) and end (the default is the length of sequence). sequence must either be a list or a vector of octets. +Each octet returned will be transformed in turn by the optional +transformer function. +
+ +


[Function] +
make-in-memory-output-stream &key element-type transformer => in-memory-output-stream + +


+Returns a binary output stream (of type IN-MEMORY-OUTPUT-STREAM) which accepts objects of type element-type (a subtype of OCTET) and makes +available a sequence (see GET-OUTPUT-STREAM-SEQUENCE) that contains the octets that were actually +output. The octets stored will each be transformed by the optional transformer function. +
+ +


[Generic function] +
get-output-stream-sequence stream &key as-list => sequence + +


+Returns a vector containing, in order, all the octets that have +been output to the in-memory output 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. +
+ +


[Generic function] +
output-stream-sequence-length stream => length + +


Returns the current length of the underlying vector +of the in-memory output +stream stream, i.e. this is the length of the +sequence that GET-OUTPUT-STREAM-SEQUENCE would return if called at +this very moment. +
+ +


[Macro] +
with-input-from-sequence (var sequence &key start end transformer) statement* => result* + +


Creates an in-memory input +stream from the sequence sequence using the +parameters start and end +(see MAKE-IN-MEMORY-INPUT-STREAM), +binds var to this stream and then executes +the statement* forms. A +function transformer may optionally be specified +to transform the returned octets. 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 the return value of +the last statement of statement*. +
+ +


[Macro] +
with-output-to-sequence (var &key as-list element-type transformer) statement* => sequence + +


+Creates an in-memory output stream, binds var to this stream and +then executes the statement* forms. 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 the body of the macro. +
+ +


[Condition] +
in-memory-stream-error + +


+All errors related to in-memory streams are of this type. This is a subtype of STREAM-ERROR. +
+ +


[Condition] +
in-memory-stream-closed-error + +


+An error of this type is signalled if one tries to read from or write to an in-memory stream which had already been closed. This is a subtype of IN-MEMORY-STREAM-ERROR. +
+ +


[Condition] +
in-memory-stream-position-spec-error + +


Errors of this type are signalled if an erroneous +position spec is used in conjunction +with FILE-POSITION. This is a +subtype +of IN-MEMORY-STREAM-ERROR +and has an additional slot for the position spec which can be accessed +with IN-MEMORY-STREAM-POSITION-SPEC-ERROR-POSITION-SPEC. +
+ +


[Reader] +
in-memory-stream-position-spec-error-position-spec condition => position-spec + +


+If condition is of type IN-MEMORY-STREAM-POSITION-SPEC-ERROR, this function will return the offending position spec. +
+ +

Strings

+ +This section collects a few convenience functions for strings conversions. + +


[Function] +
string-to-octets string &key external-format start end => vector + +


+ +Converts the Lisp string string from start to end to an array of +octets corresponding to the external +format designated by external-format. The defaults for +start and end +are 0 and the length of the string. The default +for external-format is :LATIN1. +

+In spite of the name, string can be any sequence of characters, but +the function is optimized for strings. +

+ +


[Function] +
octets-to-string sequence &key external-format start end => string + +


Converts the Lisp +sequence sequence of octets +from start to end to a string +using the external format designated +by external-format. The defaults for +start and end +are 0 and the length of the sequence. The default +for external-format is :LATIN1. +

+This function is optimized for the case +of sequence being +a vector. +Don't use lists if you are in hurry. +

+ +


[Function] +
octet-length string &key external-format start end => length + +


+ +Returns the length of the subsequence of string from start to end in +octets if encoded using +the external format designated +by external-format. +The defaults for +start and end +are 0 and the length of string. The default +for external-format is :LATIN1. +

+In spite of the name, string can be any sequence of characters, but +the function is optimized for strings. +

+ +


[Function] +
char-length sequence &key external-format start end => length + +


+ +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 designated +by external-format. +The defaults for +start and end +are 0 and the length of the sequence. The default +for external-format is :LATIN1. 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 are in hurry. +

+ +
 

File positions

+ +For flexi streams as well +as for in-memory +streams, FILE-POSITION +will usually return NIL and do nothing when a second +argument is supplied. This is correct +w.r.t. the ANSI +standard, but not very helpful. However, even +with Gray +streams there is no portable way to implement a better +behaviour. +

+For LispWorks +and CLISP, +FILE-POSITION +for flexi streams will work as if the +function had been applied to the underlying stream, and +for in-memory streams it will try to do +something sensible if the underlying data structure is a vector +(i.e. not a list). Patches for other Common Lisp +implementations should be sent to +the trivial-gray-streams +maintainers. + +
 

Acknowledgements

+ +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 Hans Hübner for +his work on making FLEXI-STREAMS faster. + +

+$Header: /usr/local/cvsrep/flexi-streams/doc/index.html,v 1.126 2008/08/26 10:59:24 edi Exp $ +

BACK TO MY HOMEPAGE + + + diff --git a/deps/flexi-streams/encode.lisp b/deps/flexi-streams/encode.lisp new file mode 100644 index 0000000..f04b04b --- /dev/null +++ b/deps/flexi-streams/encode.lisp @@ -0,0 +1,282 @@ +;;; -*- 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 +) to write the octet . 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)))) diff --git a/deps/flexi-streams/external-format.lisp b/deps/flexi-streams/external-format.lisp new file mode 100644 index 0000000..8fa7c41 --- /dev/null +++ b/deps/flexi-streams/external-format.lisp @@ -0,0 +1,389 @@ +;;; -*- 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))) diff --git a/deps/flexi-streams/flexi-streams.asd b/deps/flexi-streams/flexi-streams.asd new file mode 100644 index 0000000..025fcc2 --- /dev/null +++ b/deps/flexi-streams/flexi-streams.asd @@ -0,0 +1,73 @@ +;;; -*- 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)))) diff --git a/deps/flexi-streams/in-memory.lisp b/deps/flexi-streams/in-memory.lisp new file mode 100644 index 0000000..10484cc --- /dev/null +++ b/deps/flexi-streams/in-memory.lisp @@ -0,0 +1,406 @@ +;;; -*- 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))))) diff --git a/deps/flexi-streams/input.lisp b/deps/flexi-streams/input.lisp new file mode 100644 index 0000000..125d5ff --- /dev/null +++ b/deps/flexi-streams/input.lisp @@ -0,0 +1,294 @@ +;;; -*- 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: + ;; + (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 diff --git a/deps/flexi-streams/io.lisp b/deps/flexi-streams/io.lisp new file mode 100644 index 0000000..a746700 --- /dev/null +++ b/deps/flexi-streams/io.lisp @@ -0,0 +1,110 @@ +;;; -*- 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 diff --git a/deps/flexi-streams/iso-8859.lisp b/deps/flexi-streams/iso-8859.lisp new file mode 100644 index 0000000..af5d043 --- /dev/null +++ b/deps/flexi-streams/iso-8859.lisp @@ -0,0 +1,53 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: FLEXI-STREAMS; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/flexi-streams/iso-8859.lisp,v 1.7 2008/05/18 21:32:15 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) + +;;; the following code was auto-generated from files which can be +;;; found at + +(defconstant +iso-8859-tables+ + `((: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))) + (: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))) + (: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))) + (: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))) + (: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))) + (: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))) + (: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))) + (: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))) + (: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))) + (: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))) + (: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))) + (: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))) + (: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))) + (: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))) + (: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)))) + "A list of the ISO-8859 encodings where each element is a cons +with the car being a keyword denoting the encoding and the cdr +being a vector enumerating the corresponding character codes.") diff --git a/deps/flexi-streams/koi8-r.lisp b/deps/flexi-streams/koi8-r.lisp new file mode 100644 index 0000000..5c8352e --- /dev/null +++ b/deps/flexi-streams/koi8-r.lisp @@ -0,0 +1,36 @@ +;;; -*- 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.") diff --git a/deps/flexi-streams/length.lisp b/deps/flexi-streams/length.lisp new file mode 100644 index 0000000..30b790b --- /dev/null +++ b/deps/flexi-streams/length.lisp @@ -0,0 +1,468 @@ +;;; -*- 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 diff --git a/deps/flexi-streams/lw-char-stream.lisp b/deps/flexi-streams/lw-char-stream.lisp new file mode 100644 index 0000000..de3fcf8 --- /dev/null +++ b/deps/flexi-streams/lw-char-stream.lisp @@ -0,0 +1,77 @@ +;;; -*- 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)))))) diff --git a/deps/flexi-streams/mapping.lisp b/deps/flexi-streams/mapping.lisp new file mode 100644 index 0000000..ee70e50 --- /dev/null +++ b/deps/flexi-streams/mapping.lisp @@ -0,0 +1,81 @@ +;;; -*- 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 ." + '(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 diff --git a/deps/flexi-streams/output.lisp b/deps/flexi-streams/output.lisp new file mode 100644 index 0000000..894ae4e --- /dev/null +++ b/deps/flexi-streams/output.lisp @@ -0,0 +1,162 @@ +;;; -*- 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)))) diff --git a/deps/flexi-streams/packages.lisp b/deps/flexi-streams/packages.lisp new file mode 100644 index 0000000..e012b02 --- /dev/null +++ b/deps/flexi-streams/packages.lisp @@ -0,0 +1,90 @@ +;;; -*- 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)) diff --git a/deps/flexi-streams/specials.lisp b/deps/flexi-streams/specials.lisp new file mode 100644 index 0000000..3b7a453 --- /dev/null +++ b/deps/flexi-streams/specials.lisp @@ -0,0 +1,201 @@ +;;; -*- 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 +;; and +;; 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)))) diff --git a/deps/flexi-streams/stream.lisp b/deps/flexi-streams/stream.lisp new file mode 100644 index 0000000..cd827fd --- /dev/null +++ b/deps/flexi-streams/stream.lisp @@ -0,0 +1,241 @@ +;;; -*- 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))) diff --git a/deps/flexi-streams/strings.lisp b/deps/flexi-streams/strings.lisp new file mode 100644 index 0000000..d12ca02 --- /dev/null +++ b/deps/flexi-streams/strings.lisp @@ -0,0 +1,82 @@ +;;; -*- 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)) diff --git a/deps/flexi-streams/test/README b/deps/flexi-streams/test/README new file mode 100644 index 0000000..9f4eba9 --- /dev/null +++ b/deps/flexi-streams/test/README @@ -0,0 +1,4 @@ +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 diff --git a/deps/flexi-streams/test/hebrew_latin8_cr.txt b/deps/flexi-streams/test/hebrew_latin8_cr.txt new file mode 100644 index 0000000..4017a49 --- /dev/null +++ b/deps/flexi-streams/test/hebrew_latin8_cr.txt @@ -0,0 +1 @@ +:õøàä úàå íéîùä úà íéäìà àøá úéùàøá à 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 :éùùä íåé ø÷á-éäéå áø \ No newline at end of file diff --git a/deps/flexi-streams/test/hebrew_latin8_crlf.txt b/deps/flexi-streams/test/hebrew_latin8_crlf.txt new file mode 100644 index 0000000..06d86d8 --- /dev/null +++ b/deps/flexi-streams/test/hebrew_latin8_crlf.txt @@ -0,0 +1,68 @@ +:õøàä úàå íéîùä úà íéäìà àøá úéùàøá à 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 +:éùùä íåé ø÷á-éäéå áø diff --git a/deps/flexi-streams/test/hebrew_latin8_lf.txt b/deps/flexi-streams/test/hebrew_latin8_lf.txt new file mode 100644 index 0000000..bcc4c77 --- /dev/null +++ b/deps/flexi-streams/test/hebrew_latin8_lf.txt @@ -0,0 +1,68 @@ +:õøàä úàå íéîùä úà íéäìà àøá úéùàøá à 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 +:éùùä íåé ø÷á-éäéå áø diff --git a/deps/flexi-streams/test/hebrew_utf8_cr.txt b/deps/flexi-streams/test/hebrew_utf8_cr.txt new file mode 100644 index 0000000..b55e719 --- /dev/null +++ b/deps/flexi-streams/test/hebrew_utf8_cr.txt @@ -0,0 +1 @@ +:ץראה תאו םימשה תא םיהלא ארב תישארב א 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 :יששה םוי רקב-יהיו בר \ No newline at end of file diff --git a/deps/flexi-streams/test/hebrew_utf8_crlf.txt b/deps/flexi-streams/test/hebrew_utf8_crlf.txt new file mode 100644 index 0000000..c7d27eb --- /dev/null +++ b/deps/flexi-streams/test/hebrew_utf8_crlf.txt @@ -0,0 +1,68 @@ +:ץראה תאו םימשה תא םיהלא ארב תישארב א 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 +:יששה םוי רקב-יהיו בר diff --git a/deps/flexi-streams/test/hebrew_utf8_lf.txt b/deps/flexi-streams/test/hebrew_utf8_lf.txt new file mode 100644 index 0000000..1746d16 --- /dev/null +++ b/deps/flexi-streams/test/hebrew_utf8_lf.txt @@ -0,0 +1,68 @@ +:ץראה תאו םימשה תא םיהלא ארב תישארב א 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 +:יששה םוי רקב-יהיו בר diff --git a/deps/flexi-streams/test/kafka_cp1252_cr.txt b/deps/flexi-streams/test/kafka_cp1252_cr.txt new file mode 100644 index 0000000..41f1bc4 --- /dev/null +++ b/deps/flexi-streams/test/kafka_cp1252_cr.txt @@ -0,0 +1 @@ +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. \ No newline at end of file diff --git a/deps/flexi-streams/test/kafka_cp1252_crlf.txt b/deps/flexi-streams/test/kafka_cp1252_crlf.txt new file mode 100644 index 0000000..4fefd15 --- /dev/null +++ b/deps/flexi-streams/test/kafka_cp1252_crlf.txt @@ -0,0 +1,11 @@ +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. diff --git a/deps/flexi-streams/test/kafka_cp1252_lf.txt b/deps/flexi-streams/test/kafka_cp1252_lf.txt new file mode 100644 index 0000000..82dbb83 --- /dev/null +++ b/deps/flexi-streams/test/kafka_cp1252_lf.txt @@ -0,0 +1,11 @@ +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. diff --git a/deps/flexi-streams/test/kafka_latin1_cr.txt b/deps/flexi-streams/test/kafka_latin1_cr.txt new file mode 100644 index 0000000..41f1bc4 --- /dev/null +++ b/deps/flexi-streams/test/kafka_latin1_cr.txt @@ -0,0 +1 @@ +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. \ No newline at end of file diff --git a/deps/flexi-streams/test/kafka_latin1_crlf.txt b/deps/flexi-streams/test/kafka_latin1_crlf.txt new file mode 100644 index 0000000..4fefd15 --- /dev/null +++ b/deps/flexi-streams/test/kafka_latin1_crlf.txt @@ -0,0 +1,11 @@ +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. diff --git a/deps/flexi-streams/test/kafka_latin1_lf.txt b/deps/flexi-streams/test/kafka_latin1_lf.txt new file mode 100644 index 0000000..82dbb83 --- /dev/null +++ b/deps/flexi-streams/test/kafka_latin1_lf.txt @@ -0,0 +1,11 @@ +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. diff --git a/deps/flexi-streams/test/kafka_utf8_cr.txt b/deps/flexi-streams/test/kafka_utf8_cr.txt new file mode 100644 index 0000000..a2e933c --- /dev/null +++ b/deps/flexi-streams/test/kafka_utf8_cr.txt @@ -0,0 +1 @@ +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. \ No newline at end of file diff --git a/deps/flexi-streams/test/kafka_utf8_crlf.txt b/deps/flexi-streams/test/kafka_utf8_crlf.txt new file mode 100644 index 0000000..eca3fe5 --- /dev/null +++ b/deps/flexi-streams/test/kafka_utf8_crlf.txt @@ -0,0 +1,11 @@ +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. diff --git a/deps/flexi-streams/test/kafka_utf8_lf.txt b/deps/flexi-streams/test/kafka_utf8_lf.txt new file mode 100644 index 0000000..afa3364 --- /dev/null +++ b/deps/flexi-streams/test/kafka_utf8_lf.txt @@ -0,0 +1,11 @@ +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. diff --git a/deps/flexi-streams/test/packages.lisp b/deps/flexi-streams/test/packages.lisp new file mode 100644 index 0000000..0953508 --- /dev/null +++ b/deps/flexi-streams/test/packages.lisp @@ -0,0 +1,41 @@ +;;; -*- 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)) diff --git a/deps/flexi-streams/test/russian_koi8r_cr.txt b/deps/flexi-streams/test/russian_koi8r_cr.txt new file mode 100644 index 0000000..4a6bf9e --- /dev/null +++ b/deps/flexi-streams/test/russian_koi8r_cr.txt @@ -0,0 +1 @@ +úÁÒÅÇÉÓÔÒÉÒÕÊÔÅÓØ ÓÅÊÞÁÓ ÎÁ äÅÓÑÔÕÀ íÅÖÄÕÎÁÒÏÄÎÕÀ ëÏÎÆÅÒÅÎÃÉÀ ÐÏ Unicode, ËÏÔÏÒÁÑ ÓÏÓÔÏÉÔÓÑ 10-12 ÍÁÒÔÁ 1997 ÇÏÄÁ × íÁÊÎÃÅ × çÅÒÍÁÎÉÉ. ëÏÎÆÅÒÅÎÃÉÑ ÓÏÂÅÒÅÔ ÛÉÒÏËÉÊ ËÒÕÇ ÜËÓÐÅÒÔÏ× ÐÏ ×ÏÐÒÏÓÁÍ ÇÌÏÂÁÌØÎÏÇÏ éÎÔÅÒÎÅÔÁ É Unicode, ÌÏËÁÌÉÚÁÃÉÉ É ÉÎÔÅÒÎÁÃÉÏÎÁÌÉÚÁÃÉÉ, ×ÏÐÌÏÝÅÎÉÀ É ÐÒÉÍÅÎÅÎÉÀ Unicode × ÒÁÚÌÉÞÎÙÈ ÏÐÅÒÁÃÉÏÎÎÙÈ ÓÉÓÔÅÍÁÈ É ÐÒÏÇÒÁÍÍÎÙÈ ÐÒÉÌÏÖÅÎÉÑÈ, ÛÒÉÆÔÁÈ, ×ÅÒÓÔËÅ É ÍÎÏÇÏÑÚÙÞÎÙÈ ËÏÍÐØÀÔÅÒÎÙÈ ÓÉÓÔÅÍÁÈ. \ No newline at end of file diff --git a/deps/flexi-streams/test/russian_koi8r_crlf.txt b/deps/flexi-streams/test/russian_koi8r_crlf.txt new file mode 100644 index 0000000..1bf8ccc --- /dev/null +++ b/deps/flexi-streams/test/russian_koi8r_crlf.txt @@ -0,0 +1,6 @@ +úÁÒÅÇÉÓÔÒÉÒÕÊÔÅÓØ ÓÅÊÞÁÓ ÎÁ äÅÓÑÔÕÀ íÅÖÄÕÎÁÒÏÄÎÕÀ ëÏÎÆÅÒÅÎÃÉÀ ÐÏ +Unicode, ËÏÔÏÒÁÑ ÓÏÓÔÏÉÔÓÑ 10-12 ÍÁÒÔÁ 1997 ÇÏÄÁ × íÁÊÎÃÅ × çÅÒÍÁÎÉÉ. +ëÏÎÆÅÒÅÎÃÉÑ ÓÏÂÅÒÅÔ ÛÉÒÏËÉÊ ËÒÕÇ ÜËÓÐÅÒÔÏ× ÐÏ ×ÏÐÒÏÓÁÍ ÇÌÏÂÁÌØÎÏÇÏ +éÎÔÅÒÎÅÔÁ É Unicode, ÌÏËÁÌÉÚÁÃÉÉ É ÉÎÔÅÒÎÁÃÉÏÎÁÌÉÚÁÃÉÉ, ×ÏÐÌÏÝÅÎÉÀ É +ÐÒÉÍÅÎÅÎÉÀ Unicode × ÒÁÚÌÉÞÎÙÈ ÏÐÅÒÁÃÉÏÎÎÙÈ ÓÉÓÔÅÍÁÈ É ÐÒÏÇÒÁÍÍÎÙÈ +ÐÒÉÌÏÖÅÎÉÑÈ, ÛÒÉÆÔÁÈ, ×ÅÒÓÔËÅ É ÍÎÏÇÏÑÚÙÞÎÙÈ ËÏÍÐØÀÔÅÒÎÙÈ ÓÉÓÔÅÍÁÈ. diff --git a/deps/flexi-streams/test/russian_koi8r_lf.txt b/deps/flexi-streams/test/russian_koi8r_lf.txt new file mode 100644 index 0000000..7f27c81 --- /dev/null +++ b/deps/flexi-streams/test/russian_koi8r_lf.txt @@ -0,0 +1,6 @@ +úÁÒÅÇÉÓÔÒÉÒÕÊÔÅÓØ ÓÅÊÞÁÓ ÎÁ äÅÓÑÔÕÀ íÅÖÄÕÎÁÒÏÄÎÕÀ ëÏÎÆÅÒÅÎÃÉÀ ÐÏ +Unicode, ËÏÔÏÒÁÑ ÓÏÓÔÏÉÔÓÑ 10-12 ÍÁÒÔÁ 1997 ÇÏÄÁ × íÁÊÎÃÅ × çÅÒÍÁÎÉÉ. +ëÏÎÆÅÒÅÎÃÉÑ ÓÏÂÅÒÅÔ ÛÉÒÏËÉÊ ËÒÕÇ ÜËÓÐÅÒÔÏ× ÐÏ ×ÏÐÒÏÓÁÍ ÇÌÏÂÁÌØÎÏÇÏ +éÎÔÅÒÎÅÔÁ É Unicode, ÌÏËÁÌÉÚÁÃÉÉ É ÉÎÔÅÒÎÁÃÉÏÎÁÌÉÚÁÃÉÉ, ×ÏÐÌÏÝÅÎÉÀ É +ÐÒÉÍÅÎÅÎÉÀ Unicode × ÒÁÚÌÉÞÎÙÈ ÏÐÅÒÁÃÉÏÎÎÙÈ ÓÉÓÔÅÍÁÈ É ÐÒÏÇÒÁÍÍÎÙÈ +ÐÒÉÌÏÖÅÎÉÑÈ, ÛÒÉÆÔÁÈ, ×ÅÒÓÔËÅ É ÍÎÏÇÏÑÚÙÞÎÙÈ ËÏÍÐØÀÔÅÒÎÙÈ ÓÉÓÔÅÍÁÈ. diff --git a/deps/flexi-streams/test/russian_utf8_cr.txt b/deps/flexi-streams/test/russian_utf8_cr.txt new file mode 100644 index 0000000..0a02785 --- /dev/null +++ b/deps/flexi-streams/test/russian_utf8_cr.txt @@ -0,0 +1 @@ +Зарегистрируйтесь сейчас на Десятую Международную Конференцию по Unicode, которая состоится 10-12 марта 1997 года в Майнце в Германии. Конференция соберет широкий круг экспертов по вопросам глобального Интернета и Unicode, локализации и интернационализации, воплощению и применению Unicode в различных операционных системах и программных приложениях, шрифтах, верстке и многоязычных компьютерных системах. \ No newline at end of file diff --git a/deps/flexi-streams/test/russian_utf8_crlf.txt b/deps/flexi-streams/test/russian_utf8_crlf.txt new file mode 100644 index 0000000..79fed2f --- /dev/null +++ b/deps/flexi-streams/test/russian_utf8_crlf.txt @@ -0,0 +1,6 @@ +Зарегистрируйтесь сейчас на Десятую Международную Конференцию по +Unicode, которая состоится 10-12 марта 1997 года в Майнце в Германии. +Конференция соберет широкий круг экспертов по вопросам глобального +Интернета и Unicode, локализации и интернационализации, воплощению и +применению Unicode в различных операционных системах и программных +приложениях, шрифтах, верстке и многоязычных компьютерных системах. diff --git a/deps/flexi-streams/test/russian_utf8_lf.txt b/deps/flexi-streams/test/russian_utf8_lf.txt new file mode 100644 index 0000000..75e097d --- /dev/null +++ b/deps/flexi-streams/test/russian_utf8_lf.txt @@ -0,0 +1,6 @@ +Зарегистрируйтесь сейчас на Десятую Международную Конференцию по +Unicode, которая состоится 10-12 марта 1997 года в Майнце в Германии. +Конференция соберет широкий круг экспертов по вопросам глобального +Интернета и Unicode, локализации и интернационализации, воплощению и +применению Unicode в различных операционных системах и программных +приложениях, шрифтах, верстке и многоязычных компьютерных системах. diff --git a/deps/flexi-streams/test/test.lisp b/deps/flexi-streams/test/test.lisp new file mode 100644 index 0000000..0db75ab --- /dev/null +++ b/deps/flexi-streams/test/test.lisp @@ -0,0 +1,728 @@ +;;; -*- 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))) + diff --git a/deps/flexi-streams/test/tilton_ascii_cr.txt b/deps/flexi-streams/test/tilton_ascii_cr.txt new file mode 100644 index 0000000..894c20c --- /dev/null +++ b/deps/flexi-streams/test/tilton_ascii_cr.txt @@ -0,0 +1 @@ +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) % \ No newline at end of file diff --git a/deps/flexi-streams/test/tilton_ascii_crlf.txt b/deps/flexi-streams/test/tilton_ascii_crlf.txt new file mode 100644 index 0000000..1905479 --- /dev/null +++ b/deps/flexi-streams/test/tilton_ascii_crlf.txt @@ -0,0 +1,96 @@ +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) +% diff --git a/deps/flexi-streams/test/tilton_ascii_lf.txt b/deps/flexi-streams/test/tilton_ascii_lf.txt new file mode 100644 index 0000000..386c698 --- /dev/null +++ b/deps/flexi-streams/test/tilton_ascii_lf.txt @@ -0,0 +1,96 @@ +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) +% diff --git a/deps/flexi-streams/test/tilton_utf8_cr.txt b/deps/flexi-streams/test/tilton_utf8_cr.txt new file mode 100644 index 0000000..894c20c --- /dev/null +++ b/deps/flexi-streams/test/tilton_utf8_cr.txt @@ -0,0 +1 @@ +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) % \ No newline at end of file diff --git a/deps/flexi-streams/test/tilton_utf8_crlf.txt b/deps/flexi-streams/test/tilton_utf8_crlf.txt new file mode 100644 index 0000000..1905479 --- /dev/null +++ b/deps/flexi-streams/test/tilton_utf8_crlf.txt @@ -0,0 +1,96 @@ +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) +% diff --git a/deps/flexi-streams/test/tilton_utf8_lf.txt b/deps/flexi-streams/test/tilton_utf8_lf.txt new file mode 100644 index 0000000..386c698 --- /dev/null +++ b/deps/flexi-streams/test/tilton_utf8_lf.txt @@ -0,0 +1,96 @@ +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) +% diff --git a/deps/flexi-streams/test/unicode_demo_ucs2_cr_be.txt b/deps/flexi-streams/test/unicode_demo_ucs2_cr_be.txt new file mode 100644 index 0000000000000000000000000000000000000000..81d95bd574c19d17d115da56eb3537123d019fdc GIT binary patch literal 15242 zcmcJWdz4kxeaFwty$BhY!}ZKC!+#g-Rcx&i~ zcJK98gEPU~3}idk&|3vW^aH>}>a@a@DA`s>N3~nlF01tGs#MB972JCNK3Od9}A9_SWhBD(~F@jqGwh z79@o7MrdWLy!`=QjF3aezHhnbyakwo)&&#=YV96A366XZk8tDaBF}{-M z&*R?7G1Z%nXPl+W&?eD#Fy9Nxaz>nXkTF}h%fGT^8<+#e{eHDEBfVo`mXJm#^gt=)iN0CcZbv_v(@*AFOHqe))DVj`{ZCk2;=c+ES7`D4zEM zpT$Ym=9Y6`!Ce{L$6a%nGj|i`ck#e;^b2ioc|C1Er+3T?+uru(w!KpxOE5y`TkeW| ze3Z*fU}y4Pl)2mM4L4GWR)iY|$?WtNhD4E^4!z6OYW-JQ4tlvo@Jjlcx09$-Q@P)q zdO+~JXLzdGA+=^L*Tkj=^54nd#Y~<}-AiEia@;#tNPaJ>%4WGYmm6gL94I#HiLDu7Xqj9+3K|# z{Qjzr>RX|5)#5rRSmUa{#yX(-yQcbT#y(}XUuQLqaqlL$m7wd_kl$>r3%qMuzmAM+iXNKU`t|%k>+Si?xwCRZ zbGL?b@=Nl|s3qdL#C+0^FI1~{ps6(2gbo|1$~%C%s$W{kgjcy=DDz=-b+q&&IIcxk zA|73lSal}va2>=w%z0rr+G3`BVn-A}-529$?E|zk)hs`q{>4}@+Q*^&!Deh^jr7{QN4({dRLQ+k`iJXRa<`lrLuT~j zd+DNmPCr=`hAqt8b?ia@8^|U`-EQd9V5%O;+v|wMpscCnK6v!Q_A0rX?xE^Z*lO2y zyXJKDy23gtw8rXnWzV7A^?0uIS`8;WuUw-_?&V`2zFo=Pa;AI-ujiaq_*B)*)hgw_ zGNXeTvBOc>ytyT-l9X@YObZ!$Fi_uXogI-EL? zeGBN5se`GVsYg?L<9>pDICUs>AhkcW2aa2?$=0yclfR3k?EEr02jTl^>Ik02gQ>mQjb1A<-QMjYn~Q77fL_i4)=g!Gdv;w=^ zdS-PitJQG&TK(OADVf!iEEkl;ZjI6$S6!OR8ePhcyR%DEPn(t4Mce#fQCF@!DQk6R zw_(M8Vy<}X#%A&<`&q^xGY>qTSei{2{qir^t|&d4`aUpuMAUJvWEU7`=XphOPqsY; zMNz(@zZ;1r-TY0iq;?Ur0rH0oR;;CW87IYOyW^s~qUG{(AGxs`>LWIGAbXYWMDQ`N zK11}rEV(g-<)TGvZ?3^^4-ZRdJC=Jk|t1rNpFj+!r#hLcwuM1w9!n# zQwPyeUfyprO1A7JyLZ@(GaQ!#@YxzmlKdTTQ=Xds@;kHbed9y?Egt0-KLSLUyd{Cp z(v0_K*R4it$P+ne>ilMO+`Hy&@}1R1=xC^bZr8 zk`7nk*W+emm1XXscwAmKe`GUMv0LDPPi)3$7AQ+B1BxC$0G;BMNj;H$$|N4nJ}tRe zg~mpa)FwAycVhElaFy5fR2wHzIsRnoDYV@e$19<#%*qeWV)-wj+>gckOgqgVd0|(~ z`#^RI6>+C#6PjCX=1z=lCD{$#A=#{)Fk9dQ_TJd)-NlIRaTdF1$CCD^o+@UcNuc_? zWq5AxSbiAS0gJR^quL?g+B}VCK!;`T<5Yl{3zWcx_3ljnkGZT+oP<+UsVm zcoNexJ1y&z{M}>o<4AEX^w{iV_8GOCyQ(D8xm2T*3a^O7t8nVCiLdIDYNvJ(rRsb~ z_Sa~1AaysgjxeI#kt(8A9=Dh4XKmiZ)B9>x@O7oNmN(?uWv`_wYh@q&HeBnp_IY}K z&|Xl#p!9>KHGM1B&CuxCR5-=eJM&!T#ms+ZUd_CadC?0qM`^#r^@R-Y>lizlIl=il z;~ITEa}3yt%o~}X&_0@ZTcfAwF+mt$zYO+KxQo*pw2ndZBKMPUd)>Ia>LQ%^Hz2QM zer6cQXc^zkaie@53Q@n2`45x-EbZr&yYyZ)885->ZTe2zml>CwV;L~fO}{tjS-jIU z(%4VXF0Rsl73R8lXs7qw`KY3SS5~2|L5HhMW&^U_P` zpF@92dJ;Xx;V_5x?09Spz1ivcU`W#J^hL-J&4uYXF4`5@L2S}9pqb0r4L5!ZM29)1 z-yCS?(gIdKU(>Tp>Rjmtd^*QesJft|)cW z(>T$hBer8Mcni&2bI^8LdOH0X=DRLhm(lLQLfI@kBu(~;dnf%1fy<)yG{2Fc=S+GX z^k$|Pqsts=?tGITO<%F-=02I0yg%)f86}^I#|+~!Ej^XH{0yc$%ec4^#YFPTamB@H zCtiz?C%-6G(_(F;_cXk%k>Y4Y{G4wUxv9qgVsI}_FMx~emL(+(l93*`D*q;1B!w%@ zotL_dViqF~+vcc^O*5OP#F|`=3|X+ybeu0=#gI;uD*iJp_TnvW=I8X~=y@smo#>+6 zn+5;H=_RI-Jn!_c)Y7fsdOMS8PB^{(OS%Us`t%nXm<{Jm$HCw5VYEE;#r$F z4XnZC>$Kis>z$r^de-_I7Jt9L($;gW@@}3{dVuFO&|R>^p_01?b$-BZIJfYvqJuU$1VSFI=w5Ch8#Y#&+qZi z@fZ3{e!V}5>qNi9dfomwe=4mBeycy%Z}jurdw?}@cKAd6Zokd1F&-_9wfkfJDqvN9 zfpY@mWBlpamBD+Qv`AJ%p z*%oVpwiCghtW^2pAC(Fk6PT^GVtm%^`! zm}&TRq0e-**6b_M4+XLq{0orm>@O6nV6XjR;C{<P@YpqqV zbfT{eE~68*8!;YYwH@MxL+xygLvIw6lY28_u z54H%SZWy@3$|z3;_tag+$TL8j1H6C^j@nr>8+nQ5KunwE;K+tw20!GwAs8JD6mdG~ z7qDGgyo;=Q8(P=hy$9HQJ<{yjlVoSBIq*0eLrg&0T}> zWxhO#e!jx`&D~H{i?Rfe+@2U_;#^?uvYEFojlM z-J&AiGr=$Gh6M8Z*f?%ynGXwan{4oVf-Pu3w2CzH`-EVK*}5F-#|N_wvo`o1d`=MK z;fCv;6y1KV_@1U=U&C=PY}nnfx8b3N`)J+A{m0xL{JDm2H@s#T4>UXxkG{zLrG^I^ zo`^@DXn3GuCv+1qd^=J=rXjyJs7pl=3isR!EqULIGk1y&hUyHwRw z8@F+HUje9g=~vEmjP=pd*QcegO7;7rcF)PT5&VwHXfHKU6{*czNKe&n8!+vYlUgWz z)#_wdyMnr;Zxmdm6z*Euu4Xy-IwWl}4%--2wO?uLMrD=N>caOU$k*2n;xrLGR9)S- zsB4W{)|B)U-fH+czevlHer|nGRaQmUN|97^ebJfdq~`;TBpPeXX<5Qfv`TQVG7M?w zs{LGexGz|>b`|rZu((iFXe*rUg@swP0;Gh6%L?Zdh8E5)OfR$-$mv2~VN_v664}xy zBQu~8MibaoT%j+t6h?7P0U2AUH=G(cvFj`BD9kiTHAd5Hcuj>aa9f;r3LS81fwHYI z6Z|Shx)=+g7u@lXu8qdMrZB?rMiqtwYbrRtsY1kf4HWEpV-3ys1s~|xLUVyi0%xAl z;VW)6SUZ!E>4jRTnhVtxBSXp{5#vo@w}3f>dv&b2=&0*4$5wcrZCcf0K_g=`P5ULl z8}a5Sq)BqQMm4d8J;uptJP1FIMl+IYjXLrESmP+^QDG!)>KC}ZW(#sm`{BSFflJTn z9Q6gBNEEkN|5nC*I9A_50tf&RU`Es05 zy78ff@rr=qS;SDC^KxQ9$Bw>&s3j!Dak8=4(l-!GFU!>PtQ}tuz~5R>!)+Z3M89P@Jukw)2e3 z#AalYF?eHU(NmhWjzB}l6kIAvF;_=G*;q&c)qIjqUEVvLFJU$| z18>AWSKE|{&E^%GA#siAiglKaXaJY#_=g#77RiSr=}Y@KFM+t6RGda~s$NO@*BL{%UkE2Gd6!%d9Sv$&;7GSUk+(C)bqs_cKWLR$&-lw@u5|r^zEzGE%%g? z^Ll9O9g$XL@z6gYG(OL$^kkKzx5B>cm=8`L-w^57qk(wEnFlBLuM#~MNt^YIs--6% z=~4PFSzm%}hi~b>I?2;oaiu~ZeLpgv=a!3j8?}&UxJ!7qwU~d}EMc#)lz&28XTycOu69l$DlpgqY=*sumIwDxY` z3s>j8Ej%}EL%$s!UkrKQ@gDH@cn7_wyyM<$-oJal@ZR@+WujSpd;E#$w&=0*W}MgUh5uFc zn_r*X9eyDjwp6FzZ24mK((0r6B}0x5>9Ai@O5c0AuT9-QRNTH}tHo8%gYG{|mCtnL zU!ZB{wT46cGd*kTyW5r8+ok>!e?{5EP`w!a>wf`9V zYKiE2{HpK&m4|ww)l+2ov#xejE^Cw#Zr?Qnj5B^jUvVBk^PGP_j?teved2G+SJ@Yc z*NRvCU!9NJH;fsBxNk8XL_5VW{yMW9GBT>-=(1~_;rLMyjf|*f*4t*+&p6@cZN0&z1qmVZL?}?h}MH)4XKL_Hp+bHeI^sA0G zF}4xC68-EB?24i`=&3e1iN@eW=uyN;+4vtDj?=F;S`b|%Pnmq4Ng3P0*%(cY*j+{S z(X?o^8>ROboTu~O@~D>)Dr@wIQJ?WRCtBgCqCbkxjUlt}i#rp@%|PU>n`4}ObYb*4 zaBktw4i|o-qOnm!G{*5V$cQM-K}@41oFk(l9Evpi=jbmvf1Cd{+Sr-!-)G@eEx&TV zjpKHXJ2<|={0pNRgR>hj{dmt$i`Cck`>SHU)nj!(=jdWQ^?mM2&QBGi_lY>)t}jBa zgQA=B4`N7)_&5)a{=M}1TC9)zHh4Ai^hK{U7GE!#WLJxS{JpV*sAh(zfi&98oM~6G z2b^z2UyS}H`eyX`=v(R==f%-t<&^oSF}jRHnMVA${z>$O=vHX{H2PBX<&VCeMR!G? OkN!6LJ0#xi)&4I8n16u) literal 0 HcmV?d00001 diff --git a/deps/flexi-streams/test/unicode_demo_ucs2_cr_le.txt b/deps/flexi-streams/test/unicode_demo_ucs2_cr_le.txt new file mode 100644 index 0000000000000000000000000000000000000000..005dc2f8218d1b8cab0211d22a9ff650633a90c7 GIT binary patch literal 15242 zcmc(mdvsORoyT|Xy%+>?2`3>TK*&k1$6TR69v}ok69Ni~JOs4VaRvxMQJx7;YagSX zw$pjEYMstZ>*%!A@zp;7nTnvn0zOt}Rw+_TeT~{`sgAQ;tE>Jq)9HM^zkN^c%{6t+ zR9v&pI(P5$+rRz$eSeR=_j&AF=2p5D?ov0|&2*vbcAH(7+v3(yTgP>;TjMslt!^XN zp_Oag26!gB?ND~}8@lyS)L!N;4$sa}hO8^m+~aO?JHQaSD=2S3Z|JUd&n7m}wm)%` z`$|G>;yIDn?5?9e8?NmfTiq--m1CD3Q?O~H)32PFiY89$7e078QqQfnBoo*pVXdaW7)}VQVTbuLN;C_|&uBVUe@;(+N zq~{Ivl|AzIhk4m^DMIr6<^fVxa=pRusQnX2TL{i2l+9Rjp_|4znYvomz^fQvMf5u< zTR3L8Haz1kT?v{P?LfIx3vx!1_K-0lGqlN<--8yW#PG&qnQ`%(pY&$|RySZl9Y(#_dPbJ(>G559M^ahTU#xLv8&m=tDER-MJZWZO||* z6VNt1BOCT6L)VC1kGOr*?)Swb$%c8UGB@F zZ!NTQG!gqENJrOyp4MBbod-qb*j!ngD--ntqgJdbfBk^@Hh-;}bUyO2$5Yvt*IQ`k zeb8rvLs`3;`dZZ~yC~ODY8>B4`CZPFSe$ilHFmgPHiqsLS8q4Yb?-D5#!_0mZ;3MA zjgLZ|G3{)YvCjROHEvrt89TOxg*sc@0(WZ|lG7oxmTLb3eotLuxp);V%G7DhQ!^-U zat|gIS%(#V)()9#HbIGx2Q%Nv+@0A#ujYQ*y_x$n-y@!7ZV_W#GtCalUYoxM&L!)h zcNu*Pd|HzHL2&F(FCTVfUEs>DWG*5|0#Cbq+M6O>h~TU%`P z+Q4eo4fQs-{cN#{cCB$=O>9MrX3Q0|U1zqhvN=udH@a&Js9V6V%uv4@k$fU?y<3*J z&St$1w-g)mGhmk7xZ3q*u4ZPNL%H2*Q=xs05pp$B{4pc*wff%79rfEY=QNZy+}3b$ zxHz*iGt_*x*nHBBFEm&0VZ{=H9x!ZWR^9{E&-(e5Onk-n3xz&h5iR`~j%y z=+0E5d@%g^Sm^#w_Z%9r%0gB__o!P<`Tv1^ESb@b?}bJ8Io)ItD?!)+zV+_Ep!Cq{ z?}l!sRr8U!HWQ11zA5(1z}Am?RV-b84@1qp_4eCjzYX@=>MFu%PHmNT9W?0fdJ=ch zqBYoBe12Gns91Vo+efb#OBeRSJ9s_ktjDLC&HP-YwLqEC%!pX%ZZX_VtV#2%Hq*_e zEk25+$Mg>`H}&5y=I^LB4>D5~OBZ&3_p9eMjoB?A=>_>F#^V<73U>lY&9+Lm;dSop z=p|b5Q7pZ z&2paNI(Y86%zZOCEV+Uwf{>@A%L<;1{5{4_SDL#o?r}ryE@O@RF@DtD*jj4Rei^bg z2Wnl{^MdBWr51%fXx2T0#_I(IEAR>%z2ShKS|#Eqn*3V*on%j4==LX{NIsW*D!Hrf zpDDT1sXLO~4gFYhd)*UUKc3uE_iXa}Nx#+|OZFw-qV;IOO%5ity3@m8N+GdX6CFX7n7kp8G(jrwPfGhHZ5R(CjhFf~V{JQ>AqE)!h!Z zKC@sezrz1`@^R1};?z^eeybl&_F`Y&uJ_H_|E{|WzC&P_S7iUOq@*;XQF^^SlC~4- zQQE|FgtqtVj+uN1=Bf2a7)a?e?FW*_@vQV6L}NWZ^ja^q zvABtzx*O|d-Bf1yXV)#vFCnvso>~3M>gRB+tMUC(JgTQzE+~ur8l^F=d1)@Wp3jbZ zl1uBJF)L-)Qmm676m{jwQR1-I&RtLs6D`GKKflVS&(Qw3dEkkDOH=)R`2n1Y(qnl4 z3G;}0$GI}!{OCQeC>}^Q)u~6UUs2ePU%hspuYJjV#H^S6Q3l7+$xBjvcITuhuYQor z=0oJhey|@;8m8oO<8kCmU-Hv+&n3TPdVLR{i^8=ZPdr6Au=f#*n6ko;5g)T-Saujx z8VyImd=#tqny>E1i-)KkQMOv9bs+V9`o~_>I8yd_e99Q_gGX&l$fmp}`f{0>_m;+~ zkofHEL%*zg!eS;_%WV3l$ z`6vqyqD8i9bSn!KQQ3LGENU<=KbI}T&OLP+TV9_0kdIrVA>T*uwFPdk%k@SB@Yh&T2)#uO33+v%4A0is5eh#@<$53&}pb=A&2N zAIAgOq`Aw>@tL3z@fp0WSP?$>dSXo?|(mn^iGlsnD0 zT7&l}k`@tVV=wunKJtggejl@%_nPKVd1j~e)Z7*8_Fi+~ekOOX(N6ubT-L~@KCUD= z9)pVNHXG@>?@*NMZM45-qe{99?Nrvsx(?WgJ`P4d7CJy9n>D-oe37<;hB?-kpWzje zcoqIS@m21MYvAmBXY#jrtgr4KbR9>s?v6AgYUT0wa^0-WJ-o}U;OJ8^{WCAd$}Pm*4zc8Wefr96YQ*G$SQ z<=*Q*gYt6uFO1_9H81xC>-juA)cf`Ff2Y@}@*h)wzFeb5sHEdXWWC*w_9fb-$8+l0 zqsi{4Tj=52-auA7OTSsJHAeK)ruPh`WS^w}Ye+uUNMAv_xB681o77)5O>Y=p^^@;TnYU&6YxrB1NWZuEWX^kU(|W@AUnUyT z_AgwKSRu;(Otn#;4rNh_w+__WQkTKm!POi}-jP`A61X~3 zi@6@p^@XWvT&cZ1buslhxwf%f%}LFJLz?EKE=7m>Tms$udti1bHnV7(%h`^!CGd7o z7ru+>JC~Yhh2wR$X`O4>n)xEwW^dYC;h$!-7Q@(t9nwFYD^V&8llsmyt{TI+jw$7q#<9ZfXo%k|zS3>JZU1GdKEp4(_(pxAmv3?zBo(-)vbrG~? zt}epkbEpfs$1;X%#iE^ZIyHHJCg%rzCK~_VO8Hrw{>)49EsBZs74pjS9-U+@ zM4$YkSk26#5$>5_R!hEhAQtaiMQ(=4zYN|hQuC1_yJblpLEO@TRK<5XvYU)osJ)k3 zt;cLyJh%6YM+OiX6zgruN}hL@Q(MG(s`t$s<u=cq{r)QB(<<**YyW&6znf9%-|J}afq$!{_xGFZX+3MwJK<4_p5V3n zLD{H%2Kq{^*`|x@M(|6A-uCRE);IwDwXBeT*m2AMxu3oU389W9Y36|R`1FEwO}a8Y zjo&HhX1i)nPfX9CHaT6No|~>tXDBG3;C@{ccv#HWkK5OpNPJ(NE3HS`U0emM$)u&LwXU{(p&?74Lw`X z9Hpz^s7%j8Q;go1UV@~g=s7Pv94QOIT#Af#bVu}WM^g(uo6}_+Eja}0FUv~N(hNrx z7Eh)}GuPGW>GT?xzART?ke+}Q3*a57J-!-iIBV!rZ&FIrL*XyQOVf}dyGHlRleQAG zEk-gIzYm4y3beJuJsmHUfT0?M&?E3!enH&fU2FolZtd_kT%vN$jj0y&nt35 z(~gt|`nOo_5CPL#YkZZSClfmR2u7AW4`{dC`N{_YcUA?|PYTb$7g>LMh zV?+4#4mEDktm~h=wEJNo)?PGePtr!T_^*`0AX(R=-|xHH#g$~m5fN#+)a63a98kNaBt8RZ0BlqaA`0m z2rKUH=N?fJRfO&xxYq^S;OGcygQ((8YF`WfwV&&~z*+CnL0M2kZ9d%iTc|2B^uH^} zRO~R0p%w2TE8p`By03)eS*W$37Y5(kTQdi0j9e6z4|C4K42Vn_x23wZS_`O2qG#Ah5A>4DDQ%GK4n)wEew)b6MJ5v8Y}tonA+U*&gn_*rEwGpY6{_?c3? zo2dIa%hNZbsmCPjqE)l~I$Jk{wQ!cz>Z1K4`ns-f?wU;-q4`xoJGazZ*67~Z;}hQo z;$Asb2CyVz|#n4=t^j5f<*O zFUs?=S8Gg~bf~?hKO0u!Wl;yqih;Qy-HK0%NtF+(v*&@P1fP@^NW2nkHQ6e-F3)k+ zl83?~tA*cVkoQWkB+d@cKZN#)X0gwTGDX#LYohh^?WN>E>=~bPl2VwRBN+n|KsF3N zl-hWZrZ~^@x#?y9KASwIGNfd3-i$|^#)qO^Y1UVQM^O@5MWK}3(Y1W-HTaAlZ@!kc zVYCeAs4Vbd>|vkPG1gIxlF*Gr&nP?N@!~VFmRwTCjKliaQyR5i#sp%daqY2o=5oTf zXyp3zKmPOg_SNj^{}YdmQTml98n*f;}Y zc^BkbL#LS}&eah%`jhZ$JjsVX?>*+r8I85jtI^>{lknGqARZxpj%m$dmW@IXXNMm} z;vR{=gg(y8I42dSk(`>xqcfrxQv3UnP1j(mvuXw5p~jAK}RFOV&=X-N?=VS0{d2%db=&PWwmZ@!WDLZ=)9Q z40k#2wifYEo5k#FTgpEnuHtRg3f{V1%^Lklx5|AAT~qmv)6849R`!xj=iehU_@7W) zZY|a`QJ38rtj7nsC%F+DHiANH?^brWdhhLEh290eJ?>^Ce#brN4!9%kY4?JA)%~0M zm3!a)E+?@ftPID5U7lV49h$d^0q z6nfNll$57NrMR6GnfJr3ys7qi;TjSR`X@wV!^DO)4ccFSd;K@+AE-Z6|MPmj z(?_$T711Z7+oQ*$S?9N(&)ECV-~O)syj#PtE-~TF)E6c!O`J$9&YT$1JVakp^83B~ zZd3mc6@TBc)8eY$Gd*i--|afPxBGkSI%Hokd->L?9TVCg zb(AlfeoxZ=re8Pxu<5C$A2kWhT>9=t#yZPG-D~M7vhZ0~cT_%Wlo9^EOZx-Q{_*A9 ze(19=`45x$=Q%unZ~1!Lfq0GWQS|@S`GoCZEH{eZi|HwT59S9cBcl?IR{O26Ug;=^ zMnIrgkX>>j3 zHBrK(CZemjx{-5bKV>;RIykS+QIaNSuE|MSuj;5XnithreJ7c|J-Ru%BHA5=)U!}) zxr(e+`2K>LN4KpAUjoF!p6JIH@2Fqak48BC86y^taKt=Gm&OeU2jC*{v*2>WRNpxP0G8@16Gp5`G zMc%q8$CHUJi9QR@EtHe2*Jw~wMPqZagkeOK;!sQ%bB>ILa46ElIsc0D_xW#|wVe(B zeFjO1$oubh=B+z8?&SC~2WvKG=+5C+_?FmJDZj$^*SYbqEULunZq70N@znm@b)47r z$Mci9e7m-vvWgzF`ozt8xC zlxiE97um0}Cv@M4z7YLQ^v&q=(YNeck{5AEruS*MxQ^6z8HN8 XfBNyMmXGJS8)SbQ{T&+bLD&BP8p?lx literal 0 HcmV?d00001 diff --git a/deps/flexi-streams/test/unicode_demo_ucs2_crlf_be.txt b/deps/flexi-streams/test/unicode_demo_ucs2_crlf_be.txt new file mode 100644 index 0000000000000000000000000000000000000000..96dac59ed3d2b7ae31c9fa4c2a1e15780197350a GIT binary patch literal 15666 zcmched6X5^oyV*DJ%j-Lcvd$J4R*ik_bmGf0eWHI(#;~EfT*A`PG*1x+}N8nG0VhE zlF2NI8YeT8I66sm-0}w?6A=^`ammT#1Qn5S8%?4iI?nN&ocPa7CiD6JZdJXdF_VcT zr_QUo^}E0Q_q)G)tLi?l&KvBl@RoZQdE>mPUf`|uHhR6@CT|U`HQe`ktGo@~W^Xn-94%zN_KD&$}9t&Ti*W*^Iw*Fq!f zoWBJLpu7%RSuD^0Mvq5$ikITBv4YPE?yonE)c;}lEke^vxprXDWN#wBakSO53S33} za&loV*G`Tp-ZVT^Zt)7VinXrfKA|j+#BVoQw4JNGEt_@{$Lq07{&H5XRRn3TH%nvr zeMYwxI$_4S82d#2l3)7Z-HVr`cVD8RvPHggoaO)CD&D=oT#m1$XL>>zctL(V+~((> zzzeHr&Ej{Nc_xtlt+#^FqWk>0^sMuWaJtap<%e;-HiF3Z&f>4;s8k|6V+h*c(etEcL3To(X+8kYLOV(7&sk|@TD-Tz}+c}=A5^Hv30s8XwgEmcxGy@dhMB*O#mQngzDm6n5E zYLUF0dyV6XRIw>sZ%o}Mc)>F~)%JiIw1IPM*L{U=7w%wW&!Q^Eu)7NP6uz5OipBJ* z3T@}wXEnaE#;gI}Yw%6rY4%dZsj4;JyFi1Q4luUWUd>##(R;J@=Gv>hjr`Uld7XpS zUgK>8>qajCPGz*Y?t1Xo)^ya~43%oL^t_rMb7JjRm@!nL*Vitm_v7Y;tF7YE@7(~u z5_A(*C^s~h-T?38-nF%tK@->e9&eeqxUxnv`itI`g+A{}vSe1FudvNp6TB;1zly9Y zO&9bjOlkdUp|ADU!nXW5`GNVHgV}|pg%wnqnDL&SMm7 zZnd>VK<)CjaJR|)qq(u_=+D0zn)aw>L%>j24s^(*o}w)Tdp$e zb`V=ttF=+CY7XB@57zbP|H1UFrtZ(*^k0m>wSv%ESGC|wHY72jx0gdJi*4A+tm?IS z4|yvkt3Us04L;a?fBu#~qsWrA#6bFJrL>le3W64|2OZaW{|#g-y>31A2{2W)F_PT<4>bd$FbY``p75iAu+_f4`a6!3F{rQ*o ze(-jG{+2)G&jfmkT8D2{>0BMtSWuR9FhUl2H<@Matjy03hI3EkH@D`LkdAU`}j?_SUv|ibo8f1B}DtLwr*P3oMt$6NSfDF}1Rt5IVp_neS zsO&}qtvWQ8FRYrmm)qzLkXxeGj1oUDRXhu&zMW%cPVGxQn)-g~Xl`ffpHtuWf}EE+ zlG_FRSZ-VDQLc~VcBh_BeJ`HBQpZwN^T3+1KcB-^S<1ZWzVtXPwsH)7Hm0e z7@IlEl1Di9qz)RNz1Xhypx zp!f0IX7kt)bbAjC(G_n#ntBM2pebIimh=>qC)KM=$gP7%CFHPaus`(#e#W1v1Gz0; zYmy@xBNq{A<*Pjnkd>P)Yur=wChAc@wb7HZo0+ZlbFUSITYJS7V4~%SGTqH@st2lL zbC}~Rv*ym+veZ*%FBZ}^pI9y^haQ*R`sH?F%^@;D5!#3K;+mrgwN zFZe()dpPwyVDgNplMKquH{LD|it7GcdkUIF17*ZMWSV^QJ^7Q`O9cDKDso$~m*!=h z6suj1i*k)toUaGTmVMAaVZDcQSLjMS9|7-^#PW-h9MM>YTI~0c14rqpq&{L9qa1Og zCzf#xzZ|mBw;j*y;rB3SdF&p1d63>C9EU9%dz4l5M7{*-vdL*k{zQIw$i|B7O1!}s zh$SXIL-RMK4Rqjgw_TRucjYbIuyw8U(fGk%N6=EfK4fD}_8cJJciUJr9G465*^$VS z4!hx}%rzV2e@5YZ#)(X@xRhJ{5D;PVmIhACQo2{X59h8lAEY%NP3JhX9s*wxc@td^ zfD_w!ILCS}@(5Pax5w;N{ZKwAva)r*MKy1@R_}6`Q8RYicyk=(*(83sHq(7C)K8$v zellTy615~#P4{SwL{(H4D8jNvb(68o{V`%x(&93_d(!Nzu`E6s^~=}hlU$Z6cM}}& zi;W+R2xW_9LSnlz=9tATn|dtwq{%#%drFeA46ThOu3B#V?!oS3;3~%(s6tMr^8NAD zljwUeidsxnou9Ga-!G%(#hCUGRv$F|G@9gzy%G1rxye+^JsMlsYPFjyv9=j!A9P1$ zxBP3?zz6IDiRJr}$nJMmyQoL94yB$<^3h~ak=`^sH1UPW-6JZWLRN<4dyRar5Uf=NB;J7$q6+EKfXq3?5iw z9x1O~nvq@2R|ZJ;h*NHE6baP=WhNtlm_A0N+*~2=YF0QbpUZPrS>>G_MyYz1WS8?D zS$UK>$c@)-+7G+@kzMe4*m%22s%(+}G%K-EG3l)u{X{;FZJDh$0upI>O{3+BWMuT% zXk|1Sy&KD_Ez-MGyW`rgxQJKG?`ye3ti!^c~Nh;`bW;>U}MH0@$hS>)9XEKAwF`y-2ClWt=d; zehKX3a2Kc7X`O)P1+J&z_L^~dCH7nP-+;ZG{i)%cpkd_CHL6XJ|jC zoaXKolky_m-s0Zr`x5<3EWB6ko>) z=qp%P-Af$aC;p1YOVIobjii;L5sed|&SEFyC)pR#_jRmLW}UE@;z95gWwXO#TgmN| z`R7$^euZA;qcYBUNpz>pLq9c+F*KGhDe}9n&q%J51BahLXZbIEO@~;6mrTas1*Bhu~Z?)0Q|S9)r?Cq0MuRDN^Q z(`Ziuve*kaPvU+7m_6LhO1E=vu-;3-nwwtA{dwF^PEX{HemKmgJuB)P#oes*JTN3_ zR{A1jh~^{d*>Uu%@`YHXr$aS|UpM^tu89`2O~ctx&!GjZd>p4|n%p_k4)`>VDNuDm zHPJL?tfOT+mPiBMYNQ3JH?2fF3%*mM+RZvReI~7AJvt&==76`*JT@DBr>3WIKi&M- zMQaJ|9;}qzvPAM^v$%J1{}JG_sXfhi9Wh%wsepElO72~5$WbSiI!q8 zwcj|C-^69QahaN)!d2b|)BVc0xE@7D63cPL#px$ri;ySZC}L9+eWd$Te6GHvzbcB( z!;0S&ldu5XOVabJ)NfuAxN_Xd}E~A)9kHd~euJukeyC+AwT#6J~ zvCy=fCx1ndPLnGM(=7+YUHr`3=}Xb{5;8s3MmabW{)^K~O(%KZSx~KKY0lT%7=8QJ z8=Mt9M_)l}F*C2;gRiIE+3)?$e0E!CZr;jsJnuA^vCE(C^?qIN7u}P&X6qo?op3pQ z`qCcH?e5t>ejlW(dn2U%74EH;zAtRBHvvWH^e$if5wy2J`xGLNqK)<@xJuLuRvT7G zirz78r`6WahHIElf4AeN|2Lg`Yp3@h92v%BrYCb=W?`l&(~z0Sd3>hB?z%H$GE-=c z%d}?ZWJY8PTzh~u@$1M8%yehkGWLxv(?VZ+W^|?oSWTwLZyf!jGSe~_)1H=Dl&Q^3 z=G>H-n;8q2g|VmLG!eWphF_Dp5Wd6VH8GRVEQV6Do1kcdwiDT5rV)&W%)HEKr+s{m zI7n(5%6XX~a9M=b1L4t)^bq=PBz2-?N2ZRWGuFYpAnOJqrvscutR4qV2lpc~lb{=& zSrD}sV(Vmh>V4!H4ydJR6Ev;HWng9y_yh6OM7YSZ;R!!Ut1;^mUC?+u6caO-7>@$d z^WcmCv&GH};WU=JwlWE=*wRlI^K&QEgNV#IXxxcL4Vl5vipOx{F(%W6zwk$eFS?CZ zK4>y8jKZH|_=V<6<-|C+cA{4|)MG29W21biD9hK9EC0(Yf^@?r4}B*b%j9O74O2af z_zmPYl~xnDQ;EBLpv+lBdpPYHXq)=mOeW98!bR}z#76m7JmUBbrY-1T%W7S9H#g(H zy+$6y&!M<;o|yR%(k0uSC(%;hD6Yy(`Du7Yvq--K-m+YF$mSNt#2}0QKxmqP<Q(6PX{d^sQ{LXUe2@{1ht?A(q<3m8#|UZQFZiuw4Qpl!75w)4SGBni|ie$`hS~m z0(uLpIvZH!*Ip~_nOhV4!{lr=41Gt?cT?sjT6!-Va39y-0C{?M8~3OpyJtA<@2J$a z4{CiWUXL92byZr3*R@v71>MP=c*PuJ|L`seZq?s5M6WME^456jyRh|}Z#?vzxEX%^ zpFx*lnWNeYegAjNJ^0Yc(zgrQD<0Zqv5NEB%4bi%-5>40;|2a*{yTo3U-Vh0`M1}9 z$PXjfygs{g|h9$Y-*Fx;>68L9q!ACJQKo%*1@K% zzpH);eNO{#_VEasIC^K*EM%4}0A@O^1WUI3!v6v1&HhNguMDdbND)6smv@j@tVgf1 z{%-TsN}p>zS>->ECwlxLejV+V{@q|-Xq0LA*Ok%z(jNzWH6B@Ot-GLG>30Ep+n?l* zE5mH}e+blh*!hlj{eT$e1!z}{yed04Bk5g#T!pRD<7Ja`+P}AcAvizuZ#T;EKI6{s zg6>rP5R)VxXjeghx;|qv${4y&-e=HdHk{3(J zFY&3XPfG`XNc|;(l;J+7c+)c)JI45L(>iUD#=qEcyZ=id@A$8}vp=@Nucz_UB>dk@ z?_K1Gyg$-^fHT?Qx0n_&{0CV1K$+al_;rY%0e7{(xqcB>Wka1mnO1N8qB6{<{a@4% z@D+p6Q5?@Pe-`05$>4YS+tGs9l~E}QP^-Sv4 zhZS#$8V@#}^n%8HjRzVZXuOBkJzRgp)xn=_{8rx*ZRy zd-{62k-lD9+Ou2Qi>vRcTA9atLHIUH?<(r4YFL}MkUQ1MoxrsIj_auKRq0Es<<)pd zJ2G6I74`<&uFg65Mr3U@9y{sPY_SF!VO7>>%}(r^K?CjW5U25IqRQ-c@NO__*;CR` zc-O-(_Kh?x>FDMc)pX4Wm0$l#TItzCtNU1I?TdAK#&btWuNe0V!;pTZxnd4{+`eDU zfED>tTwJUvwiVCyg5peCKGK5XlHz&AfyHx+(~9jy^1aww99|rn%sdqs^iGFPSWQsW zaE3>*r8t~(3drbUgW(K@8|%s9?&1uSHrQyI4X>%#1#V01t6~RyTA*z!&VZtZzAkzL zI0){zNaGR4e{gZA;SDbi0oGJ>oKwY+{=rbNrjB%sVo}ThA6;xNQgh(V+W|O>-(aks zLC>^e9dymb+Nz!bWss2mCa_z;9Kf|U(O#6y2NBO!xSng8)nUa5`ev8~OM#ETufvfi z+2uM7j;!o4PO;V%6j5ZFkzQx?aTG=yPstC9!)R0Kz+GkbAjvEk0(=B;X*!Lgp~!QO z;+NRa3P#5Gx=0R#n<5ZETSE2SCJ{e-F*$MCitLL@qBcu zu}D;MU4oWP#YQkMjlT|d~=nIwOQLOY_E0;+K)-@4J@^uCx;+6;UI zHoEGk%xpH_*tm)6Pgf#EmZAlGrr{^Xy4fXP4&z=HL|F>NWvJpcjGwBRsLEjp`XiZ@})ZN_x}DAGPE&7pdt+0Iji=8E{)NB^$T98%gbthvrT7v;Sk z+InN9xm-N-?o0i1jY>~*dG1!*9+r9F^sJ?Qw+r5-|4GG9i4}7jdTGbZJf4*<;tknCo*ysfjoV^xiMN!M$};|Ka=GmlTfsi+ ztGti0r~6~bo4{8neS_*^r`;s}uQP@JX(iPHsjJaM>xXrCLu;BFux35FXx`q;&S2-q z?L4vVM9bYCd#1c^d-r+!y(8X}-bwFO@87+jd+&L_jx#8z4;q4z!FfS*&=LeeKDZ!g zZ_U?SQM0mUSIwuj%a46Hx2A4OeJyn#Um~?r>LKl*NoUjNrhVR(H}D>{gLlJS>4`DV zyqB-l|4s63`7!xb`u{@fEv;W~y|?vX>rdDV^mXsxHGe(hUcqjh5H@3HWpzRmJg_NaZ^)=n{f`?q~r?fcq)(f)(>qwPO3OQqEu z=y$h}*&HAX<3_(Vo_F$gr@6qsz|qhLZ{Xa9Bviv%8&k{v@=+!U-W5$Y~Fa zzx8|>$d+)c{rWRx z&m7~EGO7{b+;CpV>;Z=zqs6X7M{t}vj@|Ej`f?n3n%#$Nz&`fZVZ6&lutTj||` zX0e8L1$J4Y51OhCPOLLHA(|vODeM1?;W!QJ!ujDv@|J196EJ) z()Dupm;BD`!6~FiQ;TG#X8$SFLoNDD;uD5X9 z%5fXVml%sdIN0E<9!x{NNzh`ZHVyx}Ebkhyd@a9`NmRA7c@4jhCo%kJly}!8kgK8S z=J!VtBt?{*7f1e18hs_v$nC4X9*NowEv?1b3n$vy@*vu+?I5b7!5JVUY?RKhGg$=A z*Tc_;e-nNq{A~D5-5ck{;bP^M`DjGAghLre6gmHC__^?AX#OnxLioi$M12eI2tOPC MZTNS{yi@-8U;BlJ$p8QV literal 0 HcmV?d00001 diff --git a/deps/flexi-streams/test/unicode_demo_ucs2_crlf_le.txt b/deps/flexi-streams/test/unicode_demo_ucs2_crlf_le.txt new file mode 100644 index 0000000000000000000000000000000000000000..849caea81445dc089f4ea52ffb48128f2057c951 GIT binary patch literal 15666 zcmc(mdz4kxeaH9Ay*LQWWwv<_N{co+*NL=yU0y;GhF0WyA7__ZFH;1t>U@Qt#CKFO>RBU zk)nOtz4VjOm{BVcDtsa*?Om6=`@AkUVgXH@?7_6O4gEVchh*f z03J0_#8WF*JKDCo>HMlTAXB;&IkHQ)yVCWz1zeF?PZnE&{B>?+&T^-=u`IckHqy@9 zTO|=KucxiFlI4H9#XX(;B|mH^;d2$w>kN_VKL)=AAYDY-hDPVPsoayvt7ZkX^7s|R zLJw&>*L2s3g^D%43RD4gDfe@W;z;~<5=GlcWo_xS9Y3x^Gug{)xf+{GxAmrJkl$zR zw$M(LAr^y8WG~sJ58l04Nx1v+2o)`|o#!n3_YUCQOPP=H)zr+)w~XL4r8#o*+%wIq z;1apn+)KS6yDRL89{%^HN>&4mY&9p=l;HLo++vnHjHf zx_MY8P2KQ}^w^b%TnoBA>UNWpMIJ@VN3A?d`R>FyISUDYkXq1npw!c=rRV0Qei!_` z?u(HxE7f&0p8Gs#M>lf=_*q7@Eb_K&3zQDv+nJdZuj$+$Q|S9ot8Q7-IijX zN=}fv8yknKRB9+aooSG|C$qwBjwYkY=BQL^yPNNBiy|UCVoX!+U(msqF0#11f*M8b zR7SDsq&K>U67sM^6F;^`j6pY160V0b-^$#RSx2k3eA#`O2QuF=zpBqJq~B{4+D6)E zV|?itvx@RwE8hs6W-pC61IL>8DPd=zrkHwRJsu@6entT z1H6xvuXRhxugi~#-EJ}3mX48GBIat>m${m;Z#L;x%biQvSLi!e!_8mQGhb=y%iP(t zHFHLDMf2^=7etq5uF4F}Tk&$U(rT=uk$orgoX~6m&nCw2os{}HqA>r7Zs3YzpjDT~ zi~j)EHF2==k~rvhI@2YC_%}z98xw_@R%@$zO2P~|K3ZjSq+eS!P_vn6+-UaE+&J(W z%zq%oM|&R3U-)~#w1qg7FXh#Z)?2oa%EP`#L~eX^jcIo?zZ$Jpb7{38iY?sIZZQ9k zhIe4=!Tg1PA*i*2&{|hx!Krj8_(W?-tyt8b6_w1J?lHHV^#2S0SfXS#J`f(QlvWc_ z%p6fS7}vP}qGSuTem!*ywHmcVwE>@$T4=C+O6x!B(_sFxe-vq?ZnEE2`)#)04p$vb zb*ihe=XA4H?2}lTtE|~(@Ux?0OoRCs*M9W;VE)2iyeH5uY7Ms4Nax2f%^Zr7HhRbc zcdKDSM!Kh*s8^rrlpv#=uDaEcLZFn{6q>uBu=)sHuVrVsQt(MLCe zS=h_r)n;>RC)Q_eNGp{Myaw|hNO9`tO{c)W@wf8-#2;YvUmRa&~9(0!lG%EO2 zfL2!5<6X^Mn)Nkm4V;y(WS`j0zUpH4^~A8mQuY`TyReIkc3ys!a0nVA4(id z>`FYI*q3__^oQZqpE!`%OS-M`WBJv~q2Ec`+!9#_;dBeK4p`gWVAO6!yd`CG<6fkD zq|)Qr#=<^U(bnI12N?TJmreXilP3~SfO}D#3s|L8(sR%pZ&aK9z zZ1H4X<7D1K--A*3ByigD000Hvi}okA&V*!2_R#KW z8#iQMX(K-BFG2dAyl3~CrR8sna+7rcO+q|+8BbCx>v;QNGqcP=xP%CoAN(963_jA^ zKrK)1ply(>SntP5yU=BC&WlZXf9^#ujcA^ej|jE+6gJmb=Y1Lam~dz$QXhGSUM_n* zN0~;VAn%ZkrGB0bvEgT*Fan87=;6Y&8~NKAx5QU5E?Yj8IAn2jIA@oFj|vg*`2@L# z;UP`btBS`i&B)^K%OxXtyT>f7`Ff{3YJO2%_7PcXBb#U}=x3z!mea^8>)dQDHJ%lu zd)qm%KbKpdbdi5N7eCUgpC|DSeNx`tY&~Bq6?wbKdjH$j$0WU2SM`8`w7u5Hp8==u z8Qma~-Wqj%~a{Z0>BJUZvYgMI@QZrNF za4|FUMrP%;to*d5E1i`~*8!z(?KP`w#i-qhR+aktqn)@`l{fRd6@J8$8(W)O; z{YTZSRX-w)+!69GRUP5!7*9vZo#1|*dey#8=}}7FsCtvKBUSHMZNwLY;_nlaohTyr zGSo+CCr)pWJ4Txylb(dz>&E5Ps$jRDQ1(jI&y406InVjHwSAE`YX3&nztiqm)ep(P zSf&0XT$1t<+}_FKeVKYm@|4=!wAvcIoff|CO?VYX^0%rq7pdliNj^y`?nmM9I{c4N zDl4d5l&8iTxs%YpU-gq5Mp+@9ND&G_|m%gEu_olpX#4sKw4gU3t3kfXWOrZZ<5hBAuKFof_VF*g!Vo!+;ANBXBT8N}jnrop z8$KdlMxzt7_VzrrMm~asLH8Bx$oshd@A`UOvNhS2oR;iJ&PaAA=a8Sl-IMGjKaG-w zN#1vm>r7q@Wj9Z=NqIwKwTqzYNnXzLc%IKoPUT7UUC9f`&(772BnxZgHMGz;AqR~G6xRxX(fGUl6LYulcyf+8M(_S>rP&1 zw8AZU(plWwNiVc^-N>FrSx54G%G!83AFIzMFYLiSV;1akFZ!LiX6q<_I^hbV)4IUV?SAhc-Uli5?~`=C z!oSth_l2A6O+eP(9rQq>8oeFx=R6dhI!&Rk?;44Ed2T@qNzpr|ZRA=8>2NLc>F;;l z`oC`Hzheofu0<)vhSd1f{8W9aCN-7cDXBJl>Pk&aO(!=w)s&i(s!L@^yD6*ZZcA09 zx>7BvVYKGmId!e6aj7!O%2HYG$<&Wcb*3&M-rqZ+)sKH3=^BQz7;yB5^GI zL|>LV2fm}>H8s_oTFA3x*VCe&w(ZD{Q?*dkq~;)0EOW5_P^d0NUKjM!utXUs+K{W?`EZ&<+EOH; z30;ExLMl7A(|RbLIfHiXJlEha&ttUln3(FoUSZ0|e0n#(@8*3b7Ysr=U3J3*g<3g=Amx2>u&JUZukGf2un z<-ONvsD{#7r5Qugd`j7z;z-SdV>`Mfp-jTB18qCOt-e@juRgaB9_N|`g8XcLd|YAQ zH2fDxf0|0~OSf`jX(OYK_DAa(&u+4jEqsI4dVYbuLsk9n@=ZW*VKvU`+ondzRdCgr zuYgBCMn|ryJ67^dB)+}ZYBr?> z4OAvf%hStEmtUs8Pm4_;?<=BePjA8+XI2Z#d+3-=SCTJq=`u?#Pb*yww;y4NZunK2 z^!uSc$66-Szoe|t?pNu_l&?&`n_g|X`)Id3-9g#AaGG31*@}+A!rpeW_7G%wt4Hq4 z>TJ%c(rFWt-iJf6uEOz($vK&RFg?F|6Fl#R>zUP4(o;w~Xm=t#yjqgPL+FazpG>Dr zhAckY#dUA$FESwY`8Jqd~jvF>Hneb%Znovapy;pt1Qq(J*3 z65gX`9C}QIC;Lb9w4_$j=2w)wmwqkxJE_F3C)4+XW;p1j$xyTYnDisY3Hp1@DAgVW~nUS)BVUd&&Cpsdm0fnu5KswCmuBJ>FezV>UzoP%x>W zF9lTEduVkZFzZ~b#~J310;#h_`EBr-096aLkt?IFgXhR~TDj*U#C67h7}!KNIy;=-dL#)= zA{%Gx$d{o>z!-dyqI_JoAv?+FI{EF)VXA=BIFMG-t|41Kpk_!>Nlbk`)Dxf_LRy|j zua@=smQBbSWymVgqK>-r%?_7SUWfLhktbb>F%5&OwCpxc0d;8$@0kXqS6chvg>lAH z^5g7C@(tu#vnxy=Ns>;(DX$|H(oU`#FnIq3Sxr!+jIa0PNUSLj1nbrtKS@!2dr53u zg~e5Ksu(Ga6d{nW%8avYQI|anOl8=nVgT36Kv|!yh4PXdbpz2UOwwPPcr3DH89Ie% z@$^HepJ=-KD5;c>b9;n|*49&05EH>lJ_^OBIATZAHzt5@7#69pej-^R_6yM(xPO># z9#TY&H;EilA{=pkOccXU}B<{!)+kczbd&;_KAoQ`CVHdT({bzi>2| ztP#}JK@+s_{kFheJwo=;NOVT7o#INCP;{%8sdrc4S@q-)lLe0FzwzTwM;^B{6^alkzITa!BzBVqAxcAp%3mY7 zHOfi;D5yr7Ha@bvR-IPo$Gl*p)7z&CJ2L%~MdzqAhiXT&ja`N2im><5ziTvy6iy6l zuJik%X3kpa^r_xz`4igumx=0otd(|i%{;BNGc0qV>E$GqzI^o+%~3sY^Z(+}ZcOK~ zH$tJD_FKYIIODA|ay#H%_@7kRC6>-@-A*TF=CW71h&N>O**{*w8@Gl0$LVrbDvSBI z$rZdoTgv;utC`NPz*xPX%v-@^X?sT`n^IPsAx7QtX&${F8HTQ4s7w!Z1n>^3zs3sZ{jgK0l z2~iX^M`uT^QFGIkWy{NUlzqBPr~K|n+?lv5@zumbe2LUasmJUDO;vJKl4WwThIg`U zyvOd~oqC8A*IeGL|C_WlPi$V%tp6|E(e$;Z2b=ac{j`a*2=T0VY5ei{j`)dq=Gk3m z(<}e;*T3mH>$WIrET8aJ@^cdwmmev=Jac47+YtXPNPNRNIDbml|1Zd|U2Zl{Yd7lu zH#TrLIq-y@)=2BQwARzEU+0!r**fv>(QvR$Hr7oQ_AvqjD!jw_Ey2en-aV z#-bPzx5l2obode_o8v99?moLh%r1$A=z8v|*q{6_CrTH`Yq_t9%Z+b&d<9Q8a9@=# zxsn#$+*jvH62@na@kv;#y0|Bv8`oR@W@3M9d`o<3yd#dtXDMyqDYjZ6{0nj(-{wIG z%Rw#t<#~kRKMG6oc!bp70kdd?B+w*`_A^H35mv_Y;)~2$La>b**2?_W#na<)q&4x3 zc#M^*<}b;e+J?*H71Z@{|8d-F^yA}|mPYPR;hI^T=MMY+#};5T=MsD?!V&xa2sy6+S6gfPr<1?_BOnO@$62n zySTo{#SG6Kxik0`!bSE}!LJbhb-rgTiEGe&HTRgjS9P*^758;{uYNoich}}imeHb% z`;T%Z3F9Lxj`_V1eL0WFpQ~PnL?Mt4Lg?bD_Uq%opVsyz{*?CMk~-_9=i9HMC~{wm zKNtT^{Pp;=@i**QoELJ5r)*RgU&bX`*(h><8s8S*PMbfAKOcVqn})usxXLLvJ+@_1A>6&&=V~a9ob$&E8GkR&)rx%edcw+|awO`e`)kt={9^ zRQ*-!1E=~JeV?LtCRkfIHhR;&3puviF%g^Adb-M*iCp`*ZiV}W-sgZ^PpiY5%+qWy z4C~?3;k9veU}u{*m8*KCRSmwn!F}hm*Xm*_f_!i1LktMpPuPP6?$QAB3$O@j$(H& zty!GQ%om~bZn+JNWH7husqBU^LFGvhJ38e z1^Jp>!1Hifnc4-Um7a%EyIsHc5EedU@B;n2vA$?)BC}|vH(2JGwa{^MGV|Z(sW1FW z3@fv_+DMIuaGQJDm)%gMMYVu)LejvZaS{Hg(w|pHLR~J1rwdL#iftK6yTXJXR zhURVwXXh8^ms3l`bFulPA77|e??h8+uo)dTQk8cCbydGKlL@bKy-?=E=&ESxM{rz& zu0%XqmRNNr?{FQ&J%wyxqnagcbr4dOyiGi9Fu!P)t2ipT zSN4Cn=SuFi^;qf$sl(arseexWzzefp>QHtE@FUqRsmHiKn%$XtI`w@w8>Nn< z4rbp3`b6qbYFFx!)V}yR!9J2YoI02~klG8!t=MF9Sn7%2MN)QNnVduL{WNk880BuX z+odP?A|bnp`#zqL%5_in$@s03{Ky_m-HHVVt#>0=>HjFluGD_xu^WrkK9C*2@}gbY z_hfDMe^PhQw?DhpydwLLWZ{x+H;XpK_P{N>jlL(c8_h?D(CIxiLr47gSn6TCfQI;W zu#~5uJE1;BJG&YVgCPe^`rg!0Jc|cY`?8z77G%1$+r>5(wf5}g9AMs5X1I6P4b+#A z>Y;a5H?vv|=UKDATQ4P}dXnXWve?a08sn-P8PY3eDn61!-dA1vz1l_zAa z&g^!qI6%x5k3HB-K4m{k|D)!C#}Z4k>7rl$1=|&+M^fJhCXa|Z&Xw$ZKF(WINd$(7V@Vm3hjkim+z^e*G1`0Q|8lvlJ|UhXG1_CS5q`VMBV)SU=E z3f5eWrlW+u&9I)}V6`$S^W9J%MUTB?z}{lKl1e7M<53aUM`^Ff$`aK?MlH`r zh)qd{W%%`k*;r+ndpPcwm(3s93{~uAIN%c-F&YKR63c+1#}7iMcx6(LXP-2QN3u^z zE>@wjQ6#m=jn`e+d<0zObv@O_NmPzMk$Mts_s8){s4BDagR@xvODGRu@qW`z<40cD z9rHezokB(2rO|}uR-3sKW1C6#KzCR+D<{kr_<+4Hwt7!7qI;diF50oA1F0vAS!fcd zK5rVH8#|UC#&y6Vt=On`$hS65;}Otq+4~q(BFQovHKxgKa=}HfC5a=DDXLwLPn-!F z5ub%CRV|KTGO8p=RY&vYQRK^4Pg$NNmFNkpnQrEcGa{Z_l4|3$X-D6`DEwDG0@mg>Xx!`Ksg`# zL$&{)ye+R;4V7oM8Kr7hoKwzgWa42)lpCMjv>$O5UaoHA) zb|Rj{w9HP+`Xqn%+W0tH91A@*IvIUN?Z&PuiF7X2=%m6cBJnJo`fK8=`lQ;a6-22z z-=6(78XZjCg{-6WXmzBDsF}yD<@%YMH}m$sh8cW)X|Cl9xmMZ9%s%*QxaMiC^Ys3p zwV-}M>5u31ZE)HGFTI-zr#O3Op3S_F`OnNNnddVvcwy!k?H9Q|pW%BQeaA8>+WUjq9W+{Nj2TF0Szf%_@Ay=GiqaS_h^8<3YX zKQoNuw2W`&gi$^Rg{WW8{D;YZhW2yHU7lVs885=?EuNjWFVQbK$1`A}n|^Q5yLg9b zq`se^U0kIzZ)lEzi|mx#Q<;;-`&rXP@R#Y4&L<7?w3@=<6!`CAhdlI*S)W+@obi7h zU4MpWPjY`fw)%MH4Xk?AB>kjFC+{9NZ_D!6uu2>y-&y=D9OS*X=*2$MThy2Yim z9+anxO3`ZBn$Wl?%KyhqzZ2Z!xH>*SU%|4Y;;uNn1kKOUM>;7EHoAa0Yn_Cj zW?n?s*ReqPblhTz@4!}c%?69&%L-Inf7PfmBHr=@$+b7)WFoSW{VJsHR%FXTFz=S#rs;b~U7jcdL2E&*$9dNI%E z@;oIyi6{EuFq`(QxbGaEW~JwWAxX2+7b8P77o}&rXjfzhu}M#dW)5dJ-1sdJ9cG(; zv!R_s3t0JhP0uu`bEF&aE{>^CbwV}C^kqz=V;gozK3^Bog4CH#qMZfbX;zV0#imcE zaiT?gY{wk%7MQnYqwTbG7thnpcb&8@r`>~vvRQUWn(P(#4xTRpE{odI{6>PFGk9v} zX-0Yxy3Cg5&Nt~XJS!I6+$YnL_ouyYM9F93G2M7fOHbu4KZEJcGA^!1F_FA-Tyb&Q ziPu8p$uEl4v{)PIJq>TGr`TH&Kj<ZmRLW1l-Hg^Wh@9Wl2ecq^Ae2%D>4LN#RO! z=cP`gm`RVrwlQjb)6C{6u_jB9Aqy6mj`QTJ7}8-<#ecfRUcAN4{G48bo|lo|i7v{$ znebnfUThl4^G^RtE!_;RuOs@USYK0?^S*l}twqeI`rf>jcE_M^Df8KbpxJga@7jE6 zU=A*yr}Yh6-}Kzuv*zEh`1}18HlJ&jceAy7KTp2R=+Eg4VDI;H z!BLOi;Mx5EZ>06mJ-|YwC;IL7)a{S+r_!3>xA=4X(SDwL53okgc7Lef?YH{I$8V;u%^&Mm0ju&0 zoD=9j$M5nlrQPK(^sD_TTpRtl{&=`7aPr|Z39NC3UFBZ@*HLhqE9@ zAUX0Iz^M1<`C}99V;dX?$xK5z&mRt#h3GsK9^J@}pzlUf2RgRvAhGUJd(b`Ffu;5FNI0er^u)LO>B1v}oSiFvpK>S4s>EcER_pL)LrTJacV zJjVH*_zGW?`Jvk=Wq+f2;2bUkI?4YSvL)GFC(}~jIoy?x^3fsq9^Un!-7cwKK5ThQ%1iC4nW`G#*i@T&avK-BteMV^{S z4VNe98@1l+Ho|G}`{GjUaoC%od;b^S9{lEH=+^;RDSGWf=;hj9dQS}6g0aCnUKrdR zyb}xrg@Dyoa7W$8f+&XF2gc;OmClzze=r>QgTb)iPVV;vcLeW3*%vT31}lP#gE4hs zaA$&DH=<5l-UfSBu!&Yr&{P)%x6}H1@S_9^4xUku3Tgw!VlY3zd+>axF09Mbx}z>1 zY!yb`FmQ*JQJxC!uDhI`r-3#FcmW+8wXoy|g-C#nQh0@?~LJRd)@> zm-+G({+W!&o9MfnY>>al1P^j06M|;bAc6l7>mDr1+=wrS2R@i9gN=0yxhwLu!4z73 zbqkAlPY1uO8xqLtW8=7;Wj-vxZL-1d4z{8J(JIo&?-PO{X6p*9A0Nyz%-Z04@Ht70 zha0YYQ*`UO;&+;c{S7C)uwhTbzJ>=I?xl4v_aAe2@Mjyo-SDbm+~4qc-1`Fe7aJaE zcs%ZTyy5xvsEX9;E#OJjZaXlolapE~eAVh? zRlAb9q&*6*QVMq+ZCA4#d_9sj8;9-ms@kuzd84w*YIb4&2=cYtL7XO{hpMaFi@MIJ zWlc#x;jMw6^NX}B>F4GLRb^H5!M~!Fbkh5Q*5HZ8+U@DIOlp5gs|5E-!;p5a+RuT9 z+rg^2tC$~!MTM$DYvF7!EX<@8ASEnZUO2Zfv~YHztI$>;rwe_BQH2pnWJ|sDOov7o zjbK-Cg}%^S7{xUOWNe|{aBAShs;{uKFvBF(7)_JmH5NL-ZFb%%w8Nzt%GSaR@T=(Q zq%VYCaK}TsjyCQ!g%O4~sxTZ_W5MxF6(ag;pkUP-YiPbN_&~=NnhI1BIP;DUUvaC! z+8Ok86>6bsDpXhW3@L*|^f!Xt4CWB-)v@NHqprssTi|)NX;q5_qv@Mr+Ajt^8gGt5 znk1KNR1;g+W1O7EgYe^MG$Faxs1xsxHI9-V6-Lsgeu3L-wjjr}9}avpaOv5_QD5MV zL~)DtZ=v5et}cEf;U&)}UTri=$)F!w;&EPBj_(95<_zsbuR*y1+&x#(YJ>;+6wX7N zD)WDdcSznJn z$~v@F6p%RFo@J+#;4=PP^R=Ya;J@J<^(7ygRvL{it7Bc^HUij4D9+YN+j+)iViPjS z7`!o~=qZg_$D^4TXl7P!$_;;r15XH;p< zim8-IikLE4pXM;7;EOFW7 zEb6j8m$%NEGd6zs?sS#SeeRzv+Bu}zQ12I8S?R0#CvPJ9$A@Nx(%x6iTkb6-=k?Im zHzLi-;-P;)sDG|e>CGy~(@NXfF%O(R_7LgUqk(wFnF}ZPuM)i%Nt+Gys--s{=~3F3 ztes#x;9L5yPV%-^oT<=9`$y*S-f}TtqZaTEcPZbt7V%G;#q4Wa%0D5lu$@uM*#&%! z_X+P>?~};7kl%6iD^4eS$tLsfk*WMoD6R;|TZs-@0j$OcT9e#}4QtUtbMHoWxH|7` z<-KV;`t9`CG30&6yWiXE9rB*^PI#|+|L*<5d(Zog%a^b&tPjV8=Y~yTa~OuX@cgi? zC0BK2)rzVeRiD!yHg=`lmb#ta`0nSIJM9#DSUXD6ne^G|fG^PXe5GvXt7~U^lH-{3 za@G1LM6NYAF4wF5^)0uye52*Qmi;Y1Wk*~ln#tbdPeivykDfpM{BAG&ud3ht`n>M& z3)!%_I{ilT7ps?6AImQua%@Pu{hCtR@8x!zx__v+b;mY~tKJ9Qf0ioW>B@JYY2~$+ zL+dlWYir-_Dy{8Oe~(@J^$RAyT^_byeziYJzlqzPq_#b6zij(q+u^n!V_yvs-GE=U z|6h5iH(I?#mcQ$2Mdh+a8R6Dl)4@37NAwlv@iWi)_v0A-nbRlUTfW+MAYLP0@qcwb zZhIIr261~a9Yia|Fy5V64jCC$adg_X&T#xFh(<KKwTK68vu z%BV(1bEA0?a{?T;k?C8aPe+$UJED*_|L=*Kc#70(7=I4LX}3w*mFZUHt4A~IElvKMCeh(Nm>6N8;;YjHkuz@EKiwy-bv}($vHZj8nL>H>Z57V7}v|w zUvQqze=DM1dZ?_?A4Yw~g#SJZr)v3?`>hDf;q9U(cdDqt8cw8~q&; I@A7K?7s?-f1poj5 literal 0 HcmV?d00001 diff --git a/deps/flexi-streams/test/unicode_demo_ucs2_lf_le.txt b/deps/flexi-streams/test/unicode_demo_ucs2_lf_le.txt new file mode 100644 index 0000000000000000000000000000000000000000..30fe7b069881f653b17858602581c6cf9f658c89 GIT binary patch literal 15242 zcmc&*X>?uHbv}Cc8QGHcEMHBQZAn+}anZAlYz>}dY|!8l&m%aL*0LlU<3Y0IkpM{{ zO=voVAvA3X#SMXCAU`}cctR$&85Zq|F~%4SE<+#=lrGj{g+FbYe&62ry!-U5uv##y z>#qCGx%=$1_qX@iXS(;i9JAakGc!%KnQT1MVK$jI(`nj~YsYhsX*C;7m)U@4PtsPi z4m{On3n)AA>zOs6usp|H>s_8J2eRfvbGKPpPW&0xQ&G#cL zBhRVGCUZ0LQ^Bj9onTnCdEU| zTTqww(A!_+W#wWE(es=7NLh~Ob%KZGS3}wy;9Q8b7M4sj<8fCb&yrT~vW=IZ^;?kE z;hJO`;2E`aInY?NedUfziy2DViHO;Xl>VhH+tG6CU=d?Rt?Pi7Y10O=&}#0Hdfli; zP8)aD7xWYT(F56S@D3682sXwB{iRar^R^7RZJ=o^cc5g7)bb!6!94EgA~GH6{ruqXNDmpsWoj)MEq8>*Nj2L?SrOA5|1UG40M|K4l^)bRyhUqfr%YvP(rPB<2eZz zWw{C3u*dOC73_N2>_v{=cp4TyE%YSld!12%cZk{Q4DIZz^K#ggDMNMs9O&E3J)V}P z+gXGb`!0|cRel?#cOiErC`^Y3X<3j)D*Lutrl#=u3Gr?C%p7$-{k69zqc7B(Zs%j5 zPX!J}?JDF~Gmo?lX**K(<6Dvb6!&RZoHQR+HJM*mdFBkBKB{UqA6KQfCAFw;(aP|y zz0!4B+T~2G&V7kiv)QYL9h<#$opolmxy$nq(;h}G=KclvmAX)3aS2KospBzDO+vcf z>~`3)23F{(?P09h2#URSCmu~aoLGliwJF-J#N&ydp*?fVJoIsnG+UAO$oSoNENKV5 zP3WEAB3r<<9+Z`sw>o9^ zT8G)J1Jt|0t)szL8J>>IAShC+0A16N*U8weyh1DjoJzPj11Ph6_QUy)|$nU zn`P8%GK*kiI07aS8!JptVg*LFX-Kz7ZX9U$qKB-26ul-T?yc-e++VpRaYZ~kes}y@ zZ$V;tVxahJf%v2YzTjBB6EhYObOS>dM&+HL>Zl*iWaP_SFQof$nZM|3xNh*(r;B}S z)#XeVXGo8Go*CxZIg=}*Qc&z%H_~gD*-lpnWhmKBQaw zJl%*lwjW!vQ~EWFv)`;j`u~A_I3lA1z9$y0b2<=3mT2jVlyW>G*Cw<@U*BYUrf=z2eae(hzk43X-b(qck>9xd)|&!vykS|PJiBqOuE$^% zOBO$9U+&k~XFGwU2go;~KXw8yaYrDjR%XctcpWP{ z)FLhO%9Ng2-v4t~KiE6JK>9bnhS7bIe=|nl9E@9?VmW)i&gEPe-GUb7jKsN{BUAcp zvlP3yChU7=nTMPlXBl<`9(GBy(so9=#@J@EgLQGY87QlaR`Uw{$ko_tfupPHN{?2aa!s~>f`D?GE$IqJORJm+k$_-CY8 z=~NtZc7T4u*-~*7&xf3y6)!qJcXX~h;q*EmqV%|P%-Q2S;~Wg0E%ymX>UEAd2as;9 zxEdC)g^&NQG)+&_a|}{$gPtQ&b1%?wH$l17u({#@G%H40@O*{tDygft;yz&O6$`rX zOZga79m6@V+Vzs{)#D`=7{xkAv5#|HYDTPw(ea40sNw~& zl6EbEb@T&Uow0Hp?XXAg?Vuh(Yq34{;g|7r2g(nL2acvJji&ta3vjZPo`Ls|ibq)6 z#>x!wqk5jLc)+QtU=6FEt*{S%RqYzDz0O{=Sr6ie5o}v0l*IPg5lCTN{UV6w!-$Q2 zz<$yZOwLl_F^HF5=bIHTIo}h#T0>)zxc0#l&mrww`@36-ykH$bRB0?>r{+-akI92@g`yp6B zU$Xt#9_beE2Zfwtp}Q9m#b^4n*I6NH6#h6Yh;2OW#}iS12&4y5Q#JQGwc=&QBP~1# zEwq)rn^C|PrJV=FqPTGBShg5;?yO+nQhD@4*ltyVd@pLB1daoU0P<;j+2|y0+bdKi z(X(ZB9ANLD=T4w)LJW)H$FpK%7INg#a(Y?)kq^|j11Wt%RE%BrD2)K?@m|zppUAIx z7Gs|Fkr(hxtB9C2Z1iia>~R)D((__jA&{#^_L}3)^FVSqXfInUGb+D0iiyQOy?6*@Fl)x@&=%ZMXwabs&M6af=UI2~bj%qtDW2VlWHX?Lxv7-%T*d9$p zd!c#k?P6R#)TPKWim1Em=yI8?~ls-;zmZfy1Q-f{g7V$0T;GJwq zX%R+a58{b+=nwY&UW{t$HIAY5%r>dXvCHaKuNmNeAy{iPBL7SfHMFT0Pn2x?AX{~_ z^mMK}*vggC+dq_EMcwIkGU~0a1Ja{U0;BeYCZM6s99=bDsO_L&w)(;mo-JZ$;UA)X z8N1}_J32q${0<)Lt#|~wPC_zQM;sA3^XOWx19NjX-es)A48AFCuI)Rs_kA1Ad7A4y z?jN`ow#DCu3~&Y;fgNH0R#J0j)neD(Sp zpuCm;E8#eUoXR~bHD5&y)_ynt-%;yK{wv78n$KQCRMhb%WPOxEdmiP~qnzA()W~|e z4mGswJ;<`7^auHzV@N+IdM_fS?9-_K4y2y~l^!6Soc$y9%ti2jn*T(O^-#M`v|9r&A;P`_GyI`G~{C_N?oZ=p4)?JfMi zCw#2gU#nQFX{)WHtw{f$5`1To+ICerZ$jf6mz2^={kJ=#<~-{B8hD6_Ev6Q~9ayUx z-iJO$hQ`wwY0Fn&{V8by)qSa~bK;u|u=j2FhEd2EP!AE)MbOT{*XmJiPt{HeJ+37h zqttRf|9$vZW1d)vz%#117V_0h@Erf4(rlX1618<3v>%DgDvIw02&odwP&JWWH2cO+7}5L_+M1$Z8b z=ZVqrcw%{D^jhSn1!cqWG%Y$E9Mm)|Iuklr=Q_~U-+iNlZ8HUB&A1yOZ6SD@kSD%t zQMVa6($f3uRMFZj*lO`butDCm*Mon&(CP$Z4eX%)33wu6!VUHASxzUZSQp+DqwmNUxK6P0&0QwEE~Zpw;5( z8hCsf@ca`gUW+?V={GNy=($1T549ZJy>wh8s6^V0K*jU*Q8IVG|X-SB{mNY>s+jjzF*9b3BtC#Af z##EFjxB5kq5a+}I$wJhl1+xX?bn%r^>O?E$PeD#SLTT#fg}^x%@olj%_ND^qJXmf$ zulO@j>I}}eBm7d#w<*i9-(8B_Jj|zj-@Jhy?ei{W2F@UGw(Z7VThAi!ZJ6DG^Bp$d z>FMs7^RJise!oQcILqs7t^0HPZicD8*WuX%eXGRx_Zwxmo|OH43wT(<9XwAzFdBKz zfM2OO+O*-h3izpmZ+o^PSJemoO_(9S+;#i^xgNg;5h1UIF^mDRk+Ipa(pX_^JbuT< zYUQahHaa#5x$0PDtT|Q^OCW6mtrT}{EIZa1tBU2IHr`L8tR^-hmIYc?EQz}s<-=nQ zvFnj>;vtpwlwFr{N$KtVhc&6r3@Ry=y9W?u~ zVsI43rbClOuc=C)lqhOWkL5zj9AM6dj7I48QNIzI>QJ*bmWQh@K*0L6EE`&C!BGs0 zt5KsC&n2-5s5K%sE6C4|mBWhJ;O(p3J`ER~rKnRWQnF(M!JiE;jfWK4Rg{uPZCPTQ zMbZqv4+PI#Xln%b1b86}7;2%Fzq27{4AQDJ`IWH4Y7bL-xDK@kqD`(qy*fM>qNP+u zk;oVwtB0@Xi!c%zrEO?`sd!*GJUJS-FJ5FUR6}MRP&K0Nm<-(sNEZ z(+DYX)UT7+v0BT7kMudXvvE&Gt`wY;(cZM5@iGVbBIL86p|l@+@wE!p&4J`Pc!!>) z4BK)!$dj5QvCNcDEwCiCyd3B#+lT)LK{qw)?*!ynHXJGAkv=LyS?KLBmm}8D3ffza zelSp4JsWjOL8}0+I#ATs>0+5;C<6C(`wH5)K)ZIltr ze!=B>e2%=$WI4Y%a1_)rvi~>ld>_iulwS!s8n#0!&ps&{O6itzzN_c=N6tI;UFe3? z80&$L?@(rZ z6?$qc#&CLahScW1t_za-?iUxq9_8*vy-VNlHo_bVWf|_54xYayWBQ+3!YZFGu>gX zSMYF(dvJkY;F*uX-R^D%N0VFT`UMXlcdz@eDXvdlBejd%Jhv3N8Q_M$iK-xh`VYE^ zf~~?au;5e33Ts}3?)l(&5!5oECkCyp)=UG{A}57tR=KOhhR@uW!QTbMJt>|#w+kK^ zR6rD;z_O&9hrE^0D85P6kpK(n=e>sEuh+Wpw=klZfR zTIJS*_A%sCr}%1Mm-VQ6i{2doJ?dr83@S(lexxm3(DEtjhZYjSTcYEl`-D5YpbHWo zgv>z&W8JYx>rv~Rn_ECVlt5%*?Tc7Rf;0{BNm9`<(9s??Z=8oveQ6Zb;!J0{JS z7v0BzBNwP?!9el%F!w2uu*)qM1eX3Xta~bjt_z;XEr@}0H9R*5n%MGr?nF@9@NBWY z2(Jz(7y#-B@#Jdv3h`mGpc(vq~EJiMq5|G`Z4Y_;mmV?2Ff|e$rbs! zQ`Gfb_@3r)@!4X$11&yS{8aJd$UTnqmq?X7ldPX@v}kc>qy@$eiF}G@@(<$ z;ytK)5PVM}cL8J|yxQOeQ2UFHp9O&?`ByYT!7zpnF}J4e$h&~#Sd$t~8VHC#I@KJu-D zJjFtkAwHs5C!;dQdCoz0H0Oy zC?k@E$W2M+KvErYJCoOlrW~nLCVZvI`lORAhjePLg_LseRDshoStzN;vu7HFt}=+V zM5N~c75R#ix%e%G9%6BlezFAlEZATXs`MDBBa&swF~Ze=--ZBBHsp)|$~@F6OGYwE z2BcAZl$V0L9GnA?MgrulSDLC<2~9%luwXN=c8-A?O2$N?bnB zu|H6gjq@-zRrVjUNipR?N+R&4?QQHIZ0$m^z7TlWN<_<6$VTk&nZ8yH8u25=*VLAS zl3ZMcX+E?b)~L2vhoYBwW(f2QmD~0gjl?p<5+h~=thb(GuT>f4Xe0J(#o7|YgqE>i z$52)T305X!ohZsg(_oa9fJZIR-Wkef?9($GX|4!rF_P#5Ml$;o`*1eelRef(pp`c& zDD@0S5*w?7rT07FXMds(HSQJj_2`XdpqD_0_9o&l0|MJabd0GFFw;gNu+gEth}=Wq zFQT_`X=9S@Gz2%tF=`(Qt|4NHMw439AZ0qLsdp}4{|R?T{C@>c4skZ*{$eXu`W*f3 zPK5vX;H(gyedWBRyOcOi81YOc-y`YCV*UeyELO@86ti?>Ir6? z7D&>6m2h9gbHtq}WsW-^;t0^pYBu(8*W=yR zJp9vU0nW88!apIF;BD11ymecFIr>Jk(tHED#^F0oE#A7-<1E<({Ci{){wLHB%*EUj zwaLn04Sc{g$*r(q15j}8?ZOFH_1;#@(A$A;r@0LhA2qwp0dveeZ_b(v=HJY3%;)C! zfy4r@&>QBB^vb+)&-3EmRbGu3uUwk7Dr-m9omo7?cAs;<^MLb1XE(mw@ubjxIZ=`y z9U8@QHd=`HowayBT#q-^8W$!WiSwTjRq@gB);Q1C-&gsg$|ouhSH53~@AUpuf0=)y zf1iKIpK?{>Rp@*F`McjYUU`@2RYb}^h<>MhQRGx)LE_Ya+5!BU5}xh6Gyc8No-wYZB+-|KQkrBTC(&~+Ej2VVZ`p5Q$6<(K^BB>s7T zN6(h8krRkF$Qecbug=wShB03#dKObDdIs}S$`C&bSH1ieNUfOf`a}Go!MVrnl717v zL;P_*IR^VRzRITs-v?#0-|h46kxL_Vu}?g=;Li8;qBToTA&D zfiD8Y#2!iEvnT2or_d0m-WD-=h{N(Y!uu`ZQ+#>;41cD0iu$*r1Z!OUmiUwW5l9RD z$^I~*vg9w3>(76y{8p6o;QnL3O}Iz;t0nc!pZHe>l&SEG-j=c+6nblYz?1N=^X~-D z?MTN+ts~_hjHtE zTo2&72N&jS+@84tzr?ptp0e>ve1Dz#zd|9b?!Y}P)t)?`+m8F@RD0eS#M@0N%1YE| z#QjGB#qlYJ9vt?i@cbaaqi2KHK_B%KKjj*Ky!>kW>v?0P=sDv{DJ9Y~uaRFyk7s`5 zf5-nD{~`a|{*UFElIP)~O!}w9pO1^Y^p9u$)W6HW8+HE7|E~W%_*45QOTM1#VIcck L|L>sj5$O6K-PL^s literal 0 HcmV?d00001 diff --git a/deps/flexi-streams/test/unicode_demo_ucs4_cr_be.txt b/deps/flexi-streams/test/unicode_demo_ucs4_cr_be.txt new file mode 100644 index 0000000000000000000000000000000000000000..f13d4014e60625c9daed3c7153f8e548c7880bf2 GIT binary patch literal 30484 zcmds=dz9r@Rp)Pabw~(w(^MsaAaGAr<EK)br>kdW>qB;7n^CY7Y~kaUvn zq{%~c9DFn50}x+`L@)?~e?V{?MV-zlh>Kx~sKId@L>&-yn8jKy`DezN`F!?0``72* zy7fS3AaO0e>zuRCKKt?A`}}^t>h2W1UT<@+*E<0AgUi9W;1W>4L2xIy3ETy42Fe@@ zxCbnOL*Q<32XMcDT)Tfe(2ln61?t>i=Y{bWpiZ7Art-~?F9c7-)!PTm=?Hi|I11#U zfUAJ(+kp8N@Y-H)<0lvo0nTlFgpqR_-^`fjs-2CWM&`NKfdXCxv?XUkPA>!JSKP;# zIFGq?lEa+iFZ{Z8?!I$l)Teg76BygAK-q=hV&EP%FphG{aE!g}%!PXA*7*zSJkM@s zo!HOZ9I`JKnO_ffgDWcvWA>P_n5XfYvwd+R$lfT-4*>11r(d)8%&!1*m-n`hQ^$RM z8n3dfkMZc=m{Ql=)m=v~kJ!pPls$iEwUKu!?HAAte$C(oaQtbi+ld|m?zxByt6 z=Yt(}G*;z##yqr}KCfdgm)4{J>nN=2rNExadO8}H++?iD?P~GbPwtP`En|9sy}Q6s zP=NVnoUZNjBS4?Yd#P)4ac(UR0ne#t&9a7RD|1$!{Uq`}Ts!xS&xQ0=n1ea%=6nzHk1?9Nb_;lM z9be9vHBer;oPFzXf9|=*_vfBIl*RLUfw{4qS!LDU+|%k>ep;Q@N2xk>od1PhZ~o`N zJ9@prQvut{u$BFv1wRiyfP%T!^G}p<{uhb;-QZ`)ZzJ(9fe(YTfzP-{KwX{GrdQ-+y zK=uZ*sG)nQZ%xq&U29+M#W~~=&sd(zYKdCtt&nGH>+w8q>pA}`!<@X6BH&tGIP8V>^aoOyDsWe3#g}>iaE{`hHhwZwVX$?jHmze5drjQguqNx52nQi>-~Xu0K1urtdd?_fY1( zd+~i&7;hP_r9wZ>>(6l;e}wtn zpq@8|jr&;})^9}5&pip82;k43 z+vl$a2f#_3%{Y;DeIhURMFIMM0Nf3d1NWAy>^4UC3$TxpPxawG^jf+0w7=S)FUZ3L zt_J)0F1z*#f>)A5)29RbqC7DWv91z(nH%O&p2=vfvcBFAYfgR3>5K)~C-y{rhn8p8 zxxM7GjAwjz<~hs@I1JoVC;LS|Wo@h#`+97Aqjc7aJ$a8m2aq4{p?v54TVkH~RKDa+ z9eGslUG?te{VGsuJ?z!2*&BxQ;K16bFY;ce4effS)@-fVzfqj7$M0IPcf9WRwM8|#mN8$cOit=LoV@i?v(d-7iVnabyf zyx8~2i(J)yjAv1S7JnvK1aixFNAG_Db?jHqD)%`huMYxkTFb_kI&m)w@)fXF>?@sn zJjmCIz2n{7&lz%1W}Er;X70P7>hvyxt{K)lj?3cDrt5zEImgB9oe%t0cV72q8$0EB z$jfA`75hr(9uM-hVo%i@i+!!O@aZ@Lb$?!jQ60+t@`Te2J z+{0CuZ@!RaeEKr(gBA7X_3rNu@(xnh;K;k+{V-=ab6=k1;Y=_ock^!V-AX>qQG41> zeQPqo=G1$7y}of5a()E-2KZg@DDwLl|J`uyejl}|V~qYx%6jUznd8GVvHmsIkHfeuX5`1 z+@F|_u^aD$_%6(esq^_^=5j}Fxfk))9QudZGk$VTZsalM)S&-y<~|Rzx5{v@Z|-ja z$IxNko#lBH^W>j#O33X;hhyv$SJXJ=#(WPlYd)b~{jU!9Jlp@@%-;^Q2jso$m8`!t ztFiPiVBZ`cMRu6@+WOSk`u+@s?J4WUxvr0n)pPonGvbXH7{cdAhWp83^y_N5{Lauu z|FPre@^1J2MkvTv(~x4+0-E_oJ3ykor> zy6v;av&moW$B{mu7rXa_zO+4|C!(j?{3i5Pa19U9L->vOs?FFl|5~f)@9ec2m-_vK z=u~d9kE5rwBadwzeU@-0II=GC&DrQ3c~=IThxyxk#^!m}!D+rz zYQLLDypJ-TdjGrou~LoY+dGss^}T8itRuGEPk+i^!G2xGGsON7$+5X=FZ&1^v94U( zo5894Xs69t`xn$0$hmtyn18hyyk%X~ z?|?kZU&fbxicZ!b?^}NxvgF)nlD_S4`M^#*1JYi5zs8=Oo}2Wp82NrwNA8WydS*?G z%eB2>%3n6G#8vEjb_^*0PB<5j=Zecq#Ci!)KH%5mqT-i549*u1-*fuFv4>qooU z6Q?l8Zqzk%#9yCd!K1pIjd#sg8MD^ozTV53)t;4Yk5^vS{VdM@8}})vhih!fopG!8 zC@>#-a^$&yUjO;Xy_4ou-%U}^W9+3JYk>Xe%P(TIFt^_N!*X?%08ACVv6TO+YgwDSg6IaXJM0rcH(T>YkDqvk=(joIaXs~>}v15F=uUN z-x`yg!9n}%j_>zckMMgx`}%G3)wXreuf3{WpAkM6+PgQ4%vc*)=vXIgj>j|dOsGEM zo6lJ5w_4U`;=3wydJz5WXLI+tW&Xx;n9+M-?8?<^b3?!T&Q!;9S@t#_Rnu@A2;`d2qkRKBAv|kHyp9jehp6XN}7oj8lH=Ufffkjou?`R{eDS zs!ZFSsX1m}~V>#eSJ zb`GZ_&li2lv-{W!p5?#I&p7ZCwXE?6=iU*yZu$N(biKdkrrl~Q-4cPagrdg4@9oxD#9kQnxS{mjiVt{mgy< zx#zTTQ`NbdQ6B}QOr2YRa&0*(b3b*pq0D+ZzZV#nqig-UKOx4gpXv3seir->@L$0n z4cEr7_0vH4pVYZ~e~2CTJm>x&*YWd=p2t?~yGA$k)cJGp7eKk^{sz>u>aY55`_HYq z*a+MIg|)V|W9%7|K9sqqANO2;2^gEQjD>aEQ(OOY)%jD#{|3^Aqp~L6t&a`&BbGm4 zu8;KX_}_uPJp22=ee|*yW6yXp5BW7Ne1y%GTXj6Iz0ZQirn>R>9@`n=DCQS37WCS4 z@=jdg-yUT@biTlNUY)1Dab&*o#=48!xRRIDSJyMfnEGk+Yv45E@x1oG0zCWqx|T!Z zFLkY4F7zp{%8dt|sI&D;PUYFNZQlAI_t5_wW9B4J&Rc)xrd{Ru3}0FE&m&7tJd^nw zk9+!d-_f?7j_VN01Drf>CJ>rWZ`txxCcxhuT|w(cF7I$_Dsw@mpORGv-U#P#ynF_t>R2R6Fe&)#-s0yQF~uYeUdMq zIdUMb14qF<6}|(Pz@6YSka~r=cmlkqH$9`*+q50*1Q&ygz$IW2>;lSNJMIRT0_Eze zvzI(eohx&nZ;Cf@chtRlK4SRhDp%H?dlqZ= zl)nV%V`m+eT@K76{d@~^^xOVk_1RJH%_iy`evDgx`j9_z>3C31?va~w{i?65>aFyC z-Si@KvL2pcuHDdw+xRyKFBrgYxk@(eHpTSRldk*4Kx0%N9LCG#ZH_< z9zK+7GixMA)BO#!Cu$fJDD51To{iweC8O-RbWr`ZJuq9OyXet%pzyB z=a?Mk-AKFakK~qpk#VUnTH7mel6?BSYdPT#MIKoL?~3+~&F7o3nU680j&;(8dKtg{ zgDm3BxHGnl+fje=DSwl=)Q)Jde2Yow=X+ZD0v_FA7)y z2LSg!{=H0L#Bbb_H`MVC#sa+eX9D8vY!>E1j_wEEwS(XYxEtIH3b+L*^Bx`o1uWH3 zJ>{NLU%dxF0m|>J^Ne4;0wNrduJxt8v`KA(8*SYRd}gGNdzcp> zXZmw4Z*nT1p3#naj!i#CT=M8S_l0MSw}5TndfYdUkCFFFx3`n|S%CW&GWgmu3%KK3o&o0TTAS)= z&rusE0?$)}Ehi6sM;y;(?Kz$iTfPZw0O~o?BQfg7^UngjbGN(;>-2k^1`3zN7vx1dCt*P6OsEk39d( zsaICUNDLXvCeG>8^G^ZBq91vd2jkcY%v+!OcWqA2<S%$NArBdceSQ(Juawaj6Z>H&d&aNLGySs%jI$(+%aF&n$RlRc|E`>^e4&nQn_ z*Ya;}%3bH4@lunCHMfW5uErg6`~S(nyff!^?p-j~JZH^Z>s$VI0{M{_&aImZW6s)S zEwaAGxd6zcyX)%c$9&c61Nn09opqjdwO?z^S{@?CR?lkaiosQ(ucA(R@a$Fp40Blz*yaLEoeCN^DjX59A7Q;}sXe~XT`>5u8d)y5)o-ks`9zpcuCl=-KY+lm-a z>3pAx9(hdjybReM=C$`CPPj6znfbaeH_WGx9=9=LJm%&&$>*1lKg79x^~@)#E-}k} z7fb6Ked`ppc`>8;jdNagI&N-2Ph=hbj`=5hL;H6#hhyz6vvVPG_ZQf+?#YGz%}e>_ zp?uldoyae)KJ;DJGY6~ekC4IHv^63wx$g3PxY|9l%JjDh7&m&$eEmK0bE_^~Oxp|i z>0}Qv*Vhf;qN=CP#ej3m>}^N>sj5dTU5~cCRpm1$EY~xS;0u06`tc#wUj}k&E^>(f zi8aLj%x3ofbf^>De2Mw{kYB;54PrF5&L7XHX%M>P8NU7)efdQ<o{W^JV7px~HD;PRn(x!#eJ?`JuOr{{ix|>v{5xXTUzjdqBp* z*%^D{?NyH)XRbP~v&`lnuxBj97d-g9lmD{-@q~=LySsXDD2p24WBTu_4(F#oH##@g ziG8WPhrz{w_~bfk5YL9}Z|~m+>YisF0(?7m9IzhI|0H|o0?sVU)4m|ys5vzZf7S{4 z%$0Smjy~aVnx9KU$GWn=%-$!^p;ztmX%M<{hyTtt-U_1EK z1V8W;T$`7^$RX_CfP5e8vw_dMw7Hr2FI63S+<45ni=X}O?-cK3eh|<RF@>%&?dvD)xc?|}-wDcZ2l90r zI0qDPA8_p+{Sx!S=sWueSOVJcocqeurT<30-IS^4IlqGn*b6+bEcXj@ZCE?^j8)qO zYy(#S_X^OT@u{awJH}d?xqHf$xu>3eQYws-J`F!$A0+eM;uJw_=m9NBK+A|L0YkA4I zwC%irU z<}7vrZ7%_HFb<)e3E$5Pd-I5i;-G z640J@Yd&3l;3e#kbLgj@^%UG0&%~ZJF`hQ3S!Bi`HyNv3Ad54`V_ezu+K?~wJDVF= zCtqc#8#d)rU#-6b?Av$PiSzrIk3DBXKF*guTA#!koTQz0pLy6Y*5ufpI0IyD%)vM& z#b`|O=K0gAt(T42)Q+`DUdU1YvQFW@@=4r+sd= zakCdXo?B0y3VJWAXXM*h=0WD69sO+snTx)SDety*^_=lLm!ITWo0kG>U6&nVAl zqP=CF?mIVbYmdK?yofXGv~iffcG@_S*WJk5=R|uh-`DbL{Q9naklci?`dp8>K8!DO z^WEt={mW53AG+!!ZrkKIT?p>tLIs97NB=RC-+is zJU+hH+Ou&+UGr&s*VxQcpXN#LhOTnC&pxa?#2#^WeeyEqa;WXBmHX{?o3VOco$N1r zJh{z!K7b5cBRppvD+itb`s|4QPCIGa{&YXN&wO2{j%;@|GnWz)Bj(@+T9sOh;o=FbO(S6UROdHxuK2l$QsavYf z{fx$&_VbMU+S86Y&gqLTuEJa_f?dG8&1ny~9J~}<0j>nx&G`ST*~_>OTn(-P*MgUW z>%jG3KR5th0bU7S1zrta0}41FYzG&B3&BNT2e=qKAG`ou0_MVhk^B!S9!4C{2BT_AUD?ZK~TVZ!27{3gJa<1;4$zy@Mqw! z!B@fm0Zoklu0emlpuhXk-`D8xBK7w_mICM>e~(}xcYn9w2DsXA1Hku&??nDVY@rvw zcj&E*Zv#IDh$H@+yALxy0zLwMcc{B*EB`K$JHKff;CmCk%2KXDi2&qKf5TPxXI`Ec+AYAIac-Q- z?Z?Jq5 znCsVmEkM7&ffj z2S@oC`Mu@0aEG~*fmfnexf}Wa)uA^BYz4M9I`mQ}Z*}agw6h+ar(tJ9#YN40rm?dH z`7}`X>Br^z8QA-bG5_{Ds&_u9HX@(xteg0|GjFbE4ztgF8sx}57*w?Vu$7T<3aZ92+dw@fBk_Q>>p__jc8hJO{`- zU(aB@8@vRZ-pF}&#xtFJKX?#a1$e#;3h-IKFw`CJu82JYVXwvD-&CEJJ2_m9KXXT4 zJHfYWcul)<(5^#I-jR>!)OE_^+_+A)n|wt5S{?aIJO8T2#5(oEH_w;B9&kCBIUYmo z`93N2oZk`52lD*_@J)4n3iC_AGl%Qc58Z!Tb>yt&a3%h3KyRs@K__hd3uHG9=dtGd zV{qf~b;$lDvNMj$2I^R2L?h$44&PLvv#XA-Tb+5<-vaoK2|I7B>$4kQry_%k!D--G z$K}SAh#ua=zNq(faP@FM?)?eKMdg3+l)Cprb!@ql%a!=6ePrJSFP^jB$h%m^)}dF= zjp(2kd(D`=l=8Hj{j_TTeaCTosULRULVV(_6>nn{y!+z)R~S!j;(t=Lll)!N?44Nm zlD{8jO@DWJnWz1VXmGHO^lj$R<@Fk5*Mght_&UbQL#Okqx|h$l*G|xRH8OqetmC(i z>3Bago?TVPc#wB7|NrFYNAT0~lX;sv-&VnabMo)v$#@YBb^u4w-2ai^Z`|tK)!4ba zIlGdM&zcPtFKp)Z*%P(+3FO}cejL05d>8nc<9)x1 j6ZmeRpYH|V2fiQtGx$CmypufS>?grb0dss8{B8cfRQi8` literal 0 HcmV?d00001 diff --git a/deps/flexi-streams/test/unicode_demo_ucs4_cr_le.txt b/deps/flexi-streams/test/unicode_demo_ucs4_cr_le.txt new file mode 100644 index 0000000000000000000000000000000000000000..da86f6b43ad9a5045293de6a308b2ccd918816ab GIT binary patch literal 30484 zcmd_zdDN$8Ss(B>dq|iNvOp4&@JtpmS!OcX6E-uMOvt{6MM|4Dld#FaWQ8E21*_IB z3Y6LwDO7|K!9OHgtF$VmMtUemM2*&3x>yml_Hd4e{L}UO$voeB_vi1Od9f`fr|0B5 z_jO{N61aR#sN-2yPFq3N{Cq22*fP@aAA=@Rs220M9xF_Xn%Nu3&fYroj0W zbnpBP0Xu9z5RiG>Oix)~8<45~hR`pao>~wS+z`m=zTn$}2LpAOg6jhN*9Y>Qf>#Hh z+ka1u=sg;m-uGv%UhRA_JbJGQrr^Z^TWSVs`oiGc8E?&6YzeJTYFL`TUGpC8+?g2p zWapg$nb!q)=LZ)B&R!Z!!7=&A>TK%_^yZnqWTvaTA^XBy$)R(xE%a@{_TZWsQ`XLy zSmY^QIh%{Sg3iVi`i_9z^~`H$PkvJ%cXc1@^ZwjX1yg-jG4lbNmeZsGf+Opg0_}0*BsV7sQkD#xY1!kuGw2Dh@ z#Klf)ySI4Flk>&CHKvDi_LktmU<%~hIPJ~(eF2|()Ol(Q)66qJ^zhA0dsth|8NdG6 z<*zmuYdz&`oQvjM+g5SYGdokjAAak0!_2E4z8Wi@cT^XEix|DmXj1 zD|j@Rf)C~VqXGFb&z02HbMw%wCvDu*bMl8q4*wZh?c0l^B6nDLR_BL@ZXbT)fIYHj zf`C5wep*0d9r$6dsFCQG0$cFB)e9gwewV8$2@;JwH5Eq;QK}~Q$S*;nU`K3nQL&FB1!t)IQb<+GXC$g|=KkeVP&^HJAxa=L!Jp*1I+@HQ%&kW3n z{R0E<-0+`5ELxOh)KDXZ(-W`GWlE!&s?5NkyKwZqm z6zG$8e>H6loUP8h*JpJ;1@v1_@@h|R^A-oC!D)*Rk`dTRMJ!7CEyIH$K{KPB&{ z1H`(w*iT6k@;EO4^g7db^RMUk1jkQ%Wc1%zpPeU$k2Xv0Wp@SDIceIXbMJgcrt`v2 zj`xXu#l9XJe_k^CioJE;o;s+V>rm}_{i$`YQ}t3iGU|x$TGg9gUsGuPctzIs?4g+s z`^nzmL$B-FU>CnV+gI#UWS^?oSM06(^~phv)wTDu&7u1&UvK@V=#U++3;UfjT5o>F zUggzs4+gI$Z`;nQO3dptlY**~(n7va)h? z_7`R?@0j7-*EufA*|~vtb#&!U+4v{)3#R|S>%J{@xh>cpTr*?JYGzjhb8T*22fg>B z@yMXPYfgcC)0+Zz-VwCkTSMOzTsiPA4Shv0Ey2EKW|_{PmAC8k1h5XgIWp_tLMoS>uV=odz~@G*_qao%i!P7aDB+x-m{e4&fv^oS?=;1ue-H;u11bM zwkxkE%WQrmdEWQ@J-Iy^`kw~>BKS=3*6{z)yq}`KlKn4a|F&8FpND=RG#%$ZoAu%B zKbQ5V1GT{ivOgbuW!C*{XtsPk{vQWF6O8AJw(Z44=AQ&VHSZscJ$)K|vHgE5rz_XU zN9hn{f)vn)bXuQqg-kgbF&aI6)qV?dh(C&wwEqwU-@ZXd3Cw10fo|w<*{`b)Dj~siT?wytPe~jh4oVQ2v9sASR9txjr z{gOlN$WO2NXR~!Qe`J1gK5q@p>)vwtrP;>g(Px)lukF`{Cx*SrsC#p#`-_2@MYE@m za@-g@i#@w4Jokm(7pKsxfz>^3chGyr&d{#cDIo9t1?}B~%&q{R-gs@h)}7-|!FazJ z<(yp@lxNQ;-QF+y9Pj&*_nhs)vU|selK0KYTkYD*_6vWUhhFRI<=W8m%67${;!7`G zTfIKaEV}on@0j(?ksdfR7mGbTFmj9Y^3Nj2N3SJ)H2dVtnHj0?#rw*RoHbVR?AWt~ z7R%Pq_2JB1JL^oF6M4vyzuF_y`z!yhRo9v8)BV(plUclWmc>+G?$cu|?7Cm!jn^YT z?%U!bW4^0rf7@V3jAFq5_R!+`-au?m)*^I$;K|c{vGw9ZP0WGwz4?|$ud#8y`1Twb zbKu(?@Ym;;dz3j-XRBVLJ69hIZRW&)#~-lYc(={5K9N@p>-EuZ90>GdnHzK@^4(^?}XR%?5JbsK#qMzIqP*t z*X%gQQ{&pu%=;4@CW2G;)_L^+#-+8y{LF3^Uuh+*~JyvfrwduJkZ+o%zy#DZC z9)9=kA?5>|(UmK@bHs*yYi%~g=bW7}XL9G|oSktl+Cw^WVWa&b%fCE&jk4RCwI-(w zcE|U!Tf$dsb?$R(jIZ<1zPdK`ir+J`*1mg^_|3O?^vgZK%HDW=E#5onsrTZuVvLiF z+Owqw?SZ)L`>b^?ch}9bI>=X#9-q(UvER(Aol#%>?N#UF$jGbpJF?R6oU~TG?{)_G z>pfuXx7g*yU#|X>s~qLECw;F$$IX^t?8mq`g$z3)~?T=&Vrd7<5ug7qoZH)>a$7B zpX^0e`P;Kk-nE9O-~6%Nn4I4{pVMzVY|C-XoBrZ8s_tWt>Gj$ka}tYQEZz&p9N3{- zdvrQ;YA)8!iddal+k5?{)7a%)J$A=?_j%d3AN+Zju#Wk%tycW%5xe@q-{Z499~(pS zJMzfr6Pt_ijQ524@XjaJzN@uA%br!uX?zcnyZe?nKp$NfV(;^M%#D2CGs)0tFUNa? z>#zOLe|t4qtZie$Z;h;S_YN{XYj4S3-eP3Sz2dW>n=@PEoUqwmJrp_n_MLutjX|%+ zT=B)wUeL!|>l#)E=Z$@o?|o-6p6#>!%8E-4;#A+(&~+(av#SU7)49fDn@)4=T=iPV zZ{D@*e&D@pG4FBK+*|0Gi;;i%%y)e}5xP0HPhxS_m=~Xea_-EH`HXqHM$8YM{*WK9 zi{{$ATF1xccoy^0qdq^(H@}so>%CTO@YNPw->q4D(}bo?f2ZK&^rS>w)_2ueq9jHxp=0apVNH}676%jxUBZI zvn<9h9l5gd8^M1L{!Q@f^L~on7ia!&WkoytwZIuYyx*MHf0va$Th8stk|Xo)gZ~iV z)BA&J=_FoOehF3fG<4palS?0I1{>Pv;taxL* zkI&~~`PI;T)VK9N10Off}LD52j$$ zQ+ILkKj!?q;kmv>d2uvfb+d2W;%Z%LpDdZy8C{#-NKM7SANyYm=#DiMKbiV(Z`BoF zJY>{W|5{Uf{4sAf5>I>VTnzSX>9JY?IXpG2 zZ*unh;W;N)pXl{mD~r8e%a1rZ+v4OKuk|zQqfFx-;~`5|&-SI;Sz1pH?Ln^xJ?7{4 z0`+N~dOeIiCO7tW%;9%(CT6wdLv5_>0YBp$&~4mf-s_2r?aqyO#<@VVJ^Jem)t`N5 z$6PnYao!etU75~!_jH=8+?xykYQmRzdY^Ay)dqjmLDOpvbjYY{d!q;C>lK~e6X>dk zc=&FN?0qBsX}#QY^dD{w9t?aP8$1J71JBK6&%md{bNaal<~|=>9$XY$5L_B;3$6(8 z?XBB`%L06|WUddU{lK1lm(4T47tJb4(=g;!$h^HUTUrnaySLW#KTc`RZD_-dA(}DHYxH+~K z=M8@NlNWneXXU4TRa<*8JGXbH&vM1PAuB%Hdf50|>*m(}(gA$6!mmFz)JX1R_;^u3 zPR!2i&A7VYx8~#A95l(zo^aaf$uG^2A-=^uqiMT z+k@MJDY!oH`LsXZ{HD-T;Pc6u!LsM@j`01SLO^Tl3mUKd(z*z$FPyMy}Z_tw>{ zv8$V!R)-yO)^Q%irH=HR10DP+I3u_%aL)G>_`1b|0iN@6c{jy)?I zhXnM`2o4Jx$H}4TZ4I6m>=%%;Zkktq=${Z=7F-)RM_&`{A6z`sd~OfU4mJj2AM+QF z{MbU*HhX6VVm&qx6S-4@>jUR(k>`VbEC1&Q+k(@B=LBr1A9Yp-aj22J`Q+bTPG~;Guwe$?ScAsVp0OzxI&8>6kHy0WzH{;y1$^=GvS8$k zOF#7j&2D|IXXU%~WS1X3Y%J^@8nBN(BhVwUv|oC+7+-VK!}e{lCTeTm*=O^*pfRv5 z?^6Oc)Im+;T3Wv1Vc!{gS^VW zPtL{4pN>Ji_1T)ML1#dJ%p`kOv&SDjyy}QkY-;63z$d-+^p^}7n%&ZeKoJ`*;ofLj&k(mV`XQ& z*4S^I#KCW6$+sSAw%(k{ofi2Wf%y2`9=K-Mw2II5t3HSM>81%h$3eP*1cP%s->jQzm!Q;JdbKo5e?fuOA)~?{q!4#0?qrZc@ zCG-?r6ZGA(`t-!WC;hJ8Bd36zcg5Afd#4qzKJdm^`))dgUp;oclZsVb=&?49g>Loh zgO2y=bAl=0m)+LTd1J4Bs4Lo)i>q?Jrww;lY%M_?#V^X8WrH<@7 ztE@hXxp7ScO>V4>cUI?OZ9Ub9kJg9|-W1?3&eWFh&J5Uv9YKAILq0ywpy`Wu+2^I3 z!{>*5=hdFS)}0OdQ&1n`v)>l%3dTIh%VP@EY&D>-Zv7mAW@A}QTaU_pI{2etip+;+ z`u?n&f{SMU`?Egd=-e~redRu$Jsafi%K2FPd%`L*rc;)`D4 zU(cDE>5;fL1eG-x?4CLE_&YEVH@QV$Uk`6{K>x0+X5pTJ_uJlKA2jFFJvn;nr9PvMIQ}Tu9ms_&|I2#Fo*Ml2EW_qkLw`KDI(#<7 zD7O0B5*qB~$=7cNhew_)eq;E0_G|g(=ZGQx2WQ=9W;OfmVQc;S;Z=sui-H{if8^DA zl(BbBZ^%k+vHqurcQ%>m%h!CmM()pAKXeZa@BLZH9iH{NL1xkBujc%JUAK{Uzf=FS zf+yn%Pu_aYr?Zf^C{+w13a~HzG&}r;hR-+e$XtdcKp+0`{002 z`%RH^Cg;k_=fU9cU~BM&V9}2{sWn}CwRdM|y;lqOyV~3k`o{x4%{V09GpKl7LoIjfNXM#@zADekr`(K{-qx_e``;p+wL2Wz|`sV`ns{0%B z{@2%~T)!!wU4t`%X9rW{UOe-Tn)i4&gg!AiBp`QLur)X$aK1C^vB5Kg#)1#a zbn#ypS-xxI_|RY1;@-hb`A@~bpFhHIO~go=H$G7P6}On{9F*Q z%g;DF=VdPze0J1`O>yAUq3axv|H_YXG=}Hq94&V7s8#KW=kS0XF^%!^b9z7@pAUT? zJJxWFU9M#LlJD68dA7ufwl+4hY>J1Dvkd`X^!E?;rgP95GUBE$C$`m!P4f2aj&au? z`9*&l!xN{NTPrc@f!grHW@~?AX!6d~7v$EQ*Qya6an{bZ(9L0tb#L~^YlE)5#9H5D z-{dK-#@O7|?pZUR4RY+R2JGQApY}&x*pV~&%IPP#X6QKMM?7Or8?&dcHjPy+@aTv~ zT%CC~)Qfy=)~7SP>Z>PTqrW@CGk29;@4bSL(WhAPYG*u0H#T{I`kWTDH*yfivKYmr zZfrj%VC&j>#bb{hy=h(AYrfmN)`7m*on02#TkWe~`>qrEX9evsf8+eq9cxOqK1Y4| zxeqMP%z5FBzS(MfR2gVvB8HqQu}3*YEo+xkjR{Al%Qo!OL&-06@}_nx<(V-DtutQxC_7{uA!_-g;y z;&a&?R;P6rM{{5k&1PxO5<2?Bhx4xZ^@+ysJ<*)V(>Yq)de7gOmpJK;amb&YF^<-C zd-&shV$|#NT5jU!TMX=varVBB&xiP$lYGhY&(0VtnbvJt+|I~!X7p9P4h}|NVzciY zpyebEXJVoYX9Z@5OwTH}7~h$Z8+GZBmCrc4Vw5MJ@-(|-@yT@#TL)*Ch2J^3HnbYD z-Cj8#pG{(=Po{e2vNqe#hr?rQtaJO=8q|O99iyGvHlNO0`{rw389e^klQ%v+tGbQ3 z+}fX;x-v97a`1PEd}i^PiJdb8eFFB_;iq}f zX$|D)oNjq+u-AH2p1;aYvyAVXiMRHvfoB- z+Q83kT_4;K+!)*x+#K8z+#1{#+#cK!ygcyP@Rh-fkf4oYc)6=&8E++sFDKf3;9gwNmqY1ASLlH8F2KL%%gp8$Eq{ zFa;k89tnOb_=VuH;PK$g!M_cDKX@YeAHf*o(Nms}!Eu4V*LYHJaxev_1TP4-qBo{i z`{iro!P|m&2A>Q+|2_G4hu(WYzK0U{J-$Z*zjNnzSpD9g->>vLtYnWoFxPQ#RN!Zz z{Y<)_rSvnueumP|`1;xNF-C*Df6)IYg#VwzS;1=1zhD2JjVmiZ6ns4RbnrXDlm1T6 zXYIh>J$_~Ip5SML7rr3hgAd5;_h0gRgelDBr_Fx{{rT~Ca(b3q&L3wC>Tn*^q>$(0`);u_`4QKZ3@k4Iebz%0M z(+75^z|5fe!@oN?Czyi2m)_`?-<|C5VEVmFzfX!!#_v!1Jh|VjPb87)Mxy=<*&_I{|2JJ5#G4Q|F6zD;rH)f9y!R2e;0F<8UGIEdSspzoBPeU zV4#m4d>s+`sDSLV2fldUI_$rFrpcWf)P{Vv24noq_4~s|-<$QmpzHmi3)f)fZwbHk zd3|WLVHdwL`-g6wUl;o3Kz;E?nOoWJ2h^6ktY7!zTAB{Jc3O``JNVW4&d}AXy#0pocLY}jN6#|&@Zhk2c&63+lHhss z{+O(n2FK0&>RSK$%)2-1Si`mIcW2~QXB{$Z{Kc$0XWIV6(02`cyuXzFX#}p)wI5|p&Hh`0cLwadW8R;gm0vhEv|2nTIAP%T+-imooYCv_##z?&e9(;6 z|M2{Xubd%}nJ z&Ujx|@azLJhs`Vc;F)gyZW_)Gnd#Q=Z)U%EeVSKuanHP(+vdT(c>DKr?+)$$=5N$C zkIKAqKI{GM)k|bv6&_!g&+A`UkWq)mbHywpo^MutejvWa`ZRAjzag+Te|baWmDh!V z6~^m-_rM=z-V#0=upSxrnm#{YG|;{Gu=7LVe|PY=gAWAX75s4EtPu0{Ga6^-hmRX( v)Nbd8{$I}7yMlKI{QQ;RdxGx`%;#9Y`g=O9A50Ev_IHB68_4lPfxP}FYCC^{ literal 0 HcmV?d00001 diff --git a/deps/flexi-streams/test/unicode_demo_ucs4_crlf_be.txt b/deps/flexi-streams/test/unicode_demo_ucs4_crlf_be.txt new file mode 100644 index 0000000000000000000000000000000000000000..f645b1292b1538f9b0a4d262429da1d7d71eeea2 GIT binary patch literal 31332 zcmds=d6Z>Ub%$SfHG(K@TLmaaeW$8;b~887D4@nJ+D4FWK%gCCLIKSXX`mZghM39B zW>jM)VAP-t(ko0 z9Dm{0XXmavH%5JG=j(v6-2{}K1I`1kQ3vBF$B)NY+sa(1cSfB*tIl)paXi~&{qY)P z=9B%h!2D{k16*2B7_;|`%bbnf{Oywz6WS`Eq$ClX|4sxgEeUTJ9S*wr|~Mw zS{aZ2jVX2ILESa>_!4`0zVbZWR_)|@OCJTfxw@__Im-Q~BP-xiAg5P=0?r23>zQC% z9gSCc?lBkbrq8RG%cpfIz`6?Sd;zeB`nAnxW0b3mJGovhc6-hBejPKuds(|390UcJ zd&cauXW#(PXV#(AXY+DyZT128sb>wdrfDnlSDyZ~tH12oKJSG!eP*BN&z#e?qj9@W zodWcyJUPp8cU?<+ZOqDyTRUlcQrxbq=U!v+*|~eXJJMH<1sRyLrp|XV{~)7WXup8x z*6~G*Srg@z+u1ja*XN#oczy1PV_DquTbLWuDOFbO%{`$$%U7$@`Y2VWj`Ke`7|j1T zc=KQ|dOTox88)&0W8f#iyHV)n8aY*akL3CMPZ9syz>kvSdh%EV?*pd+@4*K_Vg0S( z0f2r#*EvMKcjt~73}&Ck+#V?C@~nLRvE%2g@!T{r?rz6ee;i}2$JBerx^tWBp7#s} zQ^r$3_6V}5rE95gZP5u`d!X8jeaIu8Uare(idyKcl51=4kvwnfI{$OyygaAn+v~g> zIoH_}#yWG~Iv#y4-%w?*t+JDQ&rj(++Yg0Wr~Z1LC)DPD!sYxs>8G~=dU!QET@Two zUjpYfc=bLk%hBaJ>AZ4|V~^i{?p+*@bJvc?IQNB`Re9X+K6_s?<~w}utH;lC+=0qx zKRzBko0~twe1Y+A>e}y*$IXAocoFiyXI$Z&hL1u$oAat{KJNkMsT1-qvGW=^dG9Wg z=6=RAz;)yKYITk8r%TX#ZRN*1ynrhX%VvMO%Fba-UDmrZc~xD{yLKDTzPJ4@E8tb! zvF~E6XLz1z$hGG;peSHph4UWf*+2hw@D|o?0s1-{l%<%zADwrApGKbNHOF1Z-0Sy& z?{>d`eD)h;E#EQrvig3zq`u!{+FJw%fa`m~5x#2%pRc-QFj!|E+Q8=em(`!keC9l? z|E96bb=TtiurS^@evY5vT;u0C_lGU`mY2{s4q{yYI!5Qj7kh|NUG0bO`Gv5SNV>NcRzQ`;KlTYIWWduLLd1&Z#`3X)_6YqeT?R%ye!2$z3sYt{myj% z++)De08af~!TjZ54>*Rs8E=lPb-g5C_D%uD;m;L!faJ!t#VWg*(e(oCwd7fSY7%;_ zTzlGI?ROmVu?lyiYxvH)@==19kV|r0n1hkMQ|FKLF=9PJ{AF&OPkAzYj_d*I zT~1;wU=i3O^*vmkTIcqb_aE$J+*dgiT{hm z?OObpgP%te`P=3AS&?~1B3I2YPxc;0qc7QaKU>+!pl z^H@6z_;Y~sx;ER`DbGM&CSxt}ueA4(AYV)T$$#|o)$p(bTv|~W?cqgWpWDZti+ndY zSEi10zq<#*{L)MSE zeO^oat^WUXKH~j$MD7WBWZp-J-Svs_za06Mj}lD!8PW4;{@DZht&pSd9dhs9HH*yc zAxGaod1jT_Pxj7n;Mis?%*EB<8n6Ja0x#fqA8!WgD&GkTP>;3vJ&nDW=Utx#@N;R5 zd_@DI&%+HUA`GZ){j%4=HXcp^>+o`Kj+AEO1*xA)ko@Et5s}Iy?rnknn!_)2f;6c-vSRIznk%A$Iq@0QJXr% z=+D4BPyGgSe7Pr{f01W$ocb{MIb_Khx~V_)tLS{DKL0v;hroNm&x2n8?Rwun&&H+B z)GvXb89xubtE^$)ANK#ZavSpASTQeiFz)+^p)e=5&hPt}%Og4FTEty*8SZDzJjgvc zlGB(|kKu=ydzWTzIhL``P%d5%4x!7uv%!59^Q;Nul#uHWjK^3fzNmZ3jr~q!_Q47@ z9DZTE?*8GwGk+7%Ca@M=4`p9i#~RP@Y}U>9A!PfBv6oNAIP~W>>`z%k_I5pXsO~ie zIVA3ggCYFBf4rWYMlT;Jr{5gg8GhpM-niha`&}&fp>%J$_vPQ+j*;sRTYg9F02hMHEysckOuZEzxDVyBt8cAg$eTWyI)t7*`4GCE zANnBcoul%w>s??C@(evVp67iw{92yfZ~t2p^rD~Yy`ME6ZWzm_+8+9~v5)SYSy#?Q z^cwL+&!q1OchGPrx;4kHhs~2c5j*h=x1v-1sGDacI52m%pv zjUJMFW$>JK*MTdi@du#Lk_Cl z;4kY-ZsFH+V=nfhdf4uGtGo>78oSi2%i~4N53ygaJr8m%hZ$q`EIL_-Jb%N@$dY&O zDSg}Pa)O<>6VhIL)+XGk?w#}=S@JEajx{ho>zcJOHlOVg<91#C_A^f6!kj&$pBS&p z;c(qp*4b(In?v$Z`((HY8GH|4GZ@#P_DlDTv6FS{#=fYL{;biYx*NaT>60e=fNv&>KDzxo6be>U%5d zdWf~OV;!&`{rMS;7UtGnf7s4?Xa9D!squtud!V1YHtYw+sJ(q^pJh+W4ROVt(e?$V zA|7h8?0#(W&`#`4drkjEUy@(fGlyy{j9m|ShRj==*~7*pZ}8CG>GAzvYZ89%VO_ud zoV9N~^ljg2+k3;iqCJbV$c(pB6jjU_+(*aw`?=%vD#vB+_qM^9Crf-iWBbJo0z z<6M(__GR21#FKf)nZLK%B&M+0KS%73c&Sl)e`L*<#nZ#b`G~o?i~Hfx9ivozO6%>qp{#8 zYFcv$?maKbd5-8t?BCBG&$W4KzuL_AYsidQuJfJoMtuC+c)xeMKetAH>KVH+8K=C_ zC*99X={v_4U}G=vXLS4GCU6T_1h;_;LF(pMkco?ddnWxpU=MQlYwP-|a|5Hk3P_nc zHv;9_a#ZGe>S{yTtAX>ofblu{tbf;6iFMP*2ZK$Y1pf&B4E(|P*;qDx3@HEOI(O~& zvFDomT>ry5KFsKTY{k0I=!Tv;e*yjyD0koAfx1`yRsZ{mGpa5&!uFr=tZnTWd&Z;> zWv=PRHJ?8Vj7?d_!gE)@!W?Y+qpJ6(jDHQ%j-#?B=1sh_I={ciTtDgG@gKm$z`ef< zTt_eaG}eqMbCF|X!$-u@@~e*fwf9NT*i<+Exy@Eac#8Qsj0L@RpWG8y`0w@WrcWb3 zv$w}sGH3bYxr^P{lAH9Qu6v9#_0#5mf!B!J{o4OLaPPzQSsu-y)Mw@Lp-;J0ZanBj zy{%#LD%bAq=dK^}k3FAa%)I2wdF#{sw5=S!;V*0dFtX&uJ;{MFxu$>D9evi8{bcMQ zY$=n+^sS!H`cuYw>(lvK&dtP{ujI>kvd@iG|H_g_`@Yr5*eeeapStd~c1PM<@9nkZ z5%nYI?(VVH`uQ6mN6A$^Z_8?}Zd>CvkH2D#xFi0*U@kw7SqptN{SY;)vDo0pL{rRk(cI@$tvF$r``@Noe+3)%6zM603pFM31@}fUus`r0) zpUDsMc2CURmwC9yz4k=b$XruS&0RR0&F?@NID{J>Xg=g24KOg90dmWWs z49p|_JdZj0T@B0F|El*(Jy#p3efTnVedxC7WLA;Tvfdd=hQX1)Q&Yt4&WtXOr06llB@KquJM8;|6H=vy=&#V z&&Sz~FMX0*#BxdXx1G^kte+3qS|V6>K*L)Iko%Q|Bx_8|`+%C(tw zk|**H9nZkC>zXmU<}Ji136#(w{7cyiS-j*Lk@Yrb8LCxB>X> zp8b}w$V_x)Rk<<0tg-ftUp|aU8{R?2a~ar49O|2E+bffJ=v+;Gq@KV0C#}9Kmj)bWuDJ{pn%0Xs;At2 z>Z^AzC_wpbb)I>sSHM*u?P*KB^k3?lex3LC=Ci)Emo}+YaHOr9fOkpyxRZGSa;HD% z@+Y_Q>K^T==a~E#=EB(I)V=Bm_bD%6Gq@VKo;lMu@eQTS^&{2c73iGt|BToCKlpnk zKKgtXWMJbJbzETnRB#D62^yoKl*SqhI7CI7=aUkIm;z?q z%2*OZ#+_H?b+yy3`M6Iz=3%Xk zNk7V6x7OU{;ZHv=0Il5EtgAI~j@|UNmN9%Mr`k2IS&*?9=P^M0&Nl<=WGq=T>*u~U zzRYbM@~qtiUV>wLUmx1N3}hVIH+OqNJ8~f}=9_bKHYR7u#7k2kj>J@{qk?kJz8ubhHok={{w- z$5@ST9dJ$G+Fd30sH5@eBV*8p^~`*=Wh~h%#;J~SW05C&SDEpwknhH)v6eP-k2c+F ze>w8~(A_WU_`Cp|o7WCtobFRD=gNhC;cZaXhOl)kd$eWT#%~X0|0>UZZ2Q|i%2U^8 zYhZ55eaoxm9NxdV89wCQMko@Y6_0LZta@=5;XMx9;bI5wWecpPAVHx}jsUYC6X zE+V@Q_*2d~{=8^lfdjl|5*PJI$g}KOh+@ChmkNfTg zr-K6Yt?l&Vdd96R<1xSd{_gKlN8R+BF_uQA-9ESO)3>%=Q^$M?kjIQkzA`Sk)V^z} zYb}jA<0{Quy*@vF%Qz`pY@-$(3W-zNMFY5^8(lh+Pu^^uL9(85x8G2<=toJ+E^vFY2NG8 z-0RbyL$5I2Kb}t$*Yp-}UX{OTFqnBP&!e8+JCSJvy&3cABrSQ?`D1scuReL zfH`)jKM(E) zADwJ3VnMBo;RJNaX_`AWWILJH9*ub6&G=^K>$*HKpFVil#*8tUqvJ|`Kg-(v?A=}W zeYolqyS3=zY5k*b-J({{Wi-!8HK=+WPuHR=vM&F`{3C<0k2{#dxi%--I)^oNwy?Z4%O~#N&f0m^moe1mnY~r^2gu-X+PV>++;_P@P;H-5W%}Fzj32#;{{ES@ zGpat^Oxq*)>SXsb*Wb0^+^VO}d4PQrZEj`lqg9ufx*l%(uF7YQTCQh4!5v&J>DBvr z{v42BbCOSDSh247m^qI1KOO4@PoHJ}PUM#`YKJ(Duk*DlONn!NvQqw_iDa=f$d@$AcctHX1geRD)_Vl76jomOp- zcib1d8Sexc5Bq2AlQ&g8a-F&Cu+BugzsI^U5od7X9cevI1;iCH^6$>{-mxs|fuHGr zt~%_W{?yXB@vhjf+I#?<2Z&SdvnFwmWbb=M-(A<-b3fqwwBv&3CHfy>?F_)4iTTkLq2n9eO5=m@Hx%T!=YoHS)XY0!|2h+o`Go)`tnE|oqfJ*vo14R#%qy# z>fev-Adri#;G-+}g0tY>9Q8*o;p1B5yLmnhct@t)B*!uTNg1px0SzN5+*JY_ufE-@8yjabm%md$=AGk3$n>!Y%*A+w_E!03-?EDzm)8O8Zh0cQh4DF6Ha&h0 z*=}U~zJ1Hl0KF|20PfH&8|xl=d&>#n@jPctIbw4q8zCpYh#_sA#Iruu0p~T2El+2T zkJvNCTpiv4TaK?X?eP16i0zyzyO-x@gUrqK^uznGv!|bPfp+oJ_`WXTDE7u1#3Eh^*KKJAt z`ua2P)9N1WT~OzYOL(%@a_1h`uo?c`zy1h&j#@#-*xhel+LljqP~T_m_G5Rw?uk6x zIA>Xt2f0knjMG}kk^8ipHMpF)`mV{dFu$zJN<6v8Skuk|^Ngtt)q`}Uw`FJdpAcQfzZMIrBVr?1wx zJ)$h_wCl_V_=~Ti*%QYyPu}eb zYh^ylg*~F}tYPML60+ohdBmfi_HOOR&U)y%cP(`*=)JJ+k$2;n2bqg@^tl;iKKeJV zJp0zyedgd?j*@R}UI46_d(`pl<+?l&=dv2uYwCM$<)z6#^3z|fW!Tg2gx(BY<4^vL zCG#*heYl=;-`8?to%G>)9YfyskMg`X?K5+A-MMkw1Nd8(8?lD1HWqo%RvSz5y90T9 zkF@*p9WTG;pnrS99NJjx{U36D7-Qz=yH;KO%ai+AQ#bV0Oa3Osu5WeB-_aV&+hgkf z^hbPQPd##oxp^6jv8(4^aVnsXLMPW!Z&HkW1Gf8PpZez2_OkJruYS#!UJhO5)*$<` z@)2vq+V#u}naicNvu3Wh-+spHes!|f?D^z4>v}ITY%SwEYg)PJVyJgY^n2P$`}V8r zS%b{k=hQJ?_Juujw?^)BTnF0xmATh-^T~C25^C$=iIeL;C{!Onz?KK9H!j@+I@38 zFH|{aKlHR=EE&f>=Gx5t>iMjmwv0(T1zZR2t@GzIYR4R21&sSPpdHRoS2JoKcYt=a zr@zd{y~%~Sx~`3sX-m7wOX}-4bxYN`htasxe(rHyd)iUQIeoG$zJg3FfQx|fn&VDz zF?a#E1Y8O@yYc_gw2N^!xEx#ot^_XvSAna+HDC{TF?b1hDR>!pIVj*PuoavQ&H?9w zZQwlcOz%I>8d$5OI{N1THFuoCdKOmO)ZzA8v_#k*c_^q+-hE4pt zo!kilY|F8@OPsiVePcwcq ze=q$?@UijVAU}%nDB_L(UM1tq(LOu?thcxe+ybnvwZ9V-kTU1il{{jfa(lpfr>_0s zdfIT!XYJ`jJ#y(d%UB9B;ki&xJ3{*f*h|ihSGj$9Iw;iZN5FdlJm!Bl8~?5BLt}a9 zz+wD1xWA6EC`XK>xez* z^05z?n{&A?bxdBAB|ok`3NZS1;!KVn1@V3{I30b*a*me#UHuz5;5%(wZ&Mx<2$2I3LIUXTjqH|SU z<2@HTdl>sVS0mHMLLFb+)0yJ=@pX;+qKgN4=j%zxcYx=ElNveqYTWzW0i*lCWq`Y8 zRDkb;Eo0pg?~_>5IBP9N-&u89{^apU9Lf=Uv=zMj+~=@)4n3Zi@l*Lqxns^_Ph)pf zIf)w9eW4?VY3J)}Ozvwr zIkGFk4Rw4aW96dLd1+nC`|cGJbY6x`U)$^W6+Io#YQ}R>)iIv-to~ne^t}Yv=O}YG zf4;qf2j_5L?va1S%;RVqa1_mbu;g!Rw>r0vZG@dWn!PLOc=xQUcy=?dcTw2+LFC^I zegM1~d;|E=!+t`?n0HmwIJ>i`kKGm3Zl1;1`;Dx<7JL)X&$obY1>Xj~M84lfZy^_X Q`yuedz&zgyhtVJZ2|B8W$p8QV literal 0 HcmV?d00001 diff --git a/deps/flexi-streams/test/unicode_demo_ucs4_crlf_le.txt b/deps/flexi-streams/test/unicode_demo_ucs4_crlf_le.txt new file mode 100644 index 0000000000000000000000000000000000000000..966a4fecc0479818affd28394711cfe2a504620f GIT binary patch literal 31332 zcmeI*dDN$8Ss(B>3lI{9Enx|e@Jt|N0-0p8Cv0XinUIiuW0BJGW)e0T$jT<71*_IB z3Y6LwDO7}l;2#pLRa%u&ksitsQPEmU7b~LH9?tQ=KV83{nde*X^Yk~rdGT0D&gnV% z=DzOhzV_>SmfyS0wvCOAV}o0Qn}f@Poxw%H6x<%XHrN-uF1RhgvrfU?!Dg^OxFdK? z;Cu?YcmAq?9k%ZY$h>i;r>rjz$W(t@XmLGvx__Z@b-gAr%I~h=JA!)yHJO5|0{d46 za-V{i1fMzbV7=(w7nVqIH~Dm4c89(x z*b`hiW6Iju6PKLDE`RfKYtWgQLf;awyOlZaOv-f%)Ikr%`L2v}KE;dIUj2E@_-L=! zSFZ>CKU6$&bxyxEs{R?_O~I9cnqC)7!P$YHT@ai%ulj~x9rb0m*Z7U0)l*-lKwm+h zFAmJmvbWufQLV(tW^27JcC+Su*~iBBrkuSlxHp&rxi@Be*T7u?pL*8$Y7EoNGf(vJ z%}{$7}*uJ7#&ZW}x<_(8V&>RedG9F4x++zprDi zKb!iBcVF-WA<)ITTpzRjpxpP(wYC4AS^sS_@2Rs)_fJ^t%>!ROKQjAOy=gpumi5EQ zuQR+(zqx)a^2-@sr+0rk8~Z9Q_rq23HCOV>Tt7JLc=w~bIj=99`L~uo@6F8=+&1s~ z414vw|M7YK!uEr5uFWr>wz080>mOvL`y2DwA7y`O_J5r9P}eDWSmyfi>vHw}bVcyC>0q7Q!$Tf;Pb=?VZ$HQzWxdDsn!It= z>Am*6?9U9mmra59_m3R)4f&14iO-&QK$wF4Gtf(XBsw1m-W$9s=X`lrT*|#a=N}4w zGUyC$EYM?{%_*S&YU?3n#rBF|Gnj(57X)`_Hms)y=E(k@fp=DT&VP9O!MxDZ0vAT!IbH9W^dEf6#>PW}w+Fsn zaBXScDOKo5PcQ0vyl+2+i9Wme}?K)-b+uP5Y2K6~u1`x?jL zX7%P%Q{x8+UYIyr<0*N=4dIo(zpr9FT>Pgb33)s||LgT=4qPW@;P&9e>7a~xaMtJV zlfp-vE%(1$gX)|#9n`sVJ|oll;U~w3#a80qik)wj%vR!W{r99EYUuh@!(Nwa-s@N0 z)R2sN;=6|RsMp;TT3=q6wY_`&Oox4-NBGd|y*AjzZ|}Ae{}lQAE4C7U>wk6fP;2$= zJ#S~|z87q@4^wo=j@OC(z8S4MKV#4GI=b=G!OMba##Z95?EP`wO8l+=6Ow>?iTbz> zS|4@me7Z;Fzm1dgzuj5Y*t^Sr56GBby7=y2>igz^%|0J%i;U|e{~Z!riGQ8`xB6@= z@wfg{f<0rd#rA>THPB=$bMD5*#_`#om$keThI3zAIX`D-1wIF$D|gEFZ_rPh{(t>b zf&=q>Q`SAfl{2QSW_U9&=jPaT(Psl1j||#7>lC`&BeNABTZzB(uYSEZu&u7{C4JW7sk7Se54`Jm2CH-He&igN z`kxn^8C)Eg{VDiZ{%5TmdL6bB|2q9|_Uw)=)LwsHH|Kdc`>W#r_UJxP-v3{kSo{9m z)%B_Goq@h9boJa(mwkbG+6>H)6|dJUo_SjLIrFBR-yG}?ZVa9myyvKV?K;5U8%zN? zXFCJ4*Xy0nDe$?}>OJrw(M6Xhj$^_bb$%@ZWcqbFvyRsqbmf!&?KAqdf*skn9#iP+ zgI+7HA2qP|3?{cPI6YWb3;B-M=b?OWMvh%RDz8`TY=0p6-}U5!Io}uhp9lXc_+;>g z@c+rYpJHbt`(MibjkEl}41G^%I?jJS>zlIwOxB+bS}SKj{uhHU&-$MV&7SWg{L|p) zg7JK5-(Fl~{#o!d^Zwr0)5E1d_W!(cyKGHfauCy-=e)#LzaI~+j{ROq<8Cf@=1d-P zZ;jLxtskEb?Oxj4x;lqn%=tSacOZsYkL^2Vx;?RiI6g72^u@)@>Rx$A z(0k3k(5~+(An*MM?cIjV{s5oecrS2oaE?C(<9%wBb9P=(o;{y*dw=QsLEp!`N9_sL z-D}>LI$WPRsAc=x9^#L4())t?xqi$+WxL`}@u|PAzg|P;8QuHYcg^}{OHZ7cm1U2Q zj@)vF{zc^Y=yj&At_yNz&&<^Ks(aAhoHt%NY}vDi7SFEG_2bOEJL{~Q9l6Mp&)Or? zd$Jf@%dSD!uY0iBC$qe!R>f3b?(JhN?7FYvEoYW5_j|FCGxycCziF@~PI2IWXK1l~ ze;~dC^$1-*cye_QZO!;l7xUnJoo~7H+8gJLZ_l1(9{igLKKtx*A2W06ZPj;lXY50v z&7U~%_yj&0^X@s`uV)pr9LQS9kma-YTl?0qvpLR#dt09??boW=Fk8zUSIt@L(fW(A zcAcp~dnR6TYS7ro-yWIPr!#H7*ip;QgFO3ObJpvSt{HNUr_Qy*SMLkr(aU9Cjh7Aa zweRHHht9uMFB%iyc)eZ@)oXPpQ=6X0a<>;>&+8BW1>tw^zG6&PZthMhxC4RFm9zAnUu(CH^Ypd?5bk%+N92sLJqX+D%Lwg}M`#zVQ%indhsuptA zt1r&yayeq=)y}9dhxV*<^2o@m_gk{k@4U2Ly&rcL`0G7k*>~~Fjn7^u?EgacpU&Dm zo&U=0uRUw6>!;U6dqn4sSx0Vi$78p>J0Y~Xk9o?;{ar0T9nj_L>x16X*WvD;%e=)Q zZnfFUJ-W4B`lYYe;%oi-Z0byy&oOrOz92gKCbvGf)crs|vZ{eS`{Z4Bc>2yC+l|Tj z_47IX#>2K8m$|dCyk^yZ>^0q9>tkNx(UaxBWG{DdvgO|KsnE@vt#Mx1Y|maFIs5jXetC^S&zJc+6GwZ(2Hv5rX|-_P_(%EP ziC?`NxWALq{fhOQYI z`IpRm*UQ&KH_!GT@;NE*&fl2Rn7ix69O3B``SBWQzRj(*{PY~ps@(Ld&ldB} zcjf7O4^|_5HAdHeYu6q*XHUKLVa$;&e)P0C(09EwuC8R^@8sNdEl)mcv-dZ=UZb7= zcZK&q;)A|>>HD(hmmGg$5~sSElYVBZ@2-X!2?DzYJQ|NsG9v}VQNxxQ!=UiM<(60gb`Y76Ge(_oDYiC`oUwGuk#%~4xHTZYI zZ_fKE`k$Zqzmpa1>^A~u^zeRrUjIW@`fNG3CrggZe+>RpfKTs_g6fiASC^eRuMM*Q zHo9!H!(U_K1J9lxXZBwS#D-Tp_U$#B@NZ_h-_81;gW9p;jWK_5KBxEVq4}wQ>wgJa zgI}A^$#qVhiJ`fuvDo-vbF42J_M4Mu}T& zOLJB~`^GM|)}}tll4-rswfW7|RSf*G|J8u*SVuXKssHv^ZSloJMs4-5b+yM|=FX1% zoqZ{&UG+k%bA8GQjo&$M@5R`<&}q%Y)LuImhdo<*tzJM5PaW% zs-7RpmsmRIV&xyNbu{;*Ok*EoB1>2A4yW6h+DabnL$3|J=I0LrHEOMTZ7h3DcI@$( z$M5A#+-k~?`dHfwzQ%c=+t|n4w-OuMogeXx^MPi2^w(LcKl{#*8E=f^+^y<)!nqKpuLq=`eBYh}e&*=0XL03)0!*^q3@0;mSYvvx* zIp}(0c=rarmJXhkn}O%+x@YAB>AC*6qw`D%E(y*L&J8XKb_bUR`1aO4!NmbSSu$4# zQ|f`nbN;-5O+07MnfK@uLRa^?&}^}LZQ%S#S)E@HoEJE&z8Ic6^YKQ#C(LK~mj!Gz zC%nr8dDPFhg=VY0<{Q@CUwU0VbJi6*8~n&uK5WPv-&z^I(Rh_R)bse+k!erppxGtw z=PjVWFQ8woN#)L&<<$~TPg(X)o|VZ1Kr!B%VCJX?>m2VZ>3jlC5`QlxZ6`yUrY!0n=^J|~!0KR(R*B=||B!4n|JS!k4W@q+hU2X7N z_vQRNewGnOW1`c1+avk$wUv2mEb?tE^e>$Eo$cBjSH73Auu&bkkU5;)&i+`x#&u=% z<;M=+y~fbX`n2xO)Vq3JNBwoRQM>lI*PnWbi4FH4@mv+`4am3ed{t*zhoz3$V9(k* z_ByFu=j=DP&PRQahtc-By0otDfn!}cjV{d$o z-O8Vus^O}7vO|up++81f-#UqH%$dK#)pNYxv_>~a&-cPN1JB?o*b$hIJ;6=E6kHwn z%-f#_e@*Bq@Hyx7VBIr&Z_fSRM?W|FEPY4dGx8MpjE(2B^8R27Hs_TbKHucY^?T<1 zY(0h7Jo>r(#_(#7E$=M)}X z_wa-3?yOG=t_V&HP6*DM=`*vQ9rWyy&`%F8oOwI5ZVxUE9v3`i-m^)LJu4dz3Fw~| z92+!_lS9+n6+AIGA|PkoF|Yj4e?o9^@ch6z`pV$Q;DVXvb5HP$V0$3;Wevn6NA}RQ z&*tfYcpnppi`*%})q!*N$n(R8RSf3@yMt4M#|CVu+CSV_ZTA)v2Y0va;8DDeL$M$YjUDVj@^TF;_LE~Uw?xzIo zsD--7x3rwa#D_EVsvP9R|5j?kR^|B?n``F50e|c`H*?1Z{5B4?XdGtk+`xR{9hi@e z=mg6+#9Y6vy*hLj^vQg(X*Gv@(!;BcSjDGa&iH0`UGC~EK0X=)c|C5vY>B0_()!?w zMV-tpJ@FhW-;;7yo7G{HuKBWF6yV99jQ#GJme-y@oMiCT93S|lx2*4>_G}#+uqAHs zn;|yXY8>($uRl6uDr>I?a>KXp86Wy`sC$BWR>Q`Qb}c+Kkh>blZKPcnc-7N8d;Zl> zylSL2^bVE(k}vM|r~Ob9_Qbg(kc*iSBN=|=Ozz2nnxV;{+go$nzAbAZ&QX@GoUCk( z*B&3Om00+$Ecw<%-In>S+dnn(djm1@xhHV_uxS;a>sgI14%FLGAb!JUD3HnjIS?`Qji*9KESmXH1( z^qHZj;L4!yqt&M;20rO`_3k+ZpfPi;zBR$(|G9D zM*Yz9K7K|p1$?vJIy!IMc#TJWn(tDF4B7f^jMKnlcUfC{e6#J0jC`g*9UGH6H7>Pe z-&tk#Qp}BO8fbFM`gq4BBi`0ko%m^;=;2KP{&Kd?4Da-yw!7{PuW^V;Zax#C*%AA? z&tBK(oL_pKV|)JF3%1yqg8CA#{qA6YFy=*GUQ?isn*n{b?B@|Q8|z}*_2}H!gFgwT z$i9E3@6Ng-IDh89JL^M_&%I^dSMI~vvqA3GoVR9d!R_H67ob0y^_bwj^ZtWb+5Kw3 z-oD_Tfb7e%ULHK&K6dG>vi~qK1$6#6GVI?L+!^5Q&U#Wn=3O)IhqHbzSY=Nv8?&4k z9usT}PMmprv$D^&cn{Pqwx2S`ARqL-vkV)@WY4bH4(0bNIeUL_&1~m0v%J{#fpac)44 z%=rPmRW^5p|G9vynCQ!WoV)TLH0RYlIeKcRR-=ws{v@~~kP}%k9ICHus>kona_oL3 z^oN5h!e>XE;;YXyLxa71`TOnQxX6>mZyaCCew}~59zNu8@2vl@tgemrv~~Z(@G8Ua z`N7_RPx9(M%GkU1w`C=_su!n*{|s`mA#bzm8oE1cebGNUymx0McU;!12ANfMe?2n) z=lYJ0d!&9mJvb0oc=A6c_*~Fj^@E?U1$@c#OAA`OVp`>wO?^E-5U1X=qbKeooqc(J zbUvfw{N#Y`Rq~$=e`i2vm0z{l>F?!K%)7ko7M(9E;i|LVLS<-ZW#j|E=} zYU3lJe<5J6y1zB=e<$lt%;%#Hd3rw;&=CWBWbw%IQ#;N-8H_QK<+HlKpS`$Sm#$=B zM{r#*zVmr^>U&Aw_tek3%o)KHc-OPKQ_wo1J2$Tn%^w?6F!r-HoI6`pD`#rtYzmfj#&g!3$l@(+FYC3md(&X! z%+Tt0deFSPUK$=Bn}J-!1MIE4zg)c|pR0q@f=2~YCa&eG@h@Wd+a)=Zpwp+3Fbr}keA?Pu#kUk=VL4(zS=)vtZm z5dEhI?Ylh2>w@mGzU1q7v>{jbiRCPv9p31l&1VIjiDN^z?q(;=h& zJ#Sx^d6+fwYOOBf5Nq?}uf1fC-&M0&oz`D0&4W!eo25N>=;#w4&b#8*CmO%^P4gmG z=V)=80sfY`iIx5si#o71#?t!k34gqgjCy^>%TEsci-Y|!*53c|`4D6Ck~3NU*;&R* zuJv0LyE8JKA3avL2M41+@!5AK(DD+CGjY*{rw8VUOwTH}D#p_zJL=OTFRyWy#VKEY zN$tmw0#?^X13#S|L9 z-}iC08T50A?-`VK_R652>qfm(!rvWC!JdE|J+U;7{h`^eKDqj0OHAxcfzQYNnX=15 zvm*z8lgj5IpUc=eJ!sFmvdbQS&4+GlAy?;Yl*bmktxM(kt?V?*_&%YyYri_q*<+{Q zOI-K4ZFl5+<`b_R_Xd{-&kL>yt_+?Z_!+mWgKL6ogX@CpgByYygPVezgIj_Z1U`?x zD0p%3?ZFhB73>Q7dr;?wJ})>wxFEPNxG158fEOHTYQg`R~BroqFd{`QA|A_bfjW z_?<|XA%N3NBp<^u4f8# z$y4XQ-T&nHJ2}74l~}$v>-9(GcTWO;gZ%RkO1y#JMQNN}&7r>CK11*HT5t7UKc}EP zw7zZz^zhAqepl9fIIj(7_U!RPZrwHGx**36us;Q63C%D5ZNVAA6#RqqOAr0NYkzOn z@5=gpV0*1jv9guz0z!&cuhW&TWG`X{a z+K|t#V2r=H{$Tj%JG0&ubiF%t(QC0fH{`4}dSz(!VH>|PM}}^#UlIEHK#lQ7nH%S` zSI_G$D`aj8kB{B+`htbbQQ0@1OJ^DJ;MdpVLhlJK3r-yPuMh3Me^2n{;Huz_!4%-{ zK*#+_S)H9a?`zlkH)h^gKXq*VtgC9M7IfGkZ@;YJxF=`7tYP=#TAB{Jc3P9A9sKHi zcj)R>-hNy7dxOh^<7XLsxOdpUX{Ocu!r+PX{)DU-1&^Qi)wTZ3nRjQ_v5xC%__D}u z&U)n7`O8`N&9wcKLf<;<@%~EoPaSw<^xBM#>r&=BW|>Rp)qa$DO7`Ctyft9wE%W{v zS^0&>gjSEo22U9HJ-3?Wqi6J*y>^y$Z9iy6dvM%*_P6GBte<+Wt6}GW9N%=udBI!m z@v4UgGEll}dEL`PcdnLp@T>D(gT2breMk84&Kd8@3Z98T=Gb{fKX|5F!|R5#hs<Zqf@IAqg2F?mGUp=F7c8>VCW=8FHj_Ci@oV_i0d%(|M3%)P-{=l3r ZYgnHTr1ibYL*4#f@b?3GzAtEQ{~Kt-hsgi{ literal 0 HcmV?d00001 diff --git a/deps/flexi-streams/test/unicode_demo_ucs4_lf_be.txt b/deps/flexi-streams/test/unicode_demo_ucs4_lf_be.txt new file mode 100644 index 0000000000000000000000000000000000000000..a1fd5437bdc8ca1d5084491b156b5d617605640c GIT binary patch literal 30484 zcmds=d6eZvb;n;%4}uHh*bOK~ebwDOr&)vn1_jh)dWJ!e89KE|J&@*Dz#U*2yb9b7ZUOEW zkZbpE2I^7woj{(u>%1`D0OUz|d@5i5@IvItTljn6>e=uyXv)1D6!09NE^{W#>4o5|in|ySXEL`=<}l~j3%jnJ zyYE~dwW*%31NwF&kai9@54cAS^rM_G9Aj@Qb0MGgbpEV5Pg(Pn*vs4)vM-jHUk!GG zODhUv_L#mHr~VqVeQ__lUjfE$-rGJ-9{07WztXZk`lEe)N?v1^ z_b7UKL|2}n?D<=(jyzMTzd$!m_oZciQvM8R1zZZu=M|uUvw<~vCfHU-eU+Xv#-ZM{ zc@=YWX-x{Sj>5WL0PLBpr=xzEoAfnvyOzK9ll$X!OP}sx?>2A<6kxpRr)&HCAkb#! zz0|d_IJXw|k8<)^v#eq2%9y36J@slYdvrY4g*|O%Uue&mQ@5jjD<@9@+LNAn+f!+& zr}b5u{wkk3C;98Xe9G#BYv;;%FQl!)9L!rc=ewAHkkQ!HTflSc_yWePf%KZoxi<{= z=bv_DfBp$WTHM!*%=P8eN~`+jA79tzr{!sFl*&`bg`e#87JeMOxz`&!4zRrfo7w*{ z@Dt$OFc@o&-ot zxiv5Fv6jB@=;1nRJ3j-BJUPbxV;O55rr$f{o!?Sr-qY(%>q`OI8_=SL?j^r9g(rBe zebpCo(8HgxI9JpXw%}VO&Q{mMdEVA@;pc`ic_z!Z*Lhhx&bbqZ`}5yA99@@hsI=Es z+9_k}Cy%Y|gF=mye*^0YHTj?9ap9fx(c1uhyOy4=Z|xiUZY|!2<6c`&{foPgaopD~ z&hhifnGIgw+mu@#j`Py&hr&a zSB>)=crJnGwTuOLPdi?5gf{ovmDcjI-<`p$>VDp-+gSTt_T8$0S8|uWi?N>B1*Sn) zpYL&^0N-nb^D!(SzwmbO7WQri+BzGQQ7qgC&pW_RLw`)gZboH%?)%L4J;t@~6i4%3 zV(-fDyGZi;UZuWea1gk^AFT48())bnDZSp5ek+Tv4KJymom|uR8@_2sbKkvqzblM4 z4A=2F%RN4GDIdDXuXzZ5?c>{q*D*TBuaLnvdDS1b%}uG$j`R9CZo~I7za3P0eb}&< zwLZQa)H?Q*GiK=p=+i6Ub)3X&&dmQZD4^O?CVc)FBl{a(z^EO46ieVrU>zsC1IF{4 zd!zS4>aNd>aX-)_t{1FX(#{&r=f028IHZ?REYP>^E9*O=^7D@Z#{%-_=k|rm!9H*t zvgs$Zu20O1eNlk+?*X@i%z=B$m39-O`vurXnNRu2eekt(^{IcYpD&n)3Aq~V<-P36 zM+ja-4Cb~BF|aS{{NX-^uWR^T=7+JACox*9tgq+8np59$GGhVDz@Dhj(DIZzx0k%j zxZ^vSr!p_#0B}#9>=*5n^|7AsN2B9Q#j~F8nfLfPfcfzpn(sV+%gpnfnlE!Fk9m~t zS@rDY`6{H;df2O3vsVx2kppWZzsPf)I@GI7t=W3Mf2neMGV8_?gQ4!@St{ znHO_a`!VjKLR$QJ$PzHOym$2e706@1Dl6T4%DmnS)M+gnUGl`aD9~5IdcLnF_i&)E z=X;lTV?SeER11(m0FF6o+Oz3m7sel}hA-nB}kN&-y_;-R!D+;4MyA14W`_^-icfWIK@;LYXsQ~Y$TY!3A1F}}u z@CtBILpz`O4p3HNJ>MtE{C8;sK1U63VO@BZC-^!}ThI3{@8&I^Z|XIl-WmA}m1cg; zxu5lXKKg7mzct_SbHl>gyl(?%f(wAXUij}l!?ELoHtuh`UeEWI_kTJc@a$SQ=eRpC z=5_pbe}(Tag?8m51np-y&!I7A&GXrxqt6rK?Vcga%mahc^THr0)U+$j4s%e8e8h^Q^4`_}myH?{U+|j?u6`eH^q#ru^=ZXa4@m zOHT(a{nM6ydlp3fyx#rpAkQFm?aqSd!%95z3{ij&_BSQ{u6WT*H~jt4f-E~?tPfORfc?hV}Ct33=i{8 zmis8?nSaJVe|dN{mfzX>sqn==1@ofp(Ap6 zw)?zFU5nD>m`m_7*X*&3g9j2P$8HCD6ueYEE*??r6IedkE-<8#n{MsXeRycQsT z^)22#-1iJiSFSzVo^|)77m)X@^On!`wua_fo66>WafrG8a*jin?>Rfcg9-O$ z_nEotYFXFv8(;cc;i)#{&GQiP z8#`wq;_wbLA61|7ebfY>_C2efGin<54|j6d7&|)?eL9Scwz#KTU-G^RT6-R~L%qW< zZGW(lW8J^{$U1z~2kBqK=(FP6s&B?3{a(h*LA@8dd{N6d>-ZP(tYzCc>KPm9FKzf7 zX=Bi~ePCYm`9&{BpO|O+#acVhzIq3G>_vPCS?vk*r@#Fr=H`;SDEuAk#o%r49%VCs zwI4_NfL`pL6WUVugr10=YU7*GTajz>5Iuz5@UQBOJ>##nivG@CtA5Gf-w#jCP4;p0 zlzPl#TSxB_WFkk_#e5?hy<^^`k>k{3uJaxUf4uM8n6zR1_MW~e&pL9N&y?El#u3k> z^rxQx?tH9PWAp79%9{FIH3rtZ5_00ud3HO!h4}TdvnnAwV?%%bwcO3KO=WSwGr=p`dZ)B zvOW`^RT&pQ~&xO8Am#>Wt{_Z_f9_6x@%^flFxyAZ(9;1H>WBOrk z>pc3X<|uMS&f;7(&)PW0#GSnucLn}r%yGu=sXFl~bdH}LycRTEqti8 z2z~nN`7-YD_bKz>e)WBXKl452Pk$%;*|*B-moez4`K^0#PQ4pFN7k&`>H1Zgx|OLh zW?$u54|{g0e`M$C1a@9&4#^J{GCt-A8L88m%0zxhmfBf9^MbzxNI zt-!eC(`S9rKXXN2bf0uQ1td+L8-R3mIZAUsdDS7!dOE)o=$E5w?Ylq0$ITz_^)`P3{3G}?@CU=SK5YIN zkp9PY?%waC$35lT|HC?dicxuV#lCBJgHN8n0DlRjEBAMx%F4gy-}XPF@}eVj{|Re# zt4H6{Cv8Y`Pdo0p{w&ZpY3U2=wx>4#QRVql#=i!s!%}L~uOAt&d1KxAtzVg!XKd<~j?J)@HUAW}%!x7?zy7$VZTB5r ztIIypZxFhqnZvX#pKI+&W52cO{AkX~idwH`M_=^Gef`w7w9KEq-twg1H3#9Fyvka$ z^FMBBMxt32o_I3K$_M5zIe=n$_rQXXc?^EjjGa0wly(%9*e0ilyYvrEI+CAwP0c~ur zqqK{GaipEEU=DxV-)r6-_1tWv&S6KtwWkg9M=V_)q!W9@=3Kk-ORIdVJzqCI2cE2l zGR)N*{Ny(N2H{ylTGUGY=Be^+Jg4rNNA*~bjGvr@kI6I3Ugjz7%B#Pi`yF4Yaz~rv z@m!qU*wG$wg&&txTiY3p!`y1yI7?l-XPxQGpzW#jB}QwQ{%1WhwyZCDLJoS^kgm?G zkvSsv;Ia3gUHA0aJ=gSj7~!1ciQ z?(DPl!Rv4;nNRP#HYc2+h$Cy@Sy8{fdB5qK@#s_XSSNMJm;T#7(8AyJ zJAG^V*?TGSY5peVQa$o3Yuvj5b?b7Z%{Jb`S|8TR<(c@E&&<8dZvxA}b5Xz|*atZO z@%J)?5xa3tUR}pq7z?mBP6hbc=`75JIl3Eo*7k#g;C65)DBuPl&2#AQunSnOqkPhp zlV84jKmpQkt@HF>z5=cSsZU+Y<=hv_=x+gAz}3M0jF%pXcOhx+ua^6lvFB&VFD72|MX>jB zY_vHntih%$>bS)GDc}-tGB^QjtMfA%dA@Xe+nJvRxX*${t~Sj9&iJM$f`z(Pr+n&j zRL8MEd1|n!@n_T1SS!aJvFXde6p+u69*I#q%0C(K%-!^S;J))q!3My+6mxCTPn%8$ zbAY(o_`@ILQTv`Xt{x*bUq_NAhb!{f^o{2P}aBI0+c9dF1{xre0Yc zBR-@r8N2kB2&Gj$q^GU_k}Ypg%o zknX-U=8g_q+ISvl>H1|ot%Y;+rmdqH!*=FVy~Z>L(iiFTrBI8$La{V)&dhkbr7u&<=i7ZdwoJA3-C&dj+v$R4ma>`C=G+I!klPFl+7 zr@l=A_q40tHR6u?>6rlp8iski8Z%}&0Y07=Jx-ifpKTd?cB3qtSM*BTx;9>Z3pJZydZbfxzOjVP1Yjo ztDlR2IJ&bgk9Le#zCJKt&ONivv#$1Qty!Cg@Ui7n&UhTv)1Ec;XP)#!yU8nm=7XFa zZOrm*ItA_~i@ebzv7H|l>3gkPOyz06eIOm=X9r)kd`6(6Yi?S)7Hk7#soKbnT z+vd>y^jY2Mi?QW<^tg;X@}}MNuQW9Ej^|Z5ZL8Zod5on1bC_|PtMtn}sz2i{%&nt7 zr(e=?E?=7)-&x()*UYCm(njV;8EFMbAMdF%p`8k{CwDPVd-`EKex7lzy#8JYlD{w) zR|4(GpZ)4udzp82C|^L@&_CBpzY z_W@#4Y(LQ37xKy8P`4gIB4n1-@~JBdTHiB)v?5!XQw+TMWB$>Vy21xo zI@>40cRb*}4B9T{wNJxOa;0Ch3w7VzFrPVeM8~ZD7@OlHo1cY#A98!D%!ey4KAZc_ zm)17?)+uW9Tt?#?&w1tPa&rxQBJ1!^%sc5>iIac2aJ?B7oe~~@wp1IJzaY;XZ zNM9kl9r}6IhPLZ^c7LV)0W@+pV~z03TzB!_U-h0^Y1-Qe^c%hvw*DFVGb%5+n6VeI z)6wo@uB~gpxs^|z^8j)y^lgRy(aMJ}U5~cCRq3Bsw6e-4;aV=;%= zpIAfm&mPa-pALBQbLYR$psN6OyLSirXVUZUq!09Z zCq2YoVSE7m0wA|1y`$0?WBogI-SU5&y|)2+qSNs%=D#u~`-!^#WA=V(xIZET|4GWd z7ido(@F{qusb4#($NdLE>mzz2hLrs@`^2&09fTUiziakgf%C0Q{2cdIM&A>p-we#x zP2dbrz+J$#d-O}p3!~5MgJ2n`Lpk@Q$xHu@yt_%0PdVR%3fK*lmzMj5xjOa(_w-fW z1#AJA0QU;ep8m-vO+ETrnz?(@rMV}ceNrm)(|*xT>PX)+eOP60esmpz1PX5x&m2v$dpbq1g&(S?;X9Dw4fVA|ULg0=FfTdOTN!4FTJf}>d+VWCgsUJ^W$Ct<2jb*UdAJ@v~k_zxf<7db)(}<=H~8H zV9a6%Q1>!02K^A~nehI+xSL-MOab&PJ^`M>_?$|c8Lor22O2-OUOX1Sw|D{IK3v>X zW$59>6T#zHr!VMQO*ZKG6Sh;w$*k2q1)Nv=i%(;Y?vR;gE)Vzk;t7?e9&CnB=TzD~ zte*`sCil}0&$3RRcFqOr#ZKEhi)TaA7wv1)9HBG(kgklf$`!^7K=QYKqz_MIUp@M+ zKjf;@XYP0ggdTlr{ngF@C@)U(<~YA&FKjQ;3X_PjdG7yO;hDb|^< zGUN@N=2Kg(y?yN4cjyWE3HMCU$MdC))}}onE%mhf%zI_H7k(I@J#h-i+8Bd=O!85m z%$u>ERCPUnOs9IRP3EQ6I_nhn+dP_IeY~LRVT^Ukr+&|gx=#an2KB$~e|6x$Ho}g) z$i%#rH$Lux6+Lq{G<`|i`tod$^+$J?YwPcGz*wXU`$66Le8`wihBm1#?Y)V7=Qlot z&&nC&dUY!BJip4AZ+%$+8Haj|YYWI&w5?Bhwympj`tRKQWS-SYEO{1!$Mco@<^Uf@ za&KR$-*ag`@F8N#*tAvaXAQ&Vgg#7}F7Nu0F&LLNj4kIrcMEIlqYd}#81!m0=F;;{ zw6~1YedqdZ?Xfo!7r6=9)(_)X&lE^MGOs(Kwf96Tm(Od@fO6W#hZTO-dp+pd(7%k$ zXQy)7_a1;QU+~J4cf%yVwJT5djI}pkkE-%%3*SOt?Sq&blYZ#8e9DT`0KF4DxtDz7 z{_(!n%7%=*#?$t$J{qSsjg#IDUg_pO`>^IA_AY>)ee!(f=1|>PEBD*?HhooIo|LmM zGq+jKd!V6fB+psLnuE@My*r}6Q%~x)Ki$vVXS}YHM_-W(eZ~zv`r2^{w6RN5R=viO z`{qcv&Kene=FEBJ9f@fV^t{K^4PUP?ehHsH6MuJf1Ah5_e-PXO?gRx~2W|t0!0q4` zupbm4T{-9OEd%8pZ*1o7`58&Q1+;SWtd}aCGah{E(3kY%Rm|0y^76TsPhI+?o&v4~ z_tg1CjOsClR|5UM6{v?Z6Lq4d@%KyW(N4ypOyQG73N|I>;T4XOuN9v;CbK@a4Fzy#{aKoHzPgQyBu5rt^_XtSAna+ zUa$|m5WEPy7`z0$6clh4*b2@D=YVs;HgFzzCU_P&AK1s{u2d{DntStbJuoKoW*=C4 z^YRK{9gN>xm``(M&JO_VX*`bio(jJM;#| zH-hg6_!0l+?tP38fcJyn8uD)3%-0k$Z+y4G+xUp--uwn| z9Dd;6{1$K;Aiw$j^>eRh?+3vDz}q|1w2d z{;k(Lg|**<-Y>o0)3CSk(~RHD_fcO7J~sT$=VKU;!Poe=6Z$CZxr4y^iaWv0z*<`C zJ3s+Rb8a2+KjfrabL*SD_JjMW!#&sP(}sM+5cZo~bwBe`UZ}SKd&aqbO1B@+0EOE8 z2zW0bZ~1R9C%kfb79QR&26b;=0RHK!@WlU2H%dKZQULLK7TRuI{1#!{EU2W z`3;<5&Sc<4@YURn{C{=m%>i41%?%H|)X`fWdn@%E4bS7zGgWbJGoNkrY=S-ms zx^@QkK4Z+krjGKR1*(pSXDjQ*|4!z0RptQuoTovKoP$9{+h2ZB*iaPFN9OtXPWin>fVkz66XMVXX}ZqcY=$+ z$qk*mGwyWG{or138Q^{y6yROIIOHAhtcX1wVXwvDJ1b9{J9D^J{)`=d^+dj1lh@R1 z4%&6_nRn^KCw>zuzfu1UEpFcd&Gy>^LbLLobM6L z2j=@(;LGaz1m@?1Ck@xhAH3gHdCXax!`1S44SdU02A*&STB{$Kcu{>!5u# zv{R1I2J%>ANF(Do5ARgLv!jl#Tb>2hUjcZJ2|cf=>(d)sCqg3^gOk9MkI?li5k0(- zeNoTp;PT;qocm*-i<v={ArJP~k-p71y0~5n?MiTc9be8^^U(3UxbEfs_Ob~)FM+15?REUhF&@un`m>|* z=nr)5gsuO}{CqDq+WchP#?HG{_xvRO&Y$!b(qJ2K6wUb``F`V;=e9=A?TzeeJl-`^ z70+(w_3nxM{2=si20sAa488&U=n*@?qtCl5s-NBY)5e~PsyEMH$bKVxuLa)(wDT?C cTfw)1{|E19gSQZeIr|~-!@wBdO8y@6pW>5!1poj5 literal 0 HcmV?d00001 diff --git a/deps/flexi-streams/test/unicode_demo_ucs4_lf_le.txt b/deps/flexi-streams/test/unicode_demo_ucs4_lf_le.txt new file mode 100644 index 0000000000000000000000000000000000000000..043afc99273a582fd2a26cadbe4f16b4aa75a2ec GIT binary patch literal 30484 zcmd_zdDN$8Ss(B>la+)($O1`7!ZTUOWMMK{CJURHOeSRC!y={4o5`>VVX{IHsRirS zMS)V=B87@jBKU_yYn4`|)JPBIh^Wz8OBXAm)*jCBkbk;cyYj%nt__WFgS0^fG?;>8^N-cpmKkXMw7+DgtJ_*x&6ONF7u!PL7Hki$nK5PU zjEO~_;+3-OcJ|~q1#(ySagHnFoKNxMwLjwFUrd#iJK6Qj@@T8q zP-p(0*+#Fa+MmLgr*pj4r~2oHHwD)O>UmQz1?LBPa&d6cyowdSI`Uw*K5q@JmU=P; z`Uv`ZSzuNCpJ2H8dYXU=J-9G%pfqP}o%o&|e2A`UF)yLCAYvni1@?`bC_NLIqVxG(TNp`I~Yv;+nj(Prc zYAfEI!S{wh7i;Bt+{V2!-#ypV{yS&gcg?)hXPNF#T-cifetNzk`(-_8EPs~u&oTC%Dc18`VrI$j9OOM$v9}uB7dYP)to5AowOMA$dj0`>b@_hPhQ04j zY<(qoclLPp);DFH0?#9(?5lG|pDp#B=5zkV)^{&)c{dXqS@zi;ujyB1KLve{`+>;p z&Yms$Vz_S8XYK%YGOt7&WCY<1?nKCAO7px=6uS9@|JpFQ^X_4S3d=J572Qp=|Z zUXeJ}cA9ZZ_NAZft629H`>9Dl4#(%8UT6Al{`GuUaKf}#M*p4lv-70z(PqiL?5?0X zCr^8I?w!xbbYA$$@qV$t*w1vA6EqQwOzk9jaZgKeg_4s$ObGMji28t9sMx zYYMF&ugKb-Jv7r{@97Ob^t!GMcJbS@{lz{-_Q{I<#ooGKpB&U!U3*XSoYK$o_11ri z4%zX#u-`eO_2y^nRUREzeloZ-m}cxR_R2jO*Zsxbx}TWf-80n1+_x_3)p>L;%6}`T z)z)*ze-Fr*SGxG_Q|kKmfX#mH)fO4oMgCh8`-^>Fx_{nh`-{DGpAzV~a}72Q z^p=4pTbT=2R#uM5{-Uhq9Xp)+I>*+WofmjkM_2CDjekl%fBK7E_id@mZNc{7ni*48 zGrJm?Yjf*5=)E6}M+WU#a|+y>-W0I&j-d7468fg#%7J%j=qrM03HCQL%XI#%yf>eb z0M>zfBC{SJ`-{Evu5P^tu&bW#8T|~!Q(raruIJgsXRG?Q-W%qa)cvAhb8uN;)~Dc; z`Nvv0^uDma*!QLTjh^jZN6q!+Epv|hv%eVow?^-&^8Egq#M*Zw*P%YQ=l$&O>hnY` zb_V8WH83+)yk47l=4aV^;BDdG9&8J44PF*};K0NX;O_{gfSj{Fcl3JZYYMzKT0O@d z8eMdG{2vzHsPiikAk(jnnQ6S{&KJF1Gy1;1Df{L>g}yoHwcz@Yv%Sw!ayx^wf@QhO zZ@li-^0^v0_Smkxo-DKZk>q*b^Y-TUXy|_){Hx$I!CS-sC-Z)a{z~@0kp0_c`F|Pu zfzWiE|7_NWv;SPypAN=%BeFjqd}Y@CY-qN8J^r5tKNF1Si?;2>MCP9bKQ-?kj6HoC zeX;%jDyJ*g$VcpAdHbA?nCkOWq1CS6YiPX9;oh8yU(V{*T+w>)SkB!KJ6rhh^WncI z=X-pI#-qD?rdxk2@c-#~B`YrW%NN)E(bd0Y{d!_Pqx(NYzdv&9fx35A+W#?@^K;%F z$#?8eV|yrkw)IO6wIe^h=AX^h(fpD5$@#oBG_U*0<(Fm~k4K+fdcC$^8=e^UC8O@m zo$fCNW){t!KFV=p>@4=|s_@(wdS9GEuLf54xZOeT89PI}UZ;S(=NGhR4>GP{e0t-x z?OJz^KLz9cW|VVwQBa;epLBb_=;wH!mptce50>3KK9sy~PTp$QUbbKO<2>|QS1;Fw zo>#Uj{uEz&>Dub`VP?_2KYhonZ;tf9nYmc(=|PcOoR@zQIX-$V>7&^vXU@z>eJ|cu zcI2$Fl4r-BEwos+gsu-~=Gs|j+MLKkj{MagnciRdcdfe4T%YczW}M98wX-ay`f{Hh zV`10*3U9m~`ElPC7a8+iJ^R}RJ7N?A{d6d&iCb8 z9=*oK`QqE>$e07)=77I`ez`}PGj+D=HM(>4vCw8t40!wj`;B+o9P1NV#VdZYRx)Jy z?0wX}_3J#2bKu_9&x!VF*-V(JF~4QA)jG89;;T((@^7!iN>2Wbi~O$0v^Je%GsTWN zb`Ip|v%Wrh-O)8W&hgZ^cKGUjKsu~v`On@nx` zT$O{p*m_=n_%9E?d-o9Y0nX^k72P>v!@jjPo8oiM&X_Z~^K;J5I2Y|99l5a4ev##0 z9=%4{ZOvMfQwO`_bJ;E7tF=1!b8C#R^FXFO&?|n=%v$^IN#Zx(;vwrEU}bN-z83GD z^wfLtvto>sjM}rM2JL~k?E6{kT<)%$Wp$9R9z8yv%j1BVS39G=_}i<_$5D}2>vv?O z-#KZmdf)8~@Yj35*l)4Ri@#nMZ2w&Lk7aF+&VOn4)n2v6_0emgy`i&v){&RI@z`z8 zjt#BmV~+B1A6Li60=j%XG3YJ&+TXo$%vlU#R+IJIi(Au0pY-)uY^_~Ce>w|ha*SK8 zFOH6W$*Z4DYQCozS>m^d*QmOWJ*L-dd(25J zda-yf9CKiYZtcccaiSo^Hj{w({fYEI*Gh}_+`!~y!~x)6ImugBcT z_c@aco%V9PN4Wml5B;}Slf~LLCj8dODtFHy<7e$H*~?puY`Ir_Hgt1lYn&4{+pC8n zXWzclFRwA^^_VNZ7}^W^cxzq5>fpSwkMh0mEXK2awqIFs$w8dz+Zwtq-f#PcHIv=cP-{U&YF7*J##VgFQ56Yk0(Mm$M#7q&KmRL=b)TBb7MYZ z-mVezgQq{_$LpfGHm}z4u{oZ_y!5D_ALg6i%F^{*t2X#*i>~k1ti5s0o;s`lm>*mG z=w;)l?-~))7}wtk-}NguzG|!YFuY!io%Q#H_djBrANR`-WzQcue#9a^wK5ld=c#XB zBlCXiz1e&C>jLk`tHC|NviI73y|dpj>-B4O?Dl(ZQ|O%m9^3u?L%%MF=UhBf(D!s- zgG75T7njw(c9zBXrK46>ek1s=!M_WBecn&e`{K<1t*mHgzZN*7hxeQF`X92=XUn-g zS#o6lWAL8>e0qNnRG0j|>fvjzwL$jZMwe}N_-jmj;Mw!z%>Ju^*zjt{ew?X)Gt2yT z*8d#Th81s&_wo5$EWa9>kNUR$m!SFo%6v|)v*?Wf=Apjg;)Bhxwq)3EKH{lOvcB)J zCFs|uF9$ve|xL0_~Id>uKL%S+T)LTvmtlt(SP(W9MS9 zXG@RO3drH9VSSUc=MT?0x%xz}=UQ3p^;&+!(b*O!-*~N`Ss!H@_ZSaZx_Y)h-Okc_ za%c~FJ?Jq%zZa-a>(uLE>@m5qw_^^!lQS`^B_C>IZ4dYv=YVeG9`jyLTx@r4#52wX zn(fhFXQ=+{J3HpOF^==L*z3x4#=ED}T;<+e_*WCY#MAqH>#8>RqYj#0bD%>;UE3Qy zC||GW^qxRhJ;cLzV`T3e=}+tBo}>S8Yw%#;>)7Bka5eC`x$HCWsqi`doP%TOXfZL*wEFzDKuN`-WWJPDXa5~ zgNp)Z)fdA{XFlGjcjA18e`UZ%bHckSkVpM|OK7&nYkOb!j$St}ob|*_pAWgpMf`Hc zw^oK7&0i~1lBqwTe7(t5hzjWux%@z)->R@mp; z{Y`B8H_E6_b8YyRkKHD}U;#e#>gf4mrB=c1`GcYb3TYU;g%2%idqq=Jvq% zmRAFxt5dKkFcaH@+kz>$KJb3ppKpFs=qd1ia#pbHb9hJieovwAw%&Jl2i{|+zUbKifb@EU*Loo@}V_So`_Q2*0>#xHtNw|lY@utLy|V(b9v6s-+^NC!fpfOV^TEEA{|ka`!5P7`12)w0%0N!d zb=f+`&{z(N4xjXo2*kpVI;(>?)JWcZ@^3FEG@oKPat7X5gT~RGu_+fiY{)^6#lr`_ zbMjjQzW8`qF!IHvpL&62x4zc1^4)r}%a0y57WNJc*hilk=#g03FTGogues@A`?gpU zwKebTvw2<67}%EgsR0}6peAxHEno4l?+m>xe);gdo_erVdA`NwIyofZj~(Y`?eKu# z#-R?4!;D=Rm@7PUv1}g1Tc54D8gvHq$4s(kHGBNg!>f)s#imxy_+@urd8@J5_-G8| z^|raPC6>-eYlANqH8QjG#Ir2dlf$pQ%Ckq$Oj$1t@Z?U$e%nmTX?q|>GWcqZ4}8*F zPk+gp=#Z(bz52@y-@a#j=*hC4n_;zU+-URvv_RhSm)A(U z7VxU4XZC!npIFsLUFfa17GiF1+6(nyPn??qd6*S3lHo_bH}|#wa=zg_|;?AGpSg` zg&u3uSm;*2KInL^J~x;Ge%Wmeoi}E@#-cXOby0^5+4^mK)4*eQv99#^X4@GVxlDl? zHYPP{TbtL(B#J2cxH7j*49&v_-Kvj;7tMk;!JH0@2sFRxg&Iai$gx% zXVCP;yX<}G=J5F;-+8s?uXSgG{uI=Q`0Td@=55S_yga5r%~k{Y>elxNG#kre+H!R6 z)4?AFQ)E6o)AwiH6l|UO@6Y&XF`_szT?%=(33(Uuri zW*NSZ3yus5;gO3@U3b*gb3J@pn)lZgPvhz8>BS0{VAlH4D22-iJf;r3M!U zbPb@*(EQEc_MIW*YIldsZEKC}Z!MJ~Au0#rmHS-Z^BVFJJTN8o57f{m?xqy!U4%cSP3f2AM^hznb$u zxo#uxey9Ft2YccPPu_P2P`N6ZS z+VM}1?Lz`S?KefvnVc&xp9g~@f-S)pf<-^-q}Ful)!v<<^T^=E=l1RtAuR{LL`_oMum!uyfn%Ry~C z68h%?_Nx0E^ZvK8{@8pz>X4`R69FADutye;EI+m5{4>EABUwJH`@7kTyU#4nU{i2Y zFg|;Ep6N3~pS#q{bH=&B6nN&c@AC$F3Ou9S7pw+s(DOWkN4C#(eRk{f4L#36Q*eDi zAFtf}s)oK3-Ejq#i{AF_Chwij!)X!o|k#^%s! zcUI8ryZU}u+aA-j8vS3T_jKKNM ztj7gU4;l+TEYrn*VPyHPjT1t%jfbxPQ$n*%=fJFFo*NuH^Vm5&5Yq)S@8PU33YwGi z`Z+mt?eTMAz%D=I?3|yySn%0VBR0i>Plv8^JpL;`#?cs_lXJA##iLfWC!Qk$cEmKs z%g-4BeSALjf$UhrF?P9<lj7vpdFJf8-baZ6q6rxwR6b9;gjJY_|3{h9>V!eL-%`d951J5ohge3*8*XSodXr zyf)~{ORV)h_D!DRYK+ZY?VdUF*&xU6YQP>|^J#z7g&jGQubh5@Yle<9e#A58v@v`7 zYSUQN0*{V(#MPN+L%qn?W_>!ttG;^jHTt_FJabps_1-J^7=4NruXe_BbYqhTsL$y^ zdm{&NEQ?W0>c;l71GcW6S3LIE(VNz#z2>{UYaQr|-PvVvPnXpZmb#%$y(I=$pM41?~Ugp<8SH_cW!a z1-n`btK4FIXGLz*r9)OeYWWeKgu`>nUTl;fUSB7Rs4*m|2cNXtV z?3@*tJz$R=ewqiJ)6XU^d#y+1`K#z9-&{D}z@B-x^H8dBK*z z&jDW$To_ywYz;0BE(tCTE(^wMSAJ@*4&Hg?q;BRwPu1m(fj-DzE!0!3)coE+-_=!3 z%$s-Uw+3pXr*99Y;3L5!!A}Lh5Ihz<9(+0Y_rdQ6PXzxf7-KwU%I9NneBkdjo*bMK zOu?za^Mftujj7cE`5Jlfw&0z?C&SNwd;adwdk@U_Py)Zl_ekJ(?)(m`-~03Xm41hn z>`@2hIu4Ew{0y|8N%ymqe&*NDQ2H5PKYKpLXplDq{eMFE|2do;tOou2_3zoZvhqX0 z$AeD?zZ2~7cShc|1Aq7UmBD+0pABC4{Cp2SAalTf%kL4UFqfY`{~h$_#osCUeWJwi zU0HA5kl%v{{LSYt9-LSMzZW4!Fmw8}YldFwtzPQ2{!Kx7XnkA_=;7-@UVHwWsAKg!%XpS^Kj?^q&pTX=kIo7a~w$Q+n` zjCo(X*1s|H#@eZ2 zYiC`opE{7IPu701e&e2;{bK#PAJ@`!(6!TgEZV`Z&R-2(y~^7k8UBvos^FMe1|J?A z_7BgrdS4PecitbH_0r(@d0$=Y-<)~(W*uv|R{idb-0G}DhK;|Rb>~dmpA`D8VUPD$ zvOj&`kp*v5DcJQn7 z9fQ5f(|u3)@ZK5k%L+dGfXw0ZiaunfTfduzvqNXP_50h|FJ7PK)m-eFS99Au*cWgA ze(v3&-QWC;+U8N2SI%d>zrA{i%&WrV>+*U1OA9jU(0HzxWyJH%s?QI^*I1wCE$24` z*5)s7XuR^eD6qnK{qG+5qs&{vX9LzF<6hIx&le4J?>+4NQ25^!{N3OK!FL8f95^e) zeEp2Z+4 — 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: █ ▉ ╔══╦══╗ ┌──┬──┐ ╭──┬──╮ ╭──┬──╮ ┏━━┳━━┓ ┎┒┏┑ ╷ ╻ ┏┯┓ ┌┰┐ ▊ ╱╲╱╲╳╳╳ ║┌─╨─┐║ │╔═╧═╗│ │╒═╪═╕│ │╓─╁─╖│ ┃┌─╂─┐┃ ┗╃╄┙ ╶┼╴╺╋╸┠┼┨ ┝╋┥ ▋ ╲╱╲╱╳╳╳ ║│╲ ╱│║ │║ ║│ ││ │ ││ │║ ┃ ║│ ┃│ ╿ │┃ ┍╅╆┓ ╵ ╹ ┗┷┛ └┸┘ ▌ ╱╲╱╲╳╳╳ ╠╡ ╳ ╞╣ ├╢ ╟┤ ├┼─┼─┼┤ ├╫─╂─╫┤ ┣┿╾┼╼┿┫ ┕┛┖┚ ┌┄┄┐ ╎ ┏┅┅┓ ┋ ▍ ╲╱╲╱╳╳╳ ║│╱ ╲│║ │║ ║│ ││ │ ││ │║ ┃ ║│ ┃│ ╽ │┃ ░░▒▒▓▓██ ┊ ┆ ╎ ╏ ┇ ┋ ▎ ║└─╥─┘║ │╚═╤═╝│ │╘═╪═╛│ │╙─╀─╜│ ┃└─╂─┘┃ ░░▒▒▓▓██ ┊ ┆ ╎ ╏ ┇ ┋ ▏ ╚══╩══╝ └──┴──┘ ╰──┴──╯ ╰──┴──╯ ┗━━┻━━┛ ▗▄▖▛▀▜ └╌╌┘ ╎ ┗╍╍┛ ┋ ▁▂▃▄▅▆▇█ ▝▀▘▙▄▟ \ No newline at end of file diff --git a/deps/flexi-streams/test/unicode_demo_utf8_crlf.txt b/deps/flexi-streams/test/unicode_demo_utf8_crlf.txt new file mode 100644 index 0000000..d475c08 --- /dev/null +++ b/deps/flexi-streams/test/unicode_demo_utf8_crlf.txt @@ -0,0 +1,212 @@ + +UTF-8 encoded sample plain-text file +‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾ + +Markus Kuhn [ˈmaʳkʊs kuːn] — 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: █ + ▉ + ╔══╦══╗ ┌──┬──┐ ╭──┬──╮ ╭──┬──╮ ┏━━┳━━┓ ┎┒┏┑ ╷ ╻ ┏┯┓ ┌┰┐ ▊ ╱╲╱╲╳╳╳ + ║┌─╨─┐║ │╔═╧═╗│ │╒═╪═╕│ │╓─╁─╖│ ┃┌─╂─┐┃ ┗╃╄┙ ╶┼╴╺╋╸┠┼┨ ┝╋┥ ▋ ╲╱╲╱╳╳╳ + ║│╲ ╱│║ │║ ║│ ││ │ ││ │║ ┃ ║│ ┃│ ╿ │┃ ┍╅╆┓ ╵ ╹ ┗┷┛ └┸┘ ▌ ╱╲╱╲╳╳╳ + ╠╡ ╳ ╞╣ ├╢ ╟┤ ├┼─┼─┼┤ ├╫─╂─╫┤ ┣┿╾┼╼┿┫ ┕┛┖┚ ┌┄┄┐ ╎ ┏┅┅┓ ┋ ▍ ╲╱╲╱╳╳╳ + ║│╱ ╲│║ │║ ║│ ││ │ ││ │║ ┃ ║│ ┃│ ╽ │┃ ░░▒▒▓▓██ ┊ ┆ ╎ ╏ ┇ ┋ ▎ + ║└─╥─┘║ │╚═╤═╝│ │╘═╪═╛│ │╙─╀─╜│ ┃└─╂─┘┃ ░░▒▒▓▓██ ┊ ┆ ╎ ╏ ┇ ┋ ▏ + ╚══╩══╝ └──┴──┘ ╰──┴──╯ ╰──┴──╯ ┗━━┻━━┛ ▗▄▖▛▀▜ └╌╌┘ ╎ ┗╍╍┛ ┋ ▁▂▃▄▅▆▇█ + ▝▀▘▙▄▟ diff --git a/deps/flexi-streams/test/unicode_demo_utf8_lf.txt b/deps/flexi-streams/test/unicode_demo_utf8_lf.txt new file mode 100644 index 0000000..4363f27 --- /dev/null +++ b/deps/flexi-streams/test/unicode_demo_utf8_lf.txt @@ -0,0 +1,212 @@ + +UTF-8 encoded sample plain-text file +‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾ + +Markus Kuhn [ˈmaʳkʊs kuːn] — 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: █ + ▉ + ╔══╦══╗ ┌──┬──┐ ╭──┬──╮ ╭──┬──╮ ┏━━┳━━┓ ┎┒┏┑ ╷ ╻ ┏┯┓ ┌┰┐ ▊ ╱╲╱╲╳╳╳ + ║┌─╨─┐║ │╔═╧═╗│ │╒═╪═╕│ │╓─╁─╖│ ┃┌─╂─┐┃ ┗╃╄┙ ╶┼╴╺╋╸┠┼┨ ┝╋┥ ▋ ╲╱╲╱╳╳╳ + ║│╲ ╱│║ │║ ║│ ││ │ ││ │║ ┃ ║│ ┃│ ╿ │┃ ┍╅╆┓ ╵ ╹ ┗┷┛ └┸┘ ▌ ╱╲╱╲╳╳╳ + ╠╡ ╳ ╞╣ ├╢ ╟┤ ├┼─┼─┼┤ ├╫─╂─╫┤ ┣┿╾┼╼┿┫ ┕┛┖┚ ┌┄┄┐ ╎ ┏┅┅┓ ┋ ▍ ╲╱╲╱╳╳╳ + ║│╱ ╲│║ │║ ║│ ││ │ ││ │║ ┃ ║│ ┃│ ╽ │┃ ░░▒▒▓▓██ ┊ ┆ ╎ ╏ ┇ ┋ ▎ + ║└─╥─┘║ │╚═╤═╝│ │╘═╪═╛│ │╙─╀─╜│ ┃└─╂─┘┃ ░░▒▒▓▓██ ┊ ┆ ╎ ╏ ┇ ┋ ▏ + ╚══╩══╝ └──┴──┘ ╰──┴──╯ ╰──┴──╯ ┗━━┻━━┛ ▗▄▖▛▀▜ └╌╌┘ ╎ ┗╍╍┛ ┋ ▁▂▃▄▅▆▇█ + ▝▀▘▙▄▟ diff --git a/deps/flexi-streams/util.lisp b/deps/flexi-streams/util.lisp new file mode 100644 index 0000000..85dbde3 --- /dev/null +++ b/deps/flexi-streams/util.lisp @@ -0,0 +1,206 @@ +;;; -*- 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 + ;; by Vebjorn Ljosa - see also + ;; + `(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 + ;; by Vebjorn Ljosa - see also + ;; + (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))) diff --git a/deps/hunchentoot/.gitignore b/deps/hunchentoot/.gitignore new file mode 100644 index 0000000..6896773 --- /dev/null +++ b/deps/hunchentoot/.gitignore @@ -0,0 +1,2 @@ +*.*f*sl +*~ diff --git a/deps/hunchentoot/.pre-release.sh b/deps/hunchentoot/.pre-release.sh new file mode 100755 index 0000000..a4f1c8f --- /dev/null +++ b/deps/hunchentoot/.pre-release.sh @@ -0,0 +1 @@ +cd doc; make diff --git a/deps/hunchentoot/CHANGELOG b/deps/hunchentoot/CHANGELOG new file mode 100644 index 0000000..d8ce7bb --- /dev/null +++ b/deps/hunchentoot/CHANGELOG @@ -0,0 +1,567 @@ +Version 1.2.38 +2017-12-03 +Better pathname validation. +A couple of small fixes. + +Version 1.2.37 +2016-12-11 +Support listening on random port number (Lucien Pullen) + +Version 1.2.36 +2016-12-08 +Compare on the path-string. (matthieupeeters) +speed up shutdown and avoid timeout on the listening socket (Felix Lange) +clarify definition of handler function (Robert Smith) +[doc] fix ID clash in index.xml (Alex Dunn) + +Version 1.2.35 +2016-02-10 +Avoid double URL decoding, reported by muyinliu (Hans Huebner) +Remove a duplicate word in the documentation (William Halliburton) +Call convert-hack in name also (José Ronquillo Rivera) + +Version 1.2.34 +2015-07-06 +decode URL considering content-type's charset (Tim Richardt) + +Version 1.2.33 +2015-07-05 +Ignore malformed session IDs (Hans Huebner) +prevent failures when session cookie is malformed (Andrey Kutejko) +correct started-p for lispworks (LinkFly) + +Version 1.2.32 +2015-05-03 +Adds the session-regenerate-cookie-value function (Florian Margaine) +Bugfix: using variables within with-accessors (Dmitry Igrishin) +Added Gitter link (The Gitter Badger) +Add "charset" property to Content-Type HTTP header (Dmitry Igrishin) +"Connection: close" on unthreaded builds (Philipp Marek) +Make the RFC 6585 status constants external (Grim Schjetne) +Add HTTP status codes described in RFC 6585 (Grim Schjetne) +Add charset to Content-Type when serving static (Dmitry Igrishin) +Fix to PROCESS-CONNECTION leaking socket fds (Jussi Lahdenniemi) + +Version 1.2.31 +2015-03-06 +Adds HttpOnly and remove cookie on remove-session (Florian MARGAINE) + +Version 1.2.30 +2015-02-25 +Clear content-length before emitting 304 (Jason Miller) +Treat errors during url decoding as bad requests. (Stas Boukarev) + +Version 1.2.29 +2014-11-30 +temporarily revert ipv6 changes (Hans Huebner) + +Version 1.2.28 +2014-11-28 +Remove dead links and update support information (Hans Huebner) +restore listening to usocket:*wildcard-host* (Hans Huebner) +deal with IPv6 addresses from usocket (Hans Huebner) +eliminate duplicate logging of warnings (reported by loke) (Hans Huebner) +add DETACH-SOCKET function (Hans Huebner) +Add the ability to prevent the sockets from being closed after a request has been processed. (Elias MÃ¥rtenson) +document *FINISH-PROCESSING-SOCKET* (Hans Huebner) +Make check for stream timeouts more robust (Raymond Wiker) + +Version 1.2.27 +2014-05-18 +fix warning about missing NAME keyword arg at start-thread (Mark H. David) +remove tbnl-announce list (Hans Huebner) +correct speling eror (Hans Huebner) +Update request.lisp (muyinliu) +file upload file name encoding error fixed (muyinliu) +support use of logical file names for document-root and error-template-directory (Hans Huebner) +Generate www/hunchentoot-doc.html. (Stas Boukarev) +Remove mentions of asdf-install and the darcs mirror from docs. (Stas Boukarev) + +Version 1.2.26 +2014-01-18 +Optimize get-peer/local-address-and-port. (Stas Boukarev) +Close SSL streams after processing connection. (Stas Boukarev) + +Version 1.2.25 +2014-01-17 +allow for handler setting of the "connection" header (William Halliburton) + +Version 1.2.24 +2014-01-07 +Use version number from ASDF system definition, not special var (Hans Huebner) + +Version 1.2.23 +2014-01-05 +Don't set the Connection header to Close if it's already set (AndrejSuc/Stas Boukarev) + +Version 1.2.22 +2013-12-09 +Print header value (if number) in base 10 (Chaitanya Gupta) +Fix for CLISP compilation (Anton Vodonosov) + +Version 1.2.21 +2013-10-04 +Fix capitalization inconsistencies in docs (reported by Stas Boukarev) + +Version 1.2.20 +2013-10-04 +Don't rely on asdf to find default document directory +Add m4v mime type (Wes Henderson) + +Version 1.2.19 +2013-07-28 +Fix ACCEPTOR-REMOVE-SESSION default implementation (Stas Boukarev, Mathieu Lemoine) + +Version 1.2.18 +2013-05-03 +Prevent errors when basic auth user or password contains colon +Add missing implementation for client-as-string for Lispworks, contributed by Raymond Wiker + +Version 1.2.17 +2013-04-01 +New START-THREAD API function (Faré Rideau) + +Version 1.2.16 +2013-03-31 +Fix bug that caused error when requesting nonexistent page. + +Version 1.2.15 +2013-03-17 +Fix race condition in acceptor shutdown (Faré Rideau) + +Version 1.2.14 +2013-03-08 +Call ACCEPTOR-STATUS-MESSAGE in a saner and more useful fashion (sponsored by Ron Garret) + +Version 1.2.13 +2013-03-03 +fix wrong documented signature in acceptor-status-message (reported by Zach Beane) + +Version 1.2.12 +2013-03-03 +Various documentation updates +Fix bug in static file handling that caused Safari to hang on 304 responses by Hunchentoot (reported by Wim Oudshoorn) + +Version 1.2.11 +2013-01-27 +Fix bug in MD5-HEX that could cause session keys to be reused + +Version 1.2.10 +2013-01-19 +Add local-addr* and local-port* functions + +Version 1.2.9 +2012-12-28 +Fix test script to accomodate for Drakma fix regarding redirect from POST to GET +Fix range handling once again + +Version 1.2.8 +2012-12-19 +ECL fixes (Juan Jose Giarcia-Ripoll) + +Version 1.2.7 +2012-10-19 +Fix documentation for COOKIE-IN, which returns a string, not a cookie. +Hunchentoot could not deal with / pointing to a static file directory (Stas Boukarev). +Fixes to pathname sanitizing when handling static files. +Further Range: header handling fixes +Fix some export names relating to taskmaster thread count (Faré Rideau) + +Version 1.2.6 +2012-09-02 +Doc fixes, add .pre-release.sh script + +Version 1.2.5 +2012-09-02 +High-load multithread stability fixes (Mathieu Lemoine) + +Version 1.2.4 +2012-08-16 +Remove dead code & style fixes (Ala'a Mohammad) +Bug fix: setting *print-base* / *print-radix* caused invalid cookie values (Scott L. Burson) +Various documentation and style updates +Fix documentation bug found (Mathieu Lemoine) +Fix bug that could hang Hunchentoot under load (Mathieu Lemoine) + +Version 1.2.3 +2012-03-03 +Fix crash when error occurs while logging error (reported by Xu Jingtao) +Fix compilation with :hunchentoot-no-ssl feature (Mark Evenson) +Fix Range header handling (Simon Sandlund) +Export acceptor-remove-session +ECL timeout support (Juan Jose Giarcia-Ripoll) +Changed cookie handling - Hunchentoot no longer encodes cookies +automatically. Applications must make sure that they only set cookies +to permitted values (refer to RFC6265 for the details, thanks to Ralf +Stoye for debugging help) + +Version 1.2.2 +2011-11-30 +Fix warning on LispWorks (Nico de Jager) +Documentation updates +Remove obsolete symbols from export list +Add easy-ssl-acceptor +Document acceptor-remove-session, remove obsolete *session-removal-hook* export (Issue #15) +Added :description to asdf system definition +Add documentation section describing how to bind to privileged ports + +Version 1.2.1 +2011-11-04 +Use FINISH-OUTPUT instead of FORCE-OUTPUT at connection end (I. Perminov) +Documentation updates +External format EOL style fixes for Windows (Anton Kovalenko) + +Version 1.2.0 +2011-10-30 +Fix to allow send-service-unavailable-reply to work (Faré Rideau) +Make sure we always have a cooked message to send in case of error (Faré Rideau) +Add www/ directory with default file tree that is being served +Add error template mechanism and improve error reporting in general. +Improve automatic testing, SBCL kludge to support asdf:test-op +Allegro CL modern mode fixes +Fix bugs in serving partial responses +Limit maximum number of threads that Hunchentoot creates (Dan Weinreb, Scott McKay) +Export fixes (Gordon Sims, Andrey Moskvitin, Faré Rideau) +Factor out easy-handler logic into separate acceptor subclass +Export two session functions (Nico de Jager) +Allow no Content-Type header (Chaitanya Gupta) +Patch for compilation with ECL (Sohail Somani) +Fix DEFINE-EASY-HANDLER for multiple acceptors (Nicolas Neuss) +Revived *SHOW-LISP-BACKTRACES-P* +Made sure "100 Continue" is returned even if the client sends "Expect: 100-continue" twice (reported by Gordon Sims) +Fixed typo in code which interprets transfer encodings + +Version 1.1.1 +2010-08-24 +Exported WITHIN-REQUEST-P (Faré Rideau) +Safeguard measures against XSS attacks (J.P. Larocque) +Prevent potential leak when closing stream (Matt Lamari, Martin Simmons) +Change some occurrences of HANDLER-CASE* to HANDLER-CASE (Hans Hübner, Allan Dee) + +Version 1.1.0 +2010-01-08 +Architectural changes - see HANDLE-REQUEST (thanks to Andreas Fuchs and Frode Fjeld) +Re-introduced *CATCH-ERRORS-P* and MAYBE-INVOKE-DEBUGGER +Integration with trivial-backtrace (see *LOG-LISP-BACKTRACES-P*) +Treat :UNSPECIFIC like NIL in pathname components (reported by Frode Fjeld) +Fixed RESET-SESSIONS +Prepared for LispWorks 6 (Nico de Jager) +Fixed reading of post parameters (Peter Seibel and Stephen P. Compall) +Fixed STOP by supplying the :READY-ONLY keyword to USOCKET:WAIT-FOR-INPUT +Enabled SSL key passwords for Lisps other than LW (Vsevolod) + +Version 1.0.0 +2009-02-19 +Complete architectural redesign (together with Hans Hübner) +Lots of small fixes and improvements, too many to enumerate here + +Version 0.15.6 +2008-04-09 +Fixed embarrassingly mis-placed parentheses (thanks to Hans Hübner) + +Version 0.15.5 +2008-04-08 +Removed FORCE-OUTPUT* and thus the ACL-COMPAT dependency (thanks to Hans Hübner) +Support for MP-less CMUCL (thanks to Hans Hübner) + +Version 0.15.4 +2008-03-27 +Fixed unportable LOOP usage (caught by "C S S") + +Version 0.15.3 +2008-03-17 +Added CODE parameter to REDIRECT (thanks to Michael Weber) + +Version 0.15.2 +2008-03-06 +Fixed typo in test.lisp (thanks to Ben Hyde) +Changed wrong usage of EQ to EQL (thanks to Ariel Badichi) +Fixed typo in default handler (thanks to Eugene Ossintsev) + +Version 0.15.1 +2008-02-13 +Uses CL-FAD for HANDLE-STATIC-FILE now +Better error reporting for CREATE-FOLDER-DISPATCHER-AND-HANDLER (suggested by Cyrus Harmon) +Faster version of WRITE-HEADER-LINE (thanks to V. Segu�) + +Version 0.15.0 +2007-12-29 +Added support for CLISP (thanks to Anton Vodonosov) + +Version 0.14.7 +2007-11-15 +Replace ENOUGH-NAMESTRING with ENOUGH-URL (patch by Kilian Sprotte and Hans Hübner) + +Version 0.14.6 +2007-11-08 +Fix compilation order (thanks to Tiarnan O'Corrain and Chris Dean) + +Version 0.14.5 +2007-10-21 +Robustified MAKE-SOCKET-STREAM against potential leak (thanks to Alain Picard) +Replaced #-FOO #-FOO constructs for OpenMCL (patch by Michael Weber) +Updated tutorial links + +Version 0.14.4 +2007-10-20 +Made log stream shared on OpenMCL (thanks to Gary Byers) + +Version 0.14.3 +2007-10-07 +Enabled GET-GID-FROM-NAME for newer versions of SBCL (patch by Cyrus Harmon) + +Version 0.14.2 +2007-09-26 +Better handling of PORT parameter in REDIRECT (thanks to Vladimir Sedach) + +Version 0.14.1 +2007-09-24 +Fixed bug where you couldn't set "Server" header (caught by Ralf Mattes) +Documentation clarification for HEADER-OUT function + +Version 0.14.0 +2007-09-18 +Added support for "HttpOnly" cookie attribute + +Version 0.13.0 +2007-09-14 +Added *METHODS-FOR-POST-PARAMETERS* (suggested by Jonathon McKitrick) + +Version 0.12.1 +2007-09-13 +Better support for WITH-TIMEOUT on SBCL/Win32 (thanks to Anton Vodonosov) + +Version 0.12.0 +2007-09-07 +Now uses bound for flexi stream returned by RAW-POST-DATA +Needs FLEXI-STREAMS 0.12.0 or higher + +Version 0.11.2 +2007-09-05 +Fixed typo in docs +Added declaration in server.lisp to appease SBCL + +Version 0.11.1 +2007-05-25 +Fixes for OpenMCL (thanks to Lennart Staflin and Tiarnan O'Corrain) + +Version 0.11.0 +2007-05-25 +Added server names and coupled them with easy handlers (suggested by Mac Chan) +Exported SESSION-COOKIE-VALUE instead of SESSION-STRING (suggested by Slava Akhmechet) +Documentation fixes (thanks to Victor Kryukov and Igor Plekhov) + +Version 0.10.0 +2007-05-12 +Made MAYBE-INVOKE-DEBUGGER a generic function and exported it (suggested by Vladimir Sedach) + +Version 0.9.3 +2007-05-08 +Fixed CREATE-FOLDER-DISPATCHER-AND-HANDLER in the presence of URL-encoded URLs (bug caught by Nicolas Lamirault) + +Version 0.9.2 +2007-05-01 +Made DEF-HTTP-RETURN-CODE more flexible (suggested by Jong-won Choi) + +Version 0.9.1 +2007-04-29 +Added PORT parameter to REDIRECT (suggested by Cyrus Harmon) +Exported REMOVE-SESSION (suggested by Vamsee Kanakala) + +Version 0.9.0 +2007-04-19 +Added socket timeouts for AllegroCL +Catch IO timeout conditions for AllegroCL, SBCL and CMUCL (suggested by Red Daly and others) +Added per-server dispatch tables (suggested by Robert Synnott and Andrei Stebakov) + +Version 0.8.6 +2007-04-18 +USE the CL package explicitly when defining HUNCHENTOOT-MP (bug report by Joel Boehland) + +Version 0.8.5 +2007-04-10 +Correct behaviour for "100 Continue" responses + +Version 0.8.4 +2007-04-09 +Cleanup + +Version 0.8.3 +2007-04-07 +Don't use chunked encoding for empty (NIL) bodies + +Version 0.8.2 +2007-04-05 +Really exported REASON-PHRASE this time (and also *CURRENT-PROCESS*) + +Version 0.8.1 +2007-04-04 +Added HUNCHENTOOT-MP package (suggested by Cyrus Harmon) +Only invoke MARK-AND-SWEEP for 32-bit versions of LW (thanks to Chris Dean) +Exported REASON-PHRASE + +Version 0.8.0 +2007-03-31 +Added *APPROVED-RETURN-CODES*, *HEADER-STREAM*, and +HTTP-FAILED-DEPENDENCY+ +Exported MIME-TYPE and SSL-P +Some minor changes + +Version 0.7.3 +2007-03-28 +Added +HTTP-MULTI-STATUS+ + +Version 0.7.2 +2007-03-09 +Fix test suite to properly handle non-base characters in LW (bug caught by Jong-won Choi) + +Version 0.7.1 +2007-03-09 +Fixed last change (thanks to Marko Kocic) + +Version 0.7.0 +2007-03-09 +Development port (no threads) to SBCL/Win32 (patch by Marko Kocic) +Support for compilation without SSL + +Version 0.6.2 +2007-02-22 +Don't use NSTRING-UPCASE for outgoing headers (bug caught by Saurabh Nanda) +Changed ProxyPass example in docs from /lisp to /hunchentoot + +Version 0.6.1 +2007-01-24 +Reset to "faithful" external format on each iteration (bug caught by Viljo Marrandi and Ury Marshak) + +Version 0.6.0 +2007-01-23 +Accept chunked transfer encoding for mod_lisp request bodies (thanks to Hugh Winkler's mod_lisp additions) +Robustify against erroneous form-data submissions (caught by Ury Marshak) + +Version 0.5.1 +2007-01-18 +Even more flexible behaviour of RAW-POST-DATA + +Version 0.5.0 +2007-01-17 +More flexible behaviour of RAW-POST-DATA +Robustified PARSE-CONTENT-TYPE + +Version 0.4.14 +2007-01-17 +More meaningful results for RAW-POST-DATA + +Version 0.4.13 +2007-01-14 +Added favicon.ico to example website (thanks to Yoni Rabkin Katzenell, Toby, and Uwe von Loh) + +Version 0.4.12 +2006-12-27 +Added Hunchentoot logo by Uwe von Loh + +Version 0.4.11 +2006-12-01 +Exported symbols related to session GC (suggested by Nico de Jager) + +Version 0.4.10 +2006-11-19 +Added *HANDLE-HTTP-ERRORS-P* (thanks to Marijn Haverbeke) +Remove duplicate headers when reading from mod_lisp + +Version 0.4.9 +2006-11-12 +Fixed HEADER-OUT (thanks to Robert J. Macomber) + +Version 0.4.8 +2006-11-06 +Fixed bug in START-OUTPUT which confused mod_lisp + +Version 0.4.7 +2006-11-06 +Changed behaviour of REAL-REMOTE-ADDR (as suggested by Robert J. Macomber) +Fixed COOKIE-OUT (thanks to Robert J. Macomber) + +Version 0.4.6 +2006-11-05 +Don't bind *DISPATCH-TABLE* too early (thanks to Marijn Haverbeke) + +Version 0.4.5 +2006-10-25 +Fixed bug in AUTHORIZATION function (reported by Michael J. Forster) + +Version 0.4.4 +2006-10-12 +Correct SSL check in REDIRECT function +LOG-MESSAGE now checks for (BOUNDP '*SERVER*) + +Version 0.4.3 +2006-10-11 +OpenMCL fixes (by Ralf Stoye) + +Version 0.4.2 +2006-10-10 +No timeouts for mod_lisp servers (as in Hunchentoot 0.3.x) + +Version 0.4.1 +2006-10-10 +Fixed a typo in easy-handlers.lisp (caught by Travis Cross) + +Version 0.4.0 +2006-10-10 +Ported to CMUCL, SBCL, OpenMCL, and AllegroCL +Merged with TBNL +Tons of small changes, too many to list them individually + +Version 0.3.2 +2006-09-14 +Uses TBNL's WITH-DEBUGGER now + +Version 0.3.1 +2006-09-14 +Added *CATCH-ERRORS-P* (from TBNL) + +Version 0.3.0 +2006-09-05 +Accept HTTP requests with chunked transfer encoding +Use Chunga for chunking + +Version 0.2.2 +2006-08-31 +Skip START-OUTPUT advice completely if working for TBNL + +Version 0.2.1 +2006-08-28 +Added write timeouts for LW 5.0 +Updated LW links in documentation + +Version 0.2.0 +2006-08-28 +Serves as infrastructure for TBNL now (to replace KMRCL) +For HTTP/1.1 only send 'Keep-Alive' headers if explicitly requested + +Version 0.1.5 +2006-08-23 +Connection headers are separated by commas, not semicolons + +Version 0.1.4 +2006-08-22 +Refactored streams.lisp to appease LW compiler (thanks to Martin Simmons) +Changed handling of version string +Changed package handling in system definition (thanks to Christophe Rhodes) + +Version 0.1.3 +2006-02-08 +Removed KMRCL workaround + +Version 0.1.2 +2006-01-03 +Mention TBNL version number in server name header + +Version 0.1.1 +2005-12-31 +Fixed package stuff and HYPERDOC support + +Version 0.1.0 +2005-12-31 +Initial public release + +[For earlier changes see the file "CHANGELOG_TBNL" that is included with the release.] diff --git a/deps/hunchentoot/CHANGELOG_TBNL b/deps/hunchentoot/CHANGELOG_TBNL new file mode 100644 index 0000000..8933384 --- /dev/null +++ b/deps/hunchentoot/CHANGELOG_TBNL @@ -0,0 +1,340 @@ +Version 0.11.3 +2006-09-30 +Added *FILE-UPLOAD-HOOK* (suggested by Erik Enge) +Fixed DEFINE-EASY-HANDLER for cases where URI is NIL + +Version 0.11.2 +2006-09-20 +DEFINE-EASY-HANDLER: fixed and clarified redefinition +DEFINE-EASY-HANDLER: allow for functions designators as "URIs" +DEFINE-EASY-HANDLER: take file uploads into account +Made logging a little bit more robust +Added mime type for XSL-FO (.fo) + +Version 0.11.1 +2006-09-14 +Cleaner implementation of *CATCH-ERRORS-P* + +Version 0.11.0 +2006-09-14 +Added *CATCH-ERRORS-P* + +Version 0.10.3 +2006-09-05 +Appease SBCL (thanks to Juho Snellman) + +Version 0.10.2 +2006-09-05 +Better reporting of IP addresses and ports if not behind mod_lisp +Improved logging +Fixed REAL-REMOTE-ADDR +Cookies always use UTF-8 encoding (which is opaque to the client anyway) +Read request bodies without 'Content-Length' header (for Hunchentoot) +Removed accented character from test.lisp to appease SBCL (reported by Xristos Kalkanis) + +Version 0.10.1 +2006-08-31 +Only LispWorks: Set read timeout to NIL if connected to mod_lisp + +Version 0.10.0 +2006-08-28 +Based LispWorks version of TBNL on Hunchentoot infrastructure +Added "easy" handlers +Exported GET-BACKTRACE (suggested by Erik Enge) + +Version 0.9.11 +2006-08-16 +Added note about SBCL problems + +Version 0.9.10 +2006-05-24 +Prepare for LW 5.0 release + +Version 0.9.9 +2006-05-12 +Workaround for something like "application/x-www-form-urlencoded;charset=UTF-8" (caught by John Bates) + +Version 0.9.8 +2006-04-25 +For mod_lisp, Lisp-Content-Length header must be sent after Content-Length header + +Version 0.9.7 +2006-02-06 +More robust computation of content length + +Version 0.9.6 +2006-01-22 +Added the missing piece (argh!) + +Version 0.9.5 +2006-01-22 +Made creation of REQUEST object safer (thanks to Robert J. Macomber) +Replaced some erroneous DECLAIMs with DECLAREs (thanks to SBCL's style warnings) +Slight documentation enhancements + +Version 0.9.4 +2006-01-03 +Handle "Expect: 100-continue" for non-Apache front-ends +Re-introduced IGNORE-ERRORS in GET-REQUEST-DATA + +Version 0.9.3 +2006-01-01 +Fixed bug in READ-HTTP-REQUEST + +Version 0.9.2 +2005-12-31 +Protocol of reply is HTTP/1.1 now +Made HTTP/0.9 default protocol of request if none was provided +Some preparations for Hunchentoot +Various minor changes +Small fixes in docs + +Version 0.9.1 +2005-12-25 +Added missing file mime-types.lisp (thanks to Hilverd Reker) + +Version 0.9.0 +2005-12-24 +Experimental support for writing directly to the front-end (see SEND-HEADERS) +Added HANDLE-STATIC-FILE +Changed CREATE-STATIC-FILE-DISPATCHER-AND-HANDLER to use new facilities +Added CREATE-FOLDER-DISPATCHER-AND-HANDLER +Added link to Travis Cross' message w.r.t. SBCL + +Version 0.8.9 +2005-12-16 +Also use :TBNL-BIVALENT-STREAMS if :SB-UNICODE is present + +Version 0.8.8 +2005-12-08 +Made RAW-POST-DATA more useful +Updated docs w.r.t. Araneida (thanks to Alan Shields) + +Version 0.8.7 +2005-11-29 +Made "Content-Length" header SETFable + +Version 0.8.6 +2005-11-18 +Restored original stream-based code for multipart/form-data parsing (got lost somehow) +Wrapped REMOTE-ADDR with IGNORE-ERRORS (just in case) + +Version 0.8.5 +2005-11-14 +Added generic function DISPATCH-REQUEST (thanks to Jeff Caldwell) + +Version 0.8.4 +2005-10-21 +Provide REMOTE-ADDR if connected directly (for LispWorks and AllegroCL) +Show remote user and address (if available) in non-Apache logs +Mention Debian package in docs + +Version 0.8.3 +2005-10-10 +Alert LW users that a patch for OCTETS-TO-STRINGS is available (thanks to LispWorks support) + +Version 0.8.2 +2005-10-06 +Make STRING-TO-OCTETS and OCTETS-TO-STRING safer for LW + +Version 0.8.1 +2005-09-29 +Bugfix in CMUCL version of STRING-TO-OCTETS + +Version 0.8.0 +2005-09-24 +Added the ability to cope with different external formats (incorporating suggestions from Will Glozer and Ivan Shvedunov) +Raw post data is now always saved (so *SAVE-RAW-POST-DATA-P* is gone) + +Version 0.7.0 +2005-09-17 +Added the ability to store arbitrary data within REQUEST objects (suggested by Zach Beane) +Fixed handling of *HTTP-ERROR-HANDLER* +Note: *TBNL-VERSION* was wrong in 0.6.0 and 0.6.1 + +Version 0.6.1 +2005-09-10 +Robustified socket handling code + +Version 0.6.0 +2005-09-08 +Added TBNL-CONTRIB package +Added contrib directory with first entry (from Alceste Scalas) +Updated link to Bill Clementson's blog +Don't redefine what's already there (for LispWorks) + +Version 0.5.5 +2005-04-18 +Make RFC 2388 code an external dependency (thanks to Janis Dzerins) + +Version 0.5.4 +2005-04-03 +Fixed dumb typo (caught by Bob Hutchison) + +Version 0.5.3 +2005-04-03 +Re-introduced automatic front-end selection (originally by Bob Hutchison) + +Version 0.5.2 +2005-03-26 +Fixed bug in modlisp.html where *CLOSE-TBNL-STREAM* could be NIL although it should be T +Set correct content type for 304 replies + +Version 0.5.1 +2005-03-17 +Changed default cookie path in START-SESSION (suggested by Stefan Scholl) +Small bugfixes +More headers from the Araneida front-end +Added *SHOW-ACCESS-LOG-MESSAGES* +Changed "back-end" to "front-end" :) + +Version 0.5.0 +2005-03-17 +Initial support for "stand-alone" version (no front-end) (supplied by Bob Hutchison) +New logging API +Fixes in START-TBNL/STOP-TBNL +Documentation enhancements + +Version 0.4.1 +2005-03-15 +Fixed some typos, removed unused code + +Version 0.4.0 +2005-03-14 +Initial Araneida support (supplied by Bob Hutchison) + +Version 0.3.13 +2005-03-12 +Small bugfix in RFC-1123-DATE (thanks to Bob Hutchison and Stefan Scholl) + +Version 0.3.12 +2005-03-01 +Added *HTTP-ERROR-HANDLER* (suggested and coded by Stefan Scholl) +Exported and documented *SESSION-MAX-TIME* + +Version 0.3.11 +2005-02-21 +Added ability to access raw post data (suggested and coded by Zach Beane) + +Version 0.3.10 +2005-01-24 +Make bivalent streams work with LispWorks 4.4 +UTF-8 demo for LispWorks (thanks to Bob Hutchison) + +Version 0.3.9 +2004-12-31 +Re-compute content length after applying MAYBE-REWRITE-URLS-FOR-SESSION (caught by Stefan Scholl) + +Version 0.3.8 +2004-12-27 +Don't send body for HEAD requests (needs current mod_lisp version) + +Version 0.3.7 +2004-12-22 +Change #\Del to #\Rubout in QUOTE-STRING (AllegroCL complains, #\Del isn't even semi-standard) + +Version 0.3.6 +2004-12-02 +Make REQUIRE-AUTHORIZATION compliant to RFC 2616 (thanks to Stefan Scholl) + +Version 0.3.5 +2004-12-01 +Several small doc fixes (thanks to Stefan Scholl) +Catch requests like "GET http://server/foo.html HTTP/1.0" (suggested by Stefan Scholl) + +Version 0.3.4 +2004-11-29 +Added backtrace code for OpenMCL (provided by Tiarnán Ó Corráin) + +Version 0.3.3 +2004-11-22 +Cleaner handling of macro variables + +Version 0.3.2 +2004-11-11 +Updated docs for mod_lisp2 + +Version 0.3.1 +2004-11-09 +Slight changes to support Chris Hanson's mod_lisp2 +Changed GET-BACKTRACE for newer SBCL versions (thanks to Nikodemus Siivola) + +Version 0.3.0 +2004-11-09 +Initial support for multipart/form-data (thanks to Michael Weber and Janis Dzerins) +Fixed bug in CREATE-STATIC-FILE-DISPATCHER-AND-HANDLER (caught by Bill Clementson) + +Version 0.2.12 +2004-10-15 +Exported and documented DO-SESSIONS + +Version 0.2.11 +2004-09-02 +FORM-URL-ENCODED-LIST-TO-ALIST now decodes names and values + +Version 0.2.10 +2004-08-28 +Allow non-strings to be cookie values (bug caught by Zach Beane) + +Version 0.2.9 +2004-08-11 +Consistent usage of RFC-1123-DATE (provided by Stefan Scholl) +Added all missing http headers from RFC 2616 (provided by Stefan Scholl) +Added support for mod_lisp version strings (see ) +Don't always add session IDs when redirecting + +Version 0.2.8 +2004-07-24 +Fixed typo in html.lisp and improved docs (both caught by Stefan Scholl) + +Version 0.2.7 +2004-07-24 +Add missing exports and docs + +Version 0.2.6 +2004-07-24 +Make CREATE-STATIC-FILE-DISPATCHER-AND-HANDLER thread-safe (caught by Jeff Caldwell) +Added support for 'If-Modified-Since' request headers (provided by Stefan Scholl) + +Version 0.2.5 +2004-07-21 +Added CREATE-STATIC-FILE-DISPATCHER-AND-HANDLER (provided by Stefan Scholl) +Improved test suite + +Version 0.2.4 +2004-07-19 +New variable *CONTENT-TYPES-FOR-URL-REWRITE* (suggested by Stefan Scholl) +Updated index.html regarding new version of mod_lisp + +Version 0.2.3 +2004-06-12 +Bugfix for FORM-URL-ENCODED-LIST-TO-ALIST (bug caught by Jong-won Choi) + +Version 0.2.2 +2004-06-10 +Bugfix for SESSION-GC and RESET-SESSIONS (bug introduced in 0.2.0) + +Version 0.2.1 +2004-06-10 +Only create backtrace if needed (speeds up AllegroCL considerably) + +Version 0.2.0 +2004-06-07 +Added SESSION-STRING and *SESSION-REMOVAL-HOOK* +Added GET-BACKTRACE for AllegroCL + +Version 0.1.2 +2004-05-12 +Removed some more typos in docs (thanks to Karl A. Krueger) +Changed BASE64 to CL-BASE64 in .asd file (thanks to Frank Sonnemans and Nicolas Lamirault) + +Version 0.1.1 +2004-05-08 +Removed some old files from Jeff's port +Fixed a couple of typos in docs + +Version 0.1.0 +2004-05-07 +First public release +Original code by Edi Weitz +Initial doc strings, port to KMRCL, logging code and various other improvements by Jeff Caldwell diff --git a/deps/hunchentoot/README b/deps/hunchentoot/README new file mode 100644 index 0000000..5d03367 --- /dev/null +++ b/deps/hunchentoot/README @@ -0,0 +1,4 @@ +Complete documentation for Hunchentoot including details about how to +install it can be found in the 'doc' directory. + +Join the chat at https://gitter.im/edicl/hunchentoot diff --git a/deps/hunchentoot/acceptor.lisp b/deps/hunchentoot/acceptor.lisp new file mode 100644 index 0000000..5d90b8a --- /dev/null +++ b/deps/hunchentoot/acceptor.lisp @@ -0,0 +1,789 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- + +;;; 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 :hunchentoot) + +(eval-when (:load-toplevel :compile-toplevel :execute) + (defun default-document-directory (&optional sub-directory) + (let ((source-directory #.(or *compile-file-truename* *load-truename*))) + (merge-pathnames (make-pathname :directory (append (pathname-directory source-directory) + (list "www") + (when sub-directory + (list sub-directory))) + :name nil + :type nil + :defaults source-directory))))) + +(defclass acceptor () + ((port :initarg :port + :reader acceptor-port + :documentation "The port the acceptor is listening on. The +default is 80. Note that depending on your operating system you might +need special privileges to listen on port 80. When 0, the port will be +chosen by the system the first time the acceptor is started.") + (address :initarg :address + :reader acceptor-address + :documentation "The address the acceptor is listening on. +If address is a string denoting an IP address, then the server only +receives connections for that address. This must be one of the +addresses associated with the machine and allowed values are host +names such as \"www.zappa.com\" and address strings such as +\"72.3.247.29\". If address is NIL, then the server will receive +connections to all IP addresses on the machine. This is the default.") + (name :initarg :name + :accessor acceptor-name + :documentation "The optional name of the acceptor, a symbol. +This name can be utilized when defining \"easy handlers\" - see +DEFINE-EASY-HANDLER. The default name is an uninterned symbol as +returned by GENSYM.") + (request-class :initarg :request-class + :accessor acceptor-request-class + :documentation "Determines which class of request +objects is created when a request comes in and should be \(a symbol +naming) a class which inherits from REQUEST. The default is the +symbol REQUEST.") + (reply-class :initarg :reply-class + :accessor acceptor-reply-class + :documentation "Determines which class of reply +objects is created when a request is served in and should be \(a +symbol naming) a class which inherits from REPLY. The default is the +symbol REPLY.") + (taskmaster :initarg :taskmaster + :reader acceptor-taskmaster + :documentation "The taskmaster \(i.e. an instance of a +subclass of TASKMASTER) that is responsible for scheduling the work +for this acceptor. The default depends on the MP capabilities of the +underlying Lisp.") + (output-chunking-p :initarg :output-chunking-p + :accessor acceptor-output-chunking-p + :documentation "A generalized boolean denoting +whether the acceptor may use chunked encoding for output, i.e. when +sending data to the client. The default is T and there's usually no +reason to change this to NIL.") + (input-chunking-p :initarg :input-chunking-p + :accessor acceptor-input-chunking-p + :documentation "A generalized boolean denoting +whether the acceptor may use chunked encoding for input, i.e. when +accepting request bodies from the client. The default is T and +there's usually no reason to change this to NIL.") + (persistent-connections-p :initarg :persistent-connections-p + :accessor acceptor-persistent-connections-p + :documentation "A generalized boolean +denoting whether the acceptor supports persistent connections, which +is the default for threaded acceptors. If this property is NIL, +Hunchentoot closes each incoming connection after having processed one +request. This is the default for non-threaded acceptors.") + (read-timeout :initarg :read-timeout + :reader acceptor-read-timeout + :documentation "The read timeout of the acceptor, +specified in \(fractional) seconds. The precise semantics of this +parameter is determined by the underlying Lisp's implementation of +socket timeouts. NIL means no timeout.") + (write-timeout :initarg :write-timeout + :reader acceptor-write-timeout + :documentation "The write timeout of the acceptor, +specified in \(fractional) seconds. The precise semantics of this +parameter is determined by the underlying Lisp's implementation of +socket timeouts. NIL means no timeout.") + #+:lispworks + (process :accessor acceptor-process + :documentation "The Lisp process which accepts incoming +requests. This is the process started by COMM:START-UP-SERVER and no +matter what kind of taskmaster you are using this will always be a new +process different from the one where START was called.") + #-:lispworks + (listen-socket :initform nil + :accessor acceptor-listen-socket + :documentation "The socket listening for incoming +connections.") + #-:lispworks + (listen-backlog :initarg :listen-backlog + :reader acceptor-listen-backlog + :documentation "Number of pending connections + allowed in the listen socket before the kernel rejects + further incoming connections.") + (acceptor-shutdown-p :initform t + :accessor acceptor-shutdown-p + :documentation "A flag that makes the acceptor +shutdown itself when set to something other than NIL.") + (requests-in-progress :initform 0 + :accessor accessor-requests-in-progress + :documentation "The number of +requests currently in progress.") + (shutdown-queue :initform (make-condition-variable) + :accessor acceptor-shutdown-queue + :documentation "A condition variable +used with soft shutdown, signaled when all requests +have been processed.") + (shutdown-lock :initform (make-lock "hunchentoot-acceptor-shutdown") + :accessor acceptor-shutdown-lock + :documentation "The lock protecting the shutdown-queue +condition variable and the requests-in-progress counter.") + (access-log-destination :initarg :access-log-destination + :accessor acceptor-access-log-destination + :documentation "Destination of the access log +which contains one log entry per request handled in a format similar +to Apache's access.log. Can be set to a pathname or string +designating the log file, to a open output stream or to NIL to +suppress logging.") + (message-log-destination :initarg :message-log-destination + :accessor acceptor-message-log-destination + :documentation "Destination of the server +error log which is used to log informational, warning and error +messages in a free-text format intended for human inspection. Can be +set to a pathname or string designating the log file, to a open output +stream or to NIL to suppress logging.") + (error-template-directory :initarg :error-template-directory + :accessor acceptor-error-template-directory + :documentation "Directory pathname that + contains error message template files for server-generated error + messages. Files must be named .html with + representing the HTTP return code that the file applies to, + i.e. 404.html would be used as the content for a HTTP 404 Not found + response.") + (document-root :initarg :document-root + :accessor acceptor-document-root + :documentation "Directory pathname that points to +files that are served by the acceptor if no more specific +acceptor-dispatch-request method handles the request.")) + (:default-initargs + :address nil + :port 80 + :name (gensym) + :request-class 'request + :reply-class 'reply + #-lispworks :listen-backlog #-lispworks 50 + :taskmaster (make-instance (cond (*supports-threads-p* 'one-thread-per-connection-taskmaster) + (t 'single-threaded-taskmaster))) + :output-chunking-p t + :input-chunking-p t + :persistent-connections-p t + :read-timeout *default-connection-timeout* + :write-timeout *default-connection-timeout* + :access-log-destination *error-output* + :message-log-destination *error-output* + :document-root (load-time-value (default-document-directory)) + :error-template-directory (load-time-value (default-document-directory "errors"))) + (:documentation "To create a Hunchentoot webserver, you make an +instance of this class and use the generic function START to start it +\(and STOP to stop it). Use the :PORT initarg if you don't want to +listen on the default http port 80. There are other initargs most of +which you probably won't need very often. They are explained in +detail in the docstrings of the slot definitions for this class. + +Unless you are in a Lisp without MP capabilities, you can have several +active instances of ACCEPTOR \(listening on different ports) at the +same time.")) + +(defmethod print-object ((acceptor acceptor) stream) + (print-unreadable-object (acceptor stream :type t) + (format stream "\(host ~A, port ~A)" + (or (acceptor-address acceptor) "*") (acceptor-port acceptor)))) + +(defmethod initialize-instance :after ((acceptor acceptor) &key) + (with-accessors ((document-root acceptor-document-root) + (persistent-connections-p acceptor-persistent-connections-p) + (taskmaster acceptor-taskmaster) + (error-template-directory acceptor-error-template-directory)) acceptor + (when (typep taskmaster + 'single-threaded-taskmaster) + (setf persistent-connections-p nil)) + (when document-root + (setf document-root (translate-logical-pathname document-root))) + (when error-template-directory + (setf error-template-directory (translate-logical-pathname error-template-directory))))) + +(defgeneric start (acceptor) + (:documentation "Starts the ACCEPTOR so that it begins accepting +connections. Returns the acceptor.")) + +(defgeneric stop (acceptor &key soft) + (:documentation "Stops the ACCEPTOR so that it no longer accepts +requests. If SOFT is true, and there are any requests in progress, +wait until all requests are fully processed, but meanwhile do not +accept new requests. Note that SOFT must not be set when calling +STOP from within a request handler, as that will deadlock.")) + +(defgeneric started-p (acceptor) + (:documentation "Tells if ACCEPTOR has been started. +The default implementation simply queries ACCEPTOR for its listening +status, so if T is returned to the calling thread, then some thread +has called START or some thread's call to STOP hasn't finished. If NIL +is returned either some thread has called STOP, or some thread's call +to START hasn't finished or START was never called at all for +ACCEPTOR.") + (:method (acceptor) + #-lispworks (and (acceptor-listen-socket acceptor) t) + #+lispworks (not (acceptor-shutdown-p acceptor)))) + +(defgeneric start-listening (acceptor) + (:documentation "Sets up a listen socket for the given ACCEPTOR and +enables it to listen to incoming connections. This function is called +from the thread that starts the acceptor initially and may return +errors resulting from the listening operation \(like 'address in use' +or similar).")) + +(defgeneric accept-connections (acceptor) + (:documentation "In a loop, accepts a connection and hands it over +to the acceptor's taskmaster for processing using +HANDLE-INCOMING-CONNECTION. On LispWorks, this function returns +immediately, on other Lisps it retusn only once the acceptor has been +stopped.")) + +(defgeneric initialize-connection-stream (acceptor stream) + (:documentation "Can be used to modify the stream which is used to +communicate between client and server before the request is read. The +default method of ACCEPTOR does nothing, but see for example the +method defined for SSL-ACCEPTOR. All methods of this generic function +must return the stream to use.")) + +(defgeneric reset-connection-stream (acceptor stream) + (:documentation "Resets the stream which is used to communicate +between client and server after one request has been served so that it +can be used to process the next request. This generic function is +called after a request has been processed and must return the +stream.")) + +(defgeneric process-connection (acceptor socket) + (:documentation "This function is called by the taskmaster when a +new client connection has been established. Its arguments are the +ACCEPTOR object and a LispWorks socket handle or a usocket socket +stream object in SOCKET. It reads the request headers, sets up the +request and reply objects, and hands over to PROCESS-REQUEST. This is +done in a loop until the stream has to be closed or until a connection +timeout occurs. + +It is probably not a good idea to re-implement this method until you +really, really know what you're doing.")) + +(defgeneric handle-request (acceptor request) + (:documentation "This function is called once the request has been +read and a REQUEST object has been created. Its job is to set up +standard error handling and request logging. + +Might be a good place for around methods specialized for your subclass +of ACCEPTOR which bind or rebind special variables which can then be +accessed by your handlers.")) + +(defgeneric acceptor-dispatch-request (acceptor request) + (:documentation "This function is called to actually dispatch the +request once the standard logging and error handling has been set up. +ACCEPTOR subclasses implement methods for this function in order to +perform their own request routing. If a method does not want to +handle the request, it is supposed to invoke CALL-NEXT-METHOD so that +the next ACCEPTOR in the inheritance chain gets a chance to handle the +request.")) + +(defgeneric acceptor-ssl-p (acceptor) + (:documentation "Returns a true value if ACCEPTOR uses SSL +connections. The default is to unconditionally return NIL and +subclasses of ACCEPTOR must specialize this method to signal that +they're using secure connections - see the SSL-ACCEPTOR class.")) + +;; general implementation + +(defmethod start ((acceptor acceptor)) + (setf (acceptor-shutdown-p acceptor) nil) + (let ((taskmaster (acceptor-taskmaster acceptor))) + (setf (taskmaster-acceptor taskmaster) acceptor) + (start-listening acceptor) + (execute-acceptor taskmaster)) + acceptor) + +(defmethod stop ((acceptor acceptor) &key soft) + (with-lock-held ((acceptor-shutdown-lock acceptor)) + (setf (acceptor-shutdown-p acceptor) t)) + #-lispworks + (wake-acceptor-for-shutdown acceptor) + (when soft + (with-lock-held ((acceptor-shutdown-lock acceptor)) + (when (plusp (accessor-requests-in-progress acceptor)) + (condition-variable-wait (acceptor-shutdown-queue acceptor) + (acceptor-shutdown-lock acceptor))))) + (shutdown (acceptor-taskmaster acceptor)) + #-lispworks + (usocket:socket-close (acceptor-listen-socket acceptor)) + #-lispworks + (setf (acceptor-listen-socket acceptor) nil) + #+lispworks + (mp:process-kill (acceptor-process acceptor)) + acceptor) + +#-lispworks +(defun wake-acceptor-for-shutdown (acceptor) + "Creates a dummy connection to the acceptor, waking ACCEPT-CONNECTIONS while it is waiting. +This is supposed to force a check of ACCEPTOR-SHUTDOWN-P." + (handler-case + (multiple-value-bind (address port) (usocket:get-local-name (acceptor-listen-socket acceptor)) + (let ((conn (usocket:socket-connect address port))) + (usocket:socket-close conn))) + (error (e) + (acceptor-log-message acceptor :error "Wake-for-shutdown connect failed: ~A" e)))) + +(defmethod initialize-connection-stream ((acceptor acceptor) stream) + ;; default method does nothing + stream) + +(defmethod reset-connection-stream ((acceptor acceptor) stream) + ;; turn chunking off at this point + (cond ((typep stream 'chunked-stream) + ;; flush the stream first and check if there's unread input + ;; which would be an error + (setf (chunked-stream-output-chunking-p stream) nil + (chunked-stream-input-chunking-p stream) nil) + ;; switch back to bare socket stream + (chunked-stream-stream stream)) + (t stream))) + +(defmethod process-connection :around ((*acceptor* acceptor) (socket t)) + ;; this around method is used for error handling + ;; note that this method also binds *ACCEPTOR* + (with-conditions-caught-and-logged () + (with-mapped-conditions () + (call-next-method)))) + +(defun do-with-acceptor-request-count-incremented (*acceptor* function) + (with-lock-held ((acceptor-shutdown-lock *acceptor*)) + (incf (accessor-requests-in-progress *acceptor*))) + (unwind-protect + (funcall function) + (with-lock-held ((acceptor-shutdown-lock *acceptor*)) + (decf (accessor-requests-in-progress *acceptor*)) + (when (acceptor-shutdown-p *acceptor*) + (condition-variable-signal (acceptor-shutdown-queue *acceptor*)))))) + +(defmacro with-acceptor-request-count-incremented ((acceptor) &body body) + "Execute BODY with ACCEPTOR-REQUESTS-IN-PROGRESS of ACCEPTOR + incremented by one. If the ACCEPTOR-SHUTDOWN-P returns true after + the BODY has been executed, the ACCEPTOR-SHUTDOWN-QUEUE condition + variable of the ACCEPTOR is signalled in order to finish shutdown + processing." + `(do-with-acceptor-request-count-incremented ,acceptor (lambda () ,@body))) + +(defun acceptor-make-request (acceptor socket + &key + headers-in + content-stream + method + uri + server-protocol) + "Make a REQUEST instance for the ACCEPTOR, setting up those slots + that are determined from the SOCKET by calling the appropriate + socket query functions." + (multiple-value-bind (remote-addr remote-port) + (get-peer-address-and-port socket) + (multiple-value-bind (local-addr local-port) + (get-local-address-and-port socket) + (make-instance (acceptor-request-class acceptor) + :acceptor acceptor + :local-addr local-addr + :local-port local-port + :remote-addr remote-addr + :remote-port remote-port + :headers-in headers-in + :content-stream content-stream + :method method + :uri uri + :server-protocol server-protocol)))) + +(defgeneric detach-socket (acceptor) + (:documentation "Indicate to Hunchentoot that it should stop serving + requests on the current request's socket. + Hunchentoot will finish processing the current + request and then return from PROCESS-CONNECTION + without closing the connection to the client. + DETACH-SOCKET can only be called from within a + request handler function.")) + +(defmethod detach-socket ((acceptor acceptor)) + (setf *finish-processing-socket* t + *close-hunchentoot-stream* nil)) + +(defmethod process-connection ((*acceptor* acceptor) (socket t)) + (let* ((socket-stream (make-socket-stream socket *acceptor*)) + (*hunchentoot-stream*) + (*close-hunchentoot-stream* t)) + (unwind-protect + ;; process requests until either the acceptor is shut down, + ;; *CLOSE-HUNCHENTOOT-STREAM* has been set to T by the + ;; handler, or the peer fails to send a request + (progn + (setq *hunchentoot-stream* (initialize-connection-stream *acceptor* socket-stream)) + (loop + (let ((*finish-processing-socket* t)) + (when (acceptor-shutdown-p *acceptor*) + (return)) + (multiple-value-bind (headers-in method url-string protocol) + (get-request-data *hunchentoot-stream*) + ;; check if there was a request at all + (unless method + (return)) + ;; bind per-request special variables, then process the + ;; request - note that *ACCEPTOR* was bound above already + (let ((*reply* (make-instance (acceptor-reply-class *acceptor*))) + (*session* nil) + (transfer-encodings (cdr (assoc* :transfer-encoding headers-in)))) + (when transfer-encodings + (setq transfer-encodings + (split "\\s*,\\s*" transfer-encodings)) + (when (member "chunked" transfer-encodings :test #'equalp) + (cond ((acceptor-input-chunking-p *acceptor*) + ;; turn chunking on before we read the request body + (setf *hunchentoot-stream* (make-chunked-stream *hunchentoot-stream*) + (chunked-stream-input-chunking-p *hunchentoot-stream*) t)) + (t (hunchentoot-error "Client tried to use ~ +chunked encoding, but acceptor is configured to not use it."))))) + (with-acceptor-request-count-incremented (*acceptor*) + (process-request (acceptor-make-request *acceptor* socket + :headers-in headers-in + :content-stream *hunchentoot-stream* + :method method + :uri url-string + :server-protocol protocol)))) + (finish-output *hunchentoot-stream*) + (setq *hunchentoot-stream* (reset-connection-stream *acceptor* *hunchentoot-stream*)) + (when *finish-processing-socket* + (return)))))) + (when *close-hunchentoot-stream* + (flet ((close-stream (stream) + ;; as we are at the end of the request here, we ignore all + ;; errors that may occur while flushing and/or closing the + ;; stream. + (ignore-errors* + (finish-output stream)) + (ignore-errors* + (close stream :abort t)))) + (unless (or (not *hunchentoot-stream*) + (eql socket-stream *hunchentoot-stream*)) + (close-stream *hunchentoot-stream*)) + (close-stream socket-stream)))))) + +(defmethod acceptor-ssl-p ((acceptor t)) + ;; the default is to always answer "no" + nil) + +(defgeneric acceptor-log-access (acceptor &key return-code) + (:documentation + "Function to call to log access to the acceptor. The RETURN-CODE, +CONTENT and CONTENT-LENGTH keyword arguments contain additional +information about the request to log. In addition, it can use the +standard request accessor functions that are available to handler +functions to find out more information about the request.")) + +(defmethod acceptor-log-access ((acceptor acceptor) &key return-code) + "Default method for access logging. It logs the information to the +destination determined by (ACCEPTOR-ACCESS-LOG-DESTINATION ACCEPTOR) +\(unless that value is NIL) in a format that can be parsed by most +Apache log analysis tools.)" + + (with-log-stream (stream (acceptor-access-log-destination acceptor) *access-log-lock*) + (format stream "~:[-~@[ (~A)~]~;~:*~A~@[ (~A)~]~] ~:[-~;~:*~A~] [~A] \"~A ~A~@[?~A~] ~ + ~A\" ~D ~:[-~;~:*~D~] \"~:[-~;~:*~A~]\" \"~:[-~;~:*~A~]\"~%" + (remote-addr*) + (header-in* :x-forwarded-for) + (authorization) + (iso-time) + (request-method*) + (script-name*) + (query-string*) + (server-protocol*) + return-code + (content-length*) + (referer) + (user-agent)))) + +(defgeneric acceptor-log-message (acceptor log-level format-string &rest format-arguments) + (:documentation + "Function to call to log messages by the ACCEPTOR. It must accept +a severity level for the message, which will be one of :ERROR, :INFO, +or :WARNING, a format string and an arbitary number of formatting +arguments.")) + +(defmethod acceptor-log-message ((acceptor acceptor) log-level format-string &rest format-arguments) + "Default function to log server messages. Sends a formatted message + to the destination denoted by (ACCEPTOR-MESSAGE-LOG-DESTINATION + ACCEPTOR). FORMAT and ARGS are as in FORMAT. LOG-LEVEL is a + keyword denoting the log level or NIL in which case it is ignored." + (with-log-stream (stream (acceptor-message-log-destination acceptor) *message-log-lock*) + (handler-case + (format stream "[~A~@[ [~A]~]] ~?~%" + (iso-time) log-level + format-string format-arguments) + (error (e) + (ignore-errors + (format *trace-output* "error ~A while writing to error log, error not logged~%" e)))))) + +(defun log-message* (log-level format-string &rest format-arguments) + "Convenience function which calls the message logger of the current +acceptor \(if there is one) with the same arguments it accepts. + +This is the function which Hunchentoot itself uses to log errors it +catches during request processing." + (apply 'acceptor-log-message *acceptor* log-level format-string format-arguments)) + +;; usocket implementation + +#-:lispworks +(defmethod start-listening ((acceptor acceptor)) + (when (acceptor-listen-socket acceptor) + (hunchentoot-error "acceptor ~A is already listening" acceptor)) + (setf (acceptor-listen-socket acceptor) + (usocket:socket-listen (or (acceptor-address acceptor) + usocket:*wildcard-host*) + (acceptor-port acceptor) + :reuseaddress t + :backlog (acceptor-listen-backlog acceptor) + :element-type '(unsigned-byte 8))) + (values)) + +#-:lispworks +(defmethod start-listening :after ((acceptor acceptor)) + (when (zerop (acceptor-port acceptor)) + (setf (slot-value acceptor 'port) (usocket:get-local-port (acceptor-listen-socket acceptor))))) + +#-:lispworks +(defmethod accept-connections ((acceptor acceptor)) + (usocket:with-server-socket (listener (acceptor-listen-socket acceptor)) + (loop + (with-lock-held ((acceptor-shutdown-lock acceptor)) + (when (acceptor-shutdown-p acceptor) + (return))) + (when (usocket:wait-for-input listener :ready-only t) + (when-let (client-connection + (handler-case (usocket:socket-accept listener) + ;; ignore condition + (usocket:connection-aborted-error ()))) + (set-timeouts client-connection + (acceptor-read-timeout acceptor) + (acceptor-write-timeout acceptor)) + (handle-incoming-connection (acceptor-taskmaster acceptor) + client-connection)))))) + +;; LispWorks implementation + +#+:lispworks +(defmethod start-listening ((acceptor acceptor)) + (multiple-value-bind (listener-process startup-condition) + (comm:start-up-server :service (acceptor-port acceptor) + :address (acceptor-address acceptor) + :process-name (format nil "Hunchentoot listener \(~A:~A)" + (or (acceptor-address acceptor) "*") + (acceptor-port acceptor)) + ;; this function is called once on startup - we + ;; use it to check for errors and random port + :announce (lambda (socket &optional condition) + (when condition + (error condition)) + (when (or (null (acceptor-port acceptor)) + (zerop (acceptor-port acceptor))) + (multiple-value-bind (address port) + (comm:get-socket-address socket) + (declare (ignore address)) + (setf (slot-value acceptor 'port) port)))) + ;; this function is called whenever a connection + ;; is made + :function (lambda (handle) + (unless (acceptor-shutdown-p acceptor) + (handle-incoming-connection + (acceptor-taskmaster acceptor) handle))) + ;; wait until the acceptor was successfully started + ;; or an error condition is returned + :wait t) + (when startup-condition + (error startup-condition)) + (mp:process-stop listener-process) + (setf (acceptor-process acceptor) listener-process) + (values))) + +#+:lispworks +(defmethod accept-connections ((acceptor acceptor)) + (mp:process-unstop (acceptor-process acceptor)) + nil) + +(defmethod acceptor-dispatch-request ((acceptor acceptor) request) + "Detault implementation of the request dispatch method, generates an ++http-not-found+ error." + (let ((path (and (acceptor-document-root acceptor) + (request-pathname request)))) + (cond + (path + (handle-static-file + (merge-pathnames (if (equal "/" (script-name request)) #p"index.html" path) + (acceptor-document-root acceptor)))) + (t + (setf (return-code *reply*) +http-not-found+) + (abort-request-handler))))) + +(defmethod handle-request ((*acceptor* acceptor) (*request* request)) + "Standard method for request handling. Calls the request dispatcher +of *ACCEPTOR* to determine how the request should be handled. Also +sets up standard error handling which catches any errors within the +handler." + (handler-bind ((error + (lambda (cond) + ;; if the headers were already sent, the error + ;; happened within the body and we have to close + ;; the stream + (when *headers-sent* + (setq *finish-processing-socket* t)) + (throw 'handler-done + (values nil cond (get-backtrace)))))) + (with-debugger + (acceptor-dispatch-request *acceptor* *request*)))) + +(defgeneric acceptor-status-message (acceptor http-status-code &key &allow-other-keys) + (:documentation + "This function is called after the request's handler has been + invoked to convert the HTTP-STATUS-CODE to a HTML message to be + displayed to the user. If this function returns a string, that + string is sent to the client instead of the content produced by the + handler, if any. + + If an ERROR-TEMPLATE-DIRECTORY is set in the current acceptor and + the directory contains a file corresponding to HTTP-STATUS-CODE + named .html, that file is sent to the client after variable + substitution. Variables are referenced by ${}. + + Additional keyword arguments may be provided which are made + available to the templating logic as substitution variables. These + variables can be interpolated into error message templates in, + which contains the current URL relative to the server and without + GET parameters. + + In addition to the variables corresponding to keyword arguments, + the script-name, lisp-implementation-type, + lisp-implementation-version and hunchentoot-version variables are + available.")) + +(defun make-cooked-message (http-status-code &key error backtrace) + (labels ((cooked-message (format &rest arguments) + (setf (content-type*) "text/html; charset=iso-8859-1") + (format nil "~D ~A

~:*~A

~?

~A

" + http-status-code (reason-phrase http-status-code) + format (mapcar (lambda (arg) + (if (stringp arg) + (escape-for-html arg) + arg)) + arguments) + (address-string)))) + (case http-status-code + ((#.+http-moved-temporarily+ + #.+http-moved-permanently+) + (cooked-message "The document has moved here" (header-out :location))) + ((#.+http-authorization-required+) + (cooked-message "The server could not verify that you are authorized to access the document requested. ~ + Either you supplied the wrong credentials \(e.g., bad password), or your browser doesn't ~ + understand how to supply the credentials required.")) + ((#.+http-forbidden+) + (cooked-message "You don't have permission to access ~A on this server." + (script-name *request*))) + ((#.+http-not-found+) + (cooked-message "The requested URL ~A was not found on this server." + (script-name *request*))) + ((#.+http-bad-request+) + (cooked-message "Your browser sent a request that this server could not understand.")) + ((#.+http-internal-server-error+) + (if *show-lisp-errors-p* + (cooked-message "
~A~@[~%~%Backtrace:~%~%~A~]
" + (escape-for-html (princ-to-string error)) + (when *show-lisp-backtraces-p* + (escape-for-html (princ-to-string backtrace)))) + (cooked-message "An error has occurred"))) + (t + (when (<= 400 http-status-code) + (cooked-message "An error has occurred")))))) + +(defmethod acceptor-status-message ((acceptor t) http-status-code &rest args &key &allow-other-keys) + (apply 'make-cooked-message http-status-code args)) + +(defmethod acceptor-status-message :around ((acceptor acceptor) http-status-code &rest args &key &allow-other-keys) + (handler-case + (call-next-method) + (error (e) + (log-message* :error "error ~A during error processing, sending cooked message to client" e) + (apply 'make-cooked-message http-status-code args)))) + +(defun string-as-keyword (string) + "Intern STRING as keyword using the reader so that case conversion is done with the reader defaults." + (let ((*package* (find-package :keyword))) + (read-from-string string))) + +(defmethod acceptor-status-message ((acceptor acceptor) http-status-code &rest properties &key &allow-other-keys) + "Default function to generate error message sent to the client." + (labels + ((substitute-request-context-variables (string) + (let ((properties (append `(:script-name ,(script-name*) + :lisp-implementation-type ,(lisp-implementation-type) + :lisp-implementation-version ,(lisp-implementation-version) + :hunchentoot-version ,*hunchentoot-version*) + properties))) + (unless *show-lisp-backtraces-p* + (setf (getf properties :backtrace) nil)) + (cl-ppcre:regex-replace-all "(?i)\\$\\{([a-z0-9-_]+)\\}" + string + (lambda (target-string start end match-start match-end reg-starts reg-ends) + (declare (ignore start end match-start match-end)) + (let ((variable-name (string-as-keyword (subseq target-string + (aref reg-starts 0) + (aref reg-ends 0))))) + (escape-for-html (princ-to-string (getf properties variable-name variable-name)))))))) + (file-contents (file) + (let ((buf (make-string (file-length file)))) + (read-sequence buf file) + buf)) + (error-contents-from-template () + (let ((error-file-template-pathname (and (acceptor-error-template-directory acceptor) + (probe-file (make-pathname :name (princ-to-string http-status-code) + :type "html" + :defaults (acceptor-error-template-directory acceptor)))))) + (when error-file-template-pathname + (with-open-file (file error-file-template-pathname :if-does-not-exist nil :element-type 'character) + (when file + (setf (content-type*) "text/html") + (substitute-request-context-variables (file-contents file)))))))) + (or (unless (< 300 http-status-code) + (call-next-method)) ; don't ever try template for positive return codes + (when *show-lisp-errors-p* + (error-contents-from-template)) ; try template + (call-next-method)))) ; fall back to cooked message + +(defgeneric acceptor-remove-session (acceptor session) + (:documentation + "This function is called whenever a session in ACCEPTOR is being + destroyed because of a session timout or an explicit REMOVE-SESSION + call.")) + +(defmethod acceptor-remove-session ((acceptor acceptor) (session t)) + "Default implementation for the session removal hook function. This +function is called whenever a session is destroyed." + nil) + +(defgeneric acceptor-server-name (acceptor) + (:documentation "Returns a string which can be used for 'Server' headers.") + (:method ((acceptor acceptor)) + (format nil "Hunchentoot ~A" *hunchentoot-version*))) diff --git a/deps/hunchentoot/compat.lisp b/deps/hunchentoot/compat.lisp new file mode 100644 index 0000000..79376fa --- /dev/null +++ b/deps/hunchentoot/compat.lisp @@ -0,0 +1,136 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*- + +;;; 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 :hunchentoot) + +(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))) + +(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 + ;; by Vebjorn Ljosa - see also + ;; + `(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)) + +(defmacro with-rebinding (bindings &body body) + "Syntax: 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 + ;; by Vebjorn Ljosa - see also + ;; + (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 get-peer-address-and-port (socket) + "Returns the peer address and port of the socket SOCKET as two +values. The address is returned as a string in dotted IP address +notation." + (multiple-value-bind (address port) (usocket:get-peer-name socket) + (values (ecase (length address) + (4 (usocket:vector-quad-to-dotted-quad address)) + #+(or) (16 (usocket:vector-to-ipv6-host address))) + port))) + +(defun get-local-address-and-port (socket) + "Returns the local address and port of the socket SOCKET as two +values. The address is returned as a string in dotted IP address +notation." + (multiple-value-bind (address port) (usocket:get-local-name socket) + (values (ecase (length address) + (4 (usocket:vector-quad-to-dotted-quad address)) + #+(or) (16 (usocket:vector-to-ipv6-host address))) + port))) + +(defun make-socket-stream (socket acceptor) + "Returns a stream for the socket SOCKET. The ACCEPTOR argument is +ignored." + (declare (ignore acceptor)) + (usocket:socket-stream socket)) + +(defun make-lock (name) + "Simple wrapper to allow LispWorks and Bordeaux Threads to coexist." + (bt:make-lock name)) + +(defmacro with-lock-held ((lock) &body body) + "Simple wrapper to allow LispWorks and Bordeaux Threads to coexist." + `(bt:with-lock-held (,lock) ,@body)) + +(defun make-condition-variable (&key name) + (declare (ignore name)) + (bt:make-condition-variable)) + +(defun condition-variable-signal (condition-variable) + (bt:condition-notify condition-variable)) + +(defun condition-variable-wait (condition-variable lock) + (bt:condition-wait condition-variable lock)) diff --git a/deps/hunchentoot/conditions.lisp b/deps/hunchentoot/conditions.lisp new file mode 100644 index 0000000..1147e24 --- /dev/null +++ b/deps/hunchentoot/conditions.lisp @@ -0,0 +1,133 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*- + +;;; Copyright (c) 2008-2009, 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 :hunchentoot) + +(define-condition hunchentoot-condition (condition) + () + (:documentation "Superclass for all conditions related to Hunchentoot.")) + +(define-condition hunchentoot-error (hunchentoot-condition error) + () + (:documentation "Superclass for all errors related to Hunchentoot.")) + +(define-condition hunchentoot-simple-error (hunchentoot-error simple-condition) + () + (:documentation "Like HUNCHENTOOT-ERROR but with formatting capabilities.")) + +(defun hunchentoot-error (format-control &rest format-arguments) + "Signals an error of type HUNCHENTOOT-SIMPLE-ERROR with the provided +format control and arguments." + (error 'hunchentoot-simple-error + :format-control format-control + :format-arguments format-arguments)) + +(define-condition hunchentoot-warning (hunchentoot-condition warning) + () + (:documentation "Superclass for all warnings related to Hunchentoot.")) + +(define-condition hunchentoot-simple-warning (hunchentoot-warning simple-condition) + () + (:documentation "Like HUNCHENTOOT-WARNING but with formatting capabilities.")) + +(defun hunchentoot-warn (format-control &rest format-arguments) + "Signals a warning of type HUNCHENTOOT-SIMPLE-WARNING with the +provided format control and arguments." + (warn 'hunchentoot-simple-warning + :format-control format-control + :format-arguments format-arguments)) + +(define-condition parameter-error (hunchentoot-simple-error) + () + (:documentation "Signalled if a function was called with incosistent or illegal parameters.")) + +(defun parameter-error (format-control &rest format-arguments) + "Signals an error of type PARAMETER-ERROR with the provided +format control and arguments." + (error 'parameter-error + :format-control format-control + :format-arguments format-arguments)) + +(define-condition operation-not-implemented (hunchentoot-error) + ((operation :initarg :operation + :reader hunchentoot-operation-not-implemented-operation + :documentation "The name of the unimplemented operation.")) + (:report (lambda (condition stream) + (format stream "The operation ~A is not yet implemented for the implementation ~A. +Consider sending a patch..." + (hunchentoot-operation-not-implemented-operation condition) + (lisp-implementation-type)))) + (:documentation "This warning is signalled when an operation \(like +SETUID for example) is not implemented for a specific Lisp.")) + +(defun not-implemented (name) + "Used to signal an error if an operation named NAME is not implemented." + (error 'operation-not-implemented :operation name)) + +(define-condition bad-request (hunchentoot-error) + ()) + +;;; + +(defgeneric maybe-invoke-debugger (condition) + (:documentation "This generic function is called whenever a +condition CONDITION is signaled in Hunchentoot. You might want to +specialize it on specific condition classes for debugging purposes.") + (:method (condition) + "The default method invokes the debugger with CONDITION if +*CATCH-ERRORS-P* is NIL." + (unless *catch-errors-p* + (invoke-debugger condition)))) + +(defmacro with-debugger (&body body) + "Executes BODY and invokes the debugger if an error is signaled and +*CATCH-ERRORS-P* is NIL." + `(handler-bind ((bad-request (lambda (c) + (declare (ignore c)) + (setf (return-code *reply*) +http-bad-request+) + (abort-request-handler))) + (error #'maybe-invoke-debugger)) + ,@body)) + +(defmacro ignore-errors* (&body body) + "Like IGNORE-ERRORS, but observes *CATCH-ERRORS-P*." + `(ignore-errors (with-debugger ,@body))) + +(defmacro handler-case* (expression &rest clauses) + "Like HANDLER-CASE, but observes *CATCH-ERRORS-P*." + `(handler-case (with-debugger ,expression) + ,@clauses)) + +(defun get-backtrace () + "Returns a string with a backtrace of what the Lisp system thinks is +the \"current\" error." + (handler-case + (with-output-to-string (s) + (trivial-backtrace:print-backtrace-to-stream s)) + (error (condition) + (format nil "Could not generate backtrace: ~A." condition)))) diff --git a/deps/hunchentoot/cookie.lisp b/deps/hunchentoot/cookie.lisp new file mode 100644 index 0000000..9315316 --- /dev/null +++ b/deps/hunchentoot/cookie.lisp @@ -0,0 +1,127 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*- + +;;; 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 :hunchentoot) + +(defclass cookie () + ((name :initarg :name + :reader cookie-name + :type string + :documentation "The name of the cookie - a string.") + (value :initarg :value + :accessor cookie-value + :initform "" + :documentation "The value of the cookie. Will be URL-encoded +when sent to the browser.") + (expires :initarg :expires + :initform nil + :accessor cookie-expires + :documentation "The time \(a universal time) when the +cookie expires \(or NIL).") + (max-age :initarg :max-age + :initform nil + :accessor cookie-max-age + :documentation "The time delta \(in seconds) after which the +cookie expires \(or NIL).") + (path :initarg :path + :initform nil + :accessor cookie-path + :documentation "The path this cookie is valid for \(or NIL).") + (domain :initarg :domain + :initform nil + :accessor cookie-domain + :documentation "The domain this cookie is valid for \(or NIL).") + (secure :initarg :secure + :initform nil + :accessor cookie-secure + :documentation "A generalized boolean denoting whether this +cookie is a secure cookie.") + (http-only :initarg :http-only + :initform nil + :accessor cookie-http-only + :documentation "A generalized boolean denoting whether +this cookie is a `HttpOnly' cookie. + +This is a Microsoft extension that has been implemented in Firefox as +well. See .")) + (:documentation "Each COOKIE objects describes one outgoing cookie.")) + +(defmethod initialize-instance :around ((cookie cookie) &rest init-args) + "Ensure COOKIE has a correct slot-value for NAME." + (let ((name (getf init-args :name))) + (unless (http-token-p name) + (parameter-error "~S is not a legal name for a cookie." name))) + (call-next-method)) + +(defun set-cookie* (cookie &optional (reply *reply*)) + "Adds the COOKIE object COOKIE to the outgoing cookies of the +REPLY object REPLY. If a cookie with the same name +\(case-sensitive) already exists, it is replaced." + (let* ((name (cookie-name cookie)) + (place (assoc name (cookies-out reply) :test #'string=))) + (cond + (place + (setf (cdr place) cookie)) + (t + (push (cons name cookie) (cookies-out reply)) + cookie)))) + +(defun set-cookie (name &key (value "") expires max-age path domain secure http-only (reply *reply*)) + "Creates a cookie object from the parameters provided and adds +it to the outgoing cookies of the REPLY object REPLY. If a cookie +with the name NAME \(case-sensitive) already exists, it is +replaced." + (set-cookie* (make-instance 'cookie + :name name + :value value + :expires expires + :max-age max-age + :path path + :domain domain + :secure secure + :http-only http-only) + reply)) + +(defun cookie-date (universal-time) + "Converts UNIVERSAL-TIME to cookie date format." + (and universal-time + (rfc-1123-date universal-time))) + +(defmethod stringify-cookie ((cookie cookie)) + "Converts the COOKIE object COOKIE to a string suitable for a +'Set-Cookie' header to be sent to the client." + (format nil + "~A=~A~@[; Expires=~A~]~@[; Max-Age=~A~]~@[; Domain=~A~]~@[; Path=~A~]~:[~;; Secure~]~:[~;; HttpOnly~]" + (cookie-name cookie) + (cookie-value cookie) + (cookie-date (cookie-expires cookie)) + (cookie-max-age cookie) + (cookie-domain cookie) + (cookie-path cookie) + (cookie-secure cookie) + (cookie-http-only cookie))) diff --git a/deps/hunchentoot/doc/LICENSE.txt b/deps/hunchentoot/doc/LICENSE.txt new file mode 100644 index 0000000..37c6051 --- /dev/null +++ b/deps/hunchentoot/doc/LICENSE.txt @@ -0,0 +1,9 @@ +The Hunchentoot logo (the file `hunchentoot.gif' in this directory) +was created by Uwe von Loh and is available from his website at + + http://www.htg1.de/hunchentoot/hunchentoot.html + +It is licensed under a `Creative Commons Attribution-Share Alike 2.0 +Germany License', see + + http://creativecommons.org/licenses/by-sa/2.0/de/ diff --git a/deps/hunchentoot/doc/Makefile b/deps/hunchentoot/doc/Makefile new file mode 100644 index 0000000..336129b --- /dev/null +++ b/deps/hunchentoot/doc/Makefile @@ -0,0 +1,3 @@ + +all: + xsltproc --stringparam library-version `perl -ne 'print "$$1\n" if (/:version "(.*)"/)' ../hunchentoot.asd` clixdoc.xsl index.xml > ../www/hunchentoot-doc.html diff --git a/deps/hunchentoot/doc/clixdoc.xsl b/deps/hunchentoot/doc/clixdoc.xsl new file mode 100644 index 0000000..3718550 --- /dev/null +++ b/deps/hunchentoot/doc/clixdoc.xsl @@ -0,0 +1,466 @@ + + + + + + + + + + + + + + + <xsl:value-of select="clix:title"/> + + + + + + + + + + + + + + + + + +

+ + + + + + + [] +
+ + + + + => + + + + +

+ +
+

+ + + +

+ + [] +
+ + + + + => + + +

+ +
+

+ + + + + + + + + => + + +
+ + + +

+ + [] +
+ (setf ( + + ) new-value) + + => + + +

+ +
+

+ + + +

+ + [] +
+ + + + => + +
+ (setf ( + + ) new-value) +

+ +
+

+ + + + + + + + => + +
+ (setf ( + + ) new-value) +
+ + + +

+ + [] +
+ +

+ +
+

+ + + + +
+ + + + +

+ [Constants]
+ +

+ +
+

+ + + + +

+ []
+ +

+ +
+

+ + + + +

+ []
+ +

+ +
+

+ + + + + + + + + + & + + + + + + + + + + + + + + +

+ + + + +

+ + + + +

+ + + + +

+ + + + +
    + +
  1. + + # + + + +
      + +
    1. + + # + + +
      2. +       +
    +     +
    2. +     +
+ + + +
    + + +
  • + + + + + + + + + + + + + + +
      + + +
    • + + + + + +
      • +       +
    +     +     +
    • +     +
+ + + + + + + + + + + + + + + + + # + + + + + + + + + + + + + + + + + + + + - + + + + + + + + + + + + + + + + + + + + + Generic function + Method + Macro + Function + + + + + Generic reader + Specialized reader + Reader + + + + + Generic reader + Specialized reader + Reader + + + + + Generic readers + Specialized readers + Readers + + + + + Generic accessors + Specialized accessors + Accessors + + + + + Generic writer + Specialized writer + Writer + + + + + Generic accessor + Specialized accessor + Accessor + + + + + Generic accessor + Specialized accessor + Accessor + + + Special variable + Standard class + Condition type + Symbol + Constant + Constant + + + + + + + diff --git a/deps/hunchentoot/doc/hunchentoot.gif b/deps/hunchentoot/doc/hunchentoot.gif new file mode 100644 index 0000000000000000000000000000000000000000..695743513650be4203d797d5e198811554959157 GIT binary patch literal 490 zcmV_CX>@2HRA^-& zM@dakAYyqSRd;0|c5iMVOmAoaA^8LW00062EC2ui09^nr00091l#i*)?Jt0wu-c39 z+#vhUa9zY1;uNF-1-9M^$AGFz?%lxjwxhL_01OayI>AxAZm?SZKJ#0>U$hcj$N+r?|!V zSoz2YD0pVcdC8T@*D2~4snIlw>PblSC6@XcIM;d#TPsuQu()Z<+m;xD2;( z6D(W|2PfJCOj}FbEY0~7J@-l-99oI3rrbN;_jh1Mp1w8|E=bO;X?@L(;5!aqWo)UG zAg-RTZxp|C@xIMtc1;c)bl(C3QMU*TJrdpw?eYQ9m9CU14D;M_s4-orPb9|ZSO?N% zp_H+xA)|OvWuBPw6t1zu2+9$6VEWMHi4tVWoU3-mtT-sBLqB(f{xo{@A|;+8 zvR+Mpnyj{|+Q@4`b6P8QHRe(xOR#ExEvN}LPTXTm$3mDiHD}YL8 + + + + Hunchentoot - The Common Lisp web server formerly known as TBNL + + A full-featured web server written in Common Lisp offering things + like HTTP/1.1 chunking, persistent connections, and SSL. Includes + a framework for building dynamic websites interactively. + + +

+ + + + Hunchentoot - The Common Lisp web server formerly known as TBNL +

+ +
+ +

+ Hunchentoot is a web server written in Common Lisp and at the + same time a toolkit for building dynamic websites. As a + stand-alone web server, Hunchentoot is capable of HTTP/1.1 + chunking (both directions), persistent connections + (keep-alive), and SSL. +

+

+ Hunchentoot provides facilities like automatic session + handling (with and without cookies), logging, customizable + error handling, and easy access to GET and POST parameters + sent by the client. It does not include functionality + to programmatically generate HTML output. For this task you + can use any library you like, e.g. (shameless self-plug) + CL-WHO or + HTML-TEMPLATE. +

+

+ Hunchentoot talks with its front-end or with the client over + TCP/IP sockets and optionally uses multiprocessing to handle + several requests at the same time. Therefore, it cannot be + implemented completely in portable + Common Lisp. It currently works with LispWorks and all Lisps + which are supported by the compatibility layers usocket and + Bordeaux + Threads. +

+

+ Hunchentoot comes with a + BSD-style + license so you can basically do with it whatever you want. +

+

+ Hunchentoot is (or was) for example used by + QuickHoney, + City Farming, + Heike Stephan. +

+

+ Download shortcut: + http://weitz.de/files/hunchentoot.tar.gz. +

+ +
+ + + + + + Hunchentoot depends on a couple of other Lisp libraries which you'll need + to install first: + + + Make sure to use the newest versions of all of these + libraries (which might themselves depend on other libraries) - try + the repository versions if you're in doubt. Note: You can compile + Hunchentoot without SSL support - and thus without the need to + have CL+SSL - if you add :HUNCHENTOOT-NO-SSL to + + *FEATURES* before you compile it. +

+ Hunchentoot will only work with Lisps where + the character + codes of + all Latin-1 + characters coincide with their + Unicode code + points (which is the case for all current implementations I + know). +

+

+ Hunchentoot itself together with this documentation can be + downloaded from + http://weitz.de/files/hunchentoot.tar.gz. + The current version is . +

+

+ The preferred method to compile and load Hunchentoot is via ASDF. If you want to avoid + downloading and installing all the dependencies manually, give + Zach Beane's excellent Quicklisp system a try. +

+

+ Hunchentoot and its dependencies can also be installed with clbuild. + There's also a port for Gentoo + Linux thanks to Matthew Kennedy. +

+

+ The current development version of Hunchentoot can be found + at https://github.com/edicl/hunchentoot. + If you want to send patches, please fork the github repository and send pull requests. +

+ + + + Hunchentoot does not come with code to help with running it on a + privileged port (i.e. port 80 or 443) on Unix-like operating + systems. Modern Unix-like systems have specific, non-portable + ways to allow non-root users to listen to privileged ports, so + including such functionality in Hunchentoot was considered + unnecessary. Please refer to online resources for help. At the + time of this writing, the YAWS documentation has a comprehensive + writeup on the topic. + + + + + If you're feeling unsecure about exposing Hunchentoot to the wild, + wild Internet or if your Lisp web application is part of a larger + website, you can hide it behind a + proxy server. + One approach that I have used several times is to employ Apache's + mod_proxy + module with a configuration that looks like this: + +
ProxyPass /hunchentoot http://127.0.0.1:3000/hunchentoot
+ProxyPassReverse /hunchentoot http://127.0.0.1:3000/hunchentoot
+ + This will tunnel all requests where the URI path begins with + "/hunchentoot" to a (Hunchentoot) server listening on + port 3000 on the same machine. + +

+ Of course, there are + several + other (more lightweight) web proxies that you could use + instead of Apache. +

+ + + + +

+ The development version of Hunchentoot can be found on + github. Please use the github issue tracking system to + submit bug reports. Patches are welcome, please use GitHub pull + requests. If you want to make a change, please read this + first. +

+ + + + Starting your own web server is pretty easy. Do something like this: +
(hunchentoot:start (make-instance 'hunchentoot:easy-acceptor :port 4242))
+ That's it. Now you should be able to enter the address + "http://127.0.0.1:4242/" in + your browser and see something, albeit nothing very interesting + for now. + +

+ By default, Hunchentoot serves the files from the + www/ directory in its source tree. In the + distribution, that directory contains a HTML version of the + documentation as well as the error templates. The location of + the document root directory can be specified when creating a new + ACCEPTOR instance by the way of the + ACCEPTOR-DOCUMENT-ROOT. Likewise, the + location of the error template directory can be specified by the + ACCEPTOR-ERROR-TEMPLATE-DIRECTORY. Both + ACCEPTOR-DOCUMENT-ROOT and + ACCEPTOR-ERROR-TEMPLATE-DIRECTORY can be + specified using a logical pathname, which will be translated + once when the ACCEPTOR is instantiated. +

+ +

+ The EASY-ACCEPTOR class implements a + framework for developing web applications. Handlers are defined + using the DEFINE-EASY-HANDLER macro. + Request dispatching is performed according to the list of + dispatch functions in *DISPATCH-TABLE*. + Each of the functions on that list is called to determine + whether it wants to handle the request, provided as single + argument. If a dispatcher function wants to handle the request, + it returns another function to actually create the desired page. +

+ +

+ DEFINE-EASY-HANDLER is accompanied by a set + of dispatcher creation functions that can be used to create + dispatchers for standard tasks. These are documented in the subchapter on easy + handlers +

+ +

+ Now be a bit more adventurous, try this +

(hunchentoot:define-easy-handler (say-yo :uri "/yo") (name)
+  (setf (hunchentoot:content-type*) "text/plain")
+  (format nil "Hey~@[ ~A~]!" name))
+ and see what happens at "http://127.0.0.1:4242/yo" or + "http://127.0.0.1:4242/yo?name=Dude" . +

+ +

+ Hunchentoot comes with a little example website which you can use + to see if it works and which should also demonstrate a couple of + the things you can do with Hunchentoot. To start the example + website, enter the following code into your listener: + +

(asdf:oos 'asdf:load-op :hunchentoot-test)
+ + Now go to "http://127.0.0.1:4242/hunchentoot/test" and play a bit. +

+ + + +

+ Adam Petersen has written a book called "Lisp for + the Web" which explains how Hunchentoot and some other + libraries can be used to build web sites. +

+

+ Here is some software which extends Hunchentoot or is based on it: +

+
    +
  • + Weblocks by + Slava Akhmechet is a "continuations-based web framework" which + is based on Hunchentoot. +
    • +
  • + hunchentoot-cgi + (by Cyrus Harmon) provides + CGI + handlers for Hunchentoot. +
    • +
  • + CL-WEBDAV is a WebDAV + server based on Hunchentoot. +
    • +
  • + RESTAS is a web + framework based on Hunchentoot. +
    • +
+ + + + + + + If you want Hunchentoot to actually do something, you have to create and + start an acceptor. + You can also run several acceptors in one image, each one + listening on a different different port. + + + + To create a Hunchentoot webserver, you make an instance of + this class or one of its subclasses and use the generic + function START to start it (and + STOP to stop it). Use the + :port initarg if you don't want to listen + on the default http port 80. If 0 is specified for the + port, the system chooses a random port to listen on. The + port number choosen can be retrieved using the + ACCEPTOR-PORT accessor. The port + number chosen is retained across stopping and starting the + acceptor. +

+ There are other initargs most of which you probably + won't need very often. They are explained in detail + in the docstrings of the slot definitions. +

+

+ Unless you are in a Lisp without MP capabilities, you can + have several active instances of + ACCEPTOR (listening on different + ports) at the same time. +

+ + + + + Create and START an instance of this class + (instead of ACCEPTOR) if you want an https server. There are two + required initargs, :SSL-CERTIFICATE-FILE and :SSL-PRIVATEKEY-FILE, for + pathname designators denoting the certificate file and the key file in + PEM format. On LispWorks, you can have both in one file in which case + the second initarg is optional. You can also use the + :SSL-PRIVATEKEY-PASSWORD initarg to provide a password + (as a string) for the key file (or NIL, the default, for + no password). +

+ The default port for SSL-ACCEPTOR instances is 443 instead of 80 +

+ + + + + acceptor + + acceptor + + Starts acceptor so that it begins accepting + connections. Returns the acceptor. + + + + + acceptor &key soft + acceptor + + Stops the acceptor so + that it no longer accepts requests. If + soft is true, and there are any requests + in progress, wait until all requests are fully processed, but + meanwhile do not accept new requests. Note that + soft must not be set when calling + stop from within a request handler, as + that will deadlock. + + + + + The current ACCEPTOR object in the context of a request. + + + + + listen-backlog + + number-of-pending-connections + + + Number of pending connections allowed in the listen socket + before the kernel rejects further incoming connections. + Non-LispWorks only. + + + + + + acceptor + + address + + + + + acceptor + + port + + + + + acceptor + + read-timeout + + + + + ssl-acceptor + + ssl-certificate-file + + + + + ssl-acceptor + + ssl-privatekey-file + + + + + ssl-acceptor + + ssl-privatekey-password + + + + + acceptor + + write-timeout + + + + + These are readers for various slots of ACCEPTOR + objects (and some of them obviously only make sense + for SSL-ACCEPTOR objects). See the docstrings of + these slots for more information and note that there are corresponding + initargs for all of them. + + + + + + acceptor + + (or pathname null) + + + + + acceptor + + (or pathname null) + + + + + acceptor + + (or pathname null) + + + + + acceptor + + input-chunking-p + + + + + acceptor + + (or pathname null) + + + + + acceptor + + name + + + + + acceptor + + output-chunking-p + + + + + acceptor + + persistent-connections-p + + + + + acceptor + + reply-class + + + + + acceptor + + request-class + + + + + These are accessors for various slots of ACCEPTOR + objects. See the docstrings of these slots for more information and + note that there are corresponding initargs for all of them. + + + + + acceptor + + generalized-boolean + + Returns a true value if acceptor uses SSL + connections. The default is to unconditionally return NIL and + subclasses of ACCEPTOR must specialize this method to signal that + they're using secure connections - see the SSL-ACCEPTOR class. + + + + + The default connection timeout used when an + acceptor is reading from and writing to a socket stream. Note that + some Lisps allow you to set different timeouts for reading and writing + and you can specify both values via initargs when you create + an acceptor. + + + + + acceptor session + + | + + + This function is called whenever a session in + ACCEPTOR is being destroyed because of + a session timout or an explicit + REMOVE-SESSION call. + + + + + + + + If you want to modify what acceptors do, you should subclass + ACCEPTOR (or SSL-ACCEPTOR) and + specialize the generic functions that constitute their behaviour (see + example below). The life of an acceptor looks like this: It is started + with the function START which immediately calls + START-LISTENING and then applies the function + EXECUTE-ACCEPTOR to its taskmaster. This function will eventually call + ACCEPT-CONNECTIONS which is responsible for setting + things up to wait for clients to connect. For each incoming connection + which comes in, HANDLE-INCOMING-CONNECTION is applied + to the taskmaster which will either call + PROCESS-CONNECTION directly, or will create a thread + to call it. PROCESS-CONNECTION calls + INITIALIZE-CONNECTION-STREAM before it does anything + else, then it selects and calls a function which handles the request, and finally it sends the reply to the client before it calls + RESET-CONNECTION-STREAM. If the connection is + persistent, this procedure is repeated (except for the intialization step) + in a loop until the connection is closed. The acceptor is stopped with + STOP. + +

+ If you just want to use the standard acceptors that come with + Hunchentoot, you don't need to know anything about the functions + listed in this section. +

+ + + acceptor + + | + + Sets up a listen socket for the given acceptor and + enables it to listen to incoming connections. This function is called + from the thread that starts the acceptor initially and may return + errors resulting from the listening operation (like 'address in use' + or similar). + + + + + acceptor + + nil + + In a loop, accepts a connection and hands it over + to the acceptor's taskmaster for processing using + HANDLE-INCOMING-CONNECTION. On LispWorks, this + function returns immediately, on other Lisps it returns only once the + acceptor has been stopped. + + + + + acceptor socket + + nil + + + This function is called by the taskmaster when a new client + connection has been established. Its arguments are the + ACCEPTOR object and a LispWorks socket + handle or a usocket socket stream object in + socket. It reads the request headers, + sets up the request and reply objects, and hands over to + PROCESS-REQUEST which calls + HANDLE-REQUEST to select and call a + handler for the request and sends its reply to the client. + This is done in a loop until the stream has to be closed or + until a connection timeout occurs. It is probably not a + good idea to re-implement this method until you really, + really know what you're doing. +

+ Handlers may call to the + DETACH-SOCKET generic function to + indicate that no further requests should be handled on + the connection by Hunchentoot, and that responsibility for + the socket is assumed by third-party software. This can + be used by specialized handlers that wish to hand over + connection polling or processing to functions outside of + Hunchentoot, i.e. for connection multiplexing or + implementing specialized client protocols. Hunchentoot + will finish processing the request and the + PROCESS-CONNECTION function will + return without closing the connection. At that point, + the acceptor may interact with the socket in whatever + fashion required. +

+ + + + + acceptor + + stream + + + Indicate to Hunchentoot that it should stop serving requests + on the current request's socket. Hunchentoot will finish + processing the current request and then return from + PROCESS-CONNECTION without closing the + connection to the client. + DETACH-SOCKET can only be called from + within a request handler function. + + + + + acceptor stream + + stream + + + Can be used to modify the stream which is used to + communicate between client and server before the request is + read. The default method of ACCEPTOR + does nothing, but see for example the method defined for + SSL-ACCEPTOR. All methods of this + generic function must return the stream to use. + + + + + acceptor stream + + stream + + + Resets the stream which is used to communicate + between client and server after one request has been served so that it + can be used to process the next request. This generic function is + called after a request has been processed and must return the + stream. + + + + + acceptor &key return-code + + Function to call to log access to the acceptor. The + return-code keyword argument contains additional + information about the request to log. In addition, it can use the + standard request and reply accessor functions that are available to + handler functions to find out more information about the request. + + + + + acceptor log-level format-string &rest format-arguments + + Function to call to log messages by the acceptor. It must accept + a severity level for the message, which will be one of :ERROR, :INFO, + or :WARNING, a format string and an arbitary number of formatting + arguments. + + + + + acceptor http-return-code &key &allow-other-keys + + This function is called when a request's handler has been + called but failed to provide content to send back to the + client. It converts the + HTTP-STATUS-CODE to some request + contents, typically a human readable description of the + status code to be displayed to the user. + + If an ERROR-TEMPLATE-DIRECTORY is set in the current + acceptor and the directory contains a file corresponding to + HTTP-STATUS-CODE named <code>.html, that file is sent + to the client after variable substitution. Variables are + referenced by ${<variable-name>}. + + Additional keyword arguments may be provided which are made + available to the templating logic as substitution variables. + These variables can be interpolated into error message + templates in, which contains the current URL relative to the + server and without GET parameters. + + In addition to the variables corresponding to keyword + arguments, the script-name, lisp-implementation-type, + lisp-implementation-version and hunchentoot-version + variables are available. + + + + + + + This example shows how to subclass ACCEPTOR in order to + provide Hunchentoot with basic virtual host support.  It assumes + Hunchentoot is sitting behind an Internet-facing reverse-proxy web server + that maps the host (or domain) part of incoming HTTP requests to unique + localhost ports. + + 
(asdf:load-system "hunchentoot")
+(asdf:load-system "drakma")
+
+;;; Subclass ACCEPTOR
+(defclass vhost (tbnl:acceptor)
+  ;; slots
+  ((dispatch-table
+    :initform '()
+    :accessor dispatch-table
+    :documentation "List of dispatch functions"))
+  ;; options
+  (:default-initargs                    ; default-initargs must be used
+   :address "127.0.0.1"))               ; because ACCEPTOR uses it
+
+;;; Specialise ACCEPTOR-DISPATCH-REQUEST for VHOSTs
+(defmethod tbnl:acceptor-dispatch-request ((vhost vhost) request)
+  ;; try REQUEST on each dispatcher in turn
+  (mapc (lambda (dispatcher)
+	  (let ((handler (funcall dispatcher request)))
+	    (when handler               ; Handler found. FUNCALL it and return result
+	      (return-from tbnl:acceptor-dispatch-request (funcall handler)))))
+	(dispatch-table vhost))
+  (call-next-method))
+
+;;; ======================================================================
+;;; Now all we need to do is test it
+
+;;; Instantiate VHOSTs
+(defvar vhost1 (make-instance 'vhost :port 50001))
+(defvar vhost2 (make-instance 'vhost :port 50002))
+
+;;; Populate each dispatch table
+(push
+ (tbnl:create-prefix-dispatcher "/foo" 'foo1)
+ (dispatch-table vhost1))
+(push
+ (tbnl:create-prefix-dispatcher "/foo" 'foo2)
+ (dispatch-table vhost2))
+
+;;; Define handlers
+(defun foo1 () "Hello")
+(defun foo2 () "Goodbye")
+
+;;; Start VHOSTs
+(tbnl:start vhost1)
+(tbnl:start vhost2)
+
+;;; Make some requests
+(drakma:http-request "http://127.0.0.1:50001/foo")
+;;; =|
+;;; 127.0.0.1 - [2012-06-08 14:30:39] "GET /foo HTTP/1.1" 200 5 "-" "Drakma/1.2.6 (SBCL 1.0.56; Linux; 2.6.32-5-686; http://weitz.de/drakma/)"
+;;; =>
+;;; "Hello"
+;;; 200
+;;; ((:CONTENT-LENGTH . "5") (:DATE . "Fri, 08 Jun 2012 14:30:39 GMT")
+;;;  (:SERVER . "Hunchentoot 1.2.3") (:CONNECTION . "Close")
+;;;  (:CONTENT-TYPE . "text/html; charset=utf-8"))
+;;; #<PURI:URI http://127.0.0.1:50001/foo>
+;;; #<FLEXI-STREAMS:FLEXI-IO-STREAM {CA90059}>
+;;; T
+;;; "OK"
+(drakma:http-request "http://127.0.0.1:50002/foo")
+;;; =|
+;;; 127.0.0.1 - [2012-06-08 14:30:47] "GET /foo HTTP/1.1" 200 7 "-" "Drakma/1.2.6 (SBCL 1.0.56; Linux; 2.6.32-5-686; http://weitz.de/drakma/)"
+;;; =>
+;;; "Goodbye"
+;;; 200
+;;; ((:CONTENT-LENGTH . "7") (:DATE . "Fri, 08 Jun 2012 14:30:47 GMT")
+;;;  (:SERVER . "Hunchentoot 1.2.3") (:CONNECTION . "Close")
+;;;  (:CONTENT-TYPE . "text/html; charset=utf-8"))
+;;; #<PURI:URI http://127.0.0.1:50002/foo>
+;;; #<FLEXI-STREAMS:FLEXI-IO-STREAM {CAE8059}>
+;;; T
+;;; "OK"
+ + How to make each VHOST write to separate access log streams (or files) is + left as an exercise to the reader. + + + + + As a "normal" Hunchentoot user, you can completely ignore + taskmasters and skip this section. But if you're still reading, + here are the dirty details: Each acceptor has a taskmaster associated with + it at creation time. It is the taskmaster's job to distribute + the work of accepting and handling incoming connections. The + acceptor calls the taskmaster if appropriate and the taskmaster + calls back into the acceptor. This is done using the generic + functions described in this and the previous section. Hunchentoot + comes with two standard taskmaster implementations - one (which + is the default used on multi-threaded Lisps) which starts a new + thread for each incoming connection and one which handles all + requests sequentially. It should for example be relatively + straightforward to create a taskmaster which allocates threads + from a fixed pool instead of creating a new one for each + connection. + +

+ You can control the resources consumed by a threaded taskmaster via + two initargs. :max-thread-count lets you set the maximum + number of request threads that can be processes simultaneously. If + this is nil, the is no thread limit imposed. + + :max-accept-count lets you set the maximum number of requests + that can be outstanding (i.e. being processed or queued for processing). + + If :max-thread-count is supplied and :max-accept-count + is NIL, then a +HTTP-SERVICE-UNAVAILABLE+ + error will be generated if there are more than the max-thread-count + threads processing requests. If both :max-thread-count + and :max-accept-count are supplied, then max-thread-count + must be less than max-accept-count; if more than max-thread-count + requests are being processed, then requests up to max-accept-count + will be queued until a thread becomes available. If more than + max-accept-count requests are outstanding, then a +HTTP-SERVICE-UNAVAILABLE+ + error will be generated. + + In a load-balanced environment with multiple Hunchentoot servers, it's + reasonable to provide :max-thread-count but leave + :max-accept-count null. This will immediately result + in +HTTP-SERVICE-UNAVAILABLE+ when one server is + out of resources, so the load balancer can try to find another server. + + In an environment with a single Hunchentoot server, it's reasonable + to provide both :max-thread-count and a somewhat larger value + for :max-accept-count. This will cause a server that's almost + out of resources to wait a bit; if the server is completely out of resources, + then the reply will be +HTTP-SERVICE-UNAVAILABLE+. + The default for these values is 100 and 120, respectively. +

+ +

+ If you want to implement your own taskmasters, you should subclass + TASKMASTER or one of its subclasses, + SINGLE-THREADED-TASKMASTER or + ONE-THREAD-PER-CONNECTION-TASKMASTER, and + specialize the generic functions in this section. +

+ + + + An instance of this class is responsible for distributing + the work of handling requests for its acceptor. This is an + "abstract" class in the sense that usually only instances of + subclasses of TASKMASTER will be used. + + + + + + A taskmaster that starts one thread for listening to + incoming requests and one thread for each incoming + connection. +

+ This is the default taskmaster implementation for multi-threaded Lisp + implementations. +

+ + + + + + A taskmaster that runs synchronously in the + thread where the START function was invoked (or + in the case of LispWorks in the thread started + by COMM:START-UP-SERVER). + This is the simplest possible taskmaster implementation in that its + methods do nothing but calling their acceptor "sister" + methods - EXECUTE-ACCEPTOR calls ACCEPT-CONNECTIONS, + HANDLE-INCOMING-CONNECTION calls PROCESS-CONNECTION. + + + + + + This is an abstract class for taskmasters that use multiple threads; + it is not a concrete class and you should not instantiate it with + MAKE-INSTANCE. + Instead, you should instantiate its subclass + ONE-THREAD-PER-CONNECTION-TASKMASTER described above. + MULTI-THREADED-TASKMASTER + is intended to be inherited from by extensions to Hunchentoot, + such as quux-hunchentoot's + THREAD-POOLING-TASKMASTER, + though at the moment, doing so only inherits one slot and one method, + on EXECUTE-ACCEPTOR, + to have it start a new thread for the acceptor, + then saved in said slot. + + + + + taskmaster + + result + + This is a callback called by the acceptor once it + has performed all initial processing to start listening for incoming + connections (see START-LISTENING). It usually calls the + ACCEPT-CONNECTIONS method of the acceptor, but depending on the + taskmaster instance the method might be called from a new thread. + + + + + taskmaster socket + + result + + + This function is called by the acceptor to start + processing of requests on a new incoming connection. socket is the + usocket instance that represents the new connection (or a socket + handle on LispWorks). The taskmaster starts processing requests on + the incoming connection by calling the PROCESS-CONNECTION + method of the acceptor instance. The socket argument is passed to + PROCESS-CONNECTION as an argument. + + If the taskmaster is a multi-threaded taskmaster, HANDLE-INCOMING-THREAD + will call CREATE-REQUEST-HANDLER-THREAD, which will call + PROCESS-CONNECTION in a new thread. + HANDLE-INCOMING-THREAD might issue a + +HTTP-SERVICE-UNAVAILABLE+ error + if there are too many request threads or it might block waiting for a + request thread to finish. + + + + + taskmaster thunk &key + + thread + + This function is a callback that + starts a new thread that will call the given thunk + in the context of the proper taskmaster, + with appropriate context-dependent keyword arguments. + ONE-THREAD-PER-CONNECTION-TASKMASTER uses it in + EXECUTE-ACCEPTOR + and CREATE-REQUEST-HANDLER-THREAD, + but specialized taskmasters may define more functions that use it. + By default, it just creates a thread calling the thunk + with a specified name keyword argument. + Specialized taskmasters may wrap special bindings and condition handlers + around the thunk call, register the thread in a management table, etc. + + + + + taskmaster socket + + thread + + This function is called by HANDLE-INCOMING-THREAD + to create a new thread which calls PROCESS-CONNECTION. + If you specialize this function, you must be careful to have the thread + call DECREMENT-TASKMASTER-REQUEST-COUNT before + it exits. A typical method will look like this: + + 
(defmethod create-request-handler-thread ((taskmaster monitor-taskmaster) socket)
+  (bt:make-thread
+   (lambda ()
+     (with-monitor-error-handlers
+         (unwind-protect
+              (with-monitor-variable-bindings
+                  (process-connection (taskmaster-acceptor taskmaster) socket))
+           (decrement-taskmaster-request-count taskmaster))))))
+ + + + + + + + + + + + taskmaster + + taskmaster + + Shuts down the taskmaster, i.e. frees all resources + that were set up by it. For example, a multi-threaded taskmaster + might terminate all threads that are currently associated with it. + This function is called by the acceptor's STOP method. + + + + + taskmaster + + acceptor + + + This is an accessor for the slot of a TASKMASTER + object that links back to the acceptor it is + associated with. + + + + + + + + The main job of HANDLE-REQUEST is to select + and call a function which handles the request, i.e. which looks + at the data the client has sent and prepares an appropriate + reply to send back. This is by default implemented as follows: +

+ The ACCEPTOR class defines a + ACCEPTOR-DISPATCH-REQUEST generic + function which is used to actually dispatch the request. This + function is called by the default method of + HANDLE-REQUEST. Each + ACCEPTOR-DISPATCH-REQUEST method looks at + the request object and depending on its contents decides to + either handle the request or call the next method. +

+

+ In order to dispatch a request, Hunchentoot calls the + ACCEPTOR-DISPATCH-REQUEST generic + functions. The method for ACCEPTOR tries + to serve a static file relative to it's + ACCEPTOR-DOCUMENT-ROOT. Application + specific acceptor subclasses will typically perform URL + parsing and dispatching according to the policy that is + required. +

+

+ The default method of HANDLE-REQUEST sets + up standard logging and error handling + before it calls the acceptor's request dispatcher. +

+

+ Request handlers do their work by modifying + the reply object if necessary and by eventually + returning the response body in the form of a string or a binary + sequence. As an alternative, they can also + call SEND-HEADERS and write directly to a stream. +

+ + + +

+ The EASY-ACCEPTOR class defines a method + for ACCEPTOR-DISPATCH-REQUEST that walks + through the list *DISPATCH-TABLE* which + consists of dispatch functions. Each of these + functions accepts the request object as its only argument and + either returns a request handler to handle the request or + NIL which means that the next dispatcher in the + list will be tried. A request handler is a function + of zero arguments which relies on the special variable + *REQUEST* to access the request instance + being serviced. If all dispatch functions return + NIL, the next + ACCEPTOR-DISPATCH-REQUEST will be called. +

+

+ N.B. All functions and variables in this + section are related to the easy request dispatch mechanism and + are meaningless if you're using your own request dispatcher. +

+ + + + This class defines no additional slots with respect to + ACCEPTOR. It only serves as an + additional type for dispatching calls to + ACCEPTOR-DISPATCH-REQUEST. In order to + use the easy handler framework, acceptors of this class or + one of its subclasses must be used. + + + + + + This class mixes the SSL-ACCEPTOR and + the EASY-ACCEPTOR classes. It is used + when both ssl and the easy handler framework are required. + + + + + + A global list of dispatch functions. The initial value is a + list consisting of the symbol + DISPATCH-EASY-HANDLERS. + + + + + prefix handler + dispatch-fn + + A convenience function which will return a dispatcher that + returns handler whenever the path part of + the request URI starts with the + string prefix. + + + + + regex handler + dispatch-fn + + A convenience function which will return a dispatcher that + returns handler whenever the path part of + the request URI matches + the CL-PPCRE regular + expression regex (which can be a string, an + s-expression, or a scanner). + + + + + uri-prefix base-path optional content-type + dispatch-fn + + Creates and returns a dispatch function which will dispatch to + a handler function which emits the file relative + to base-path that is denoted by the URI of + the request relative + to uri-prefix. uri-prefix + must be a string ending with a + slash, base-path must be a pathname + designator for an existing directory. + Uses HANDLE-STATIC-FILE internally. +

+ If content-type is not + NIL, it will be used as a the content type for + all files in the folder. Otherwise (which is the default) + the content type of each file will be + determined as usual. +

+ + + + + uri path + optional + content-type + + result + + + Creates and returns a request dispatch function which will + dispatch to a handler function which emits the file denoted + by the pathname designator PATH with content type + CONTENT-TYPE if the SCRIPT-NAME of the request matches the + string URI. If CONTENT-TYPE is NIL, tries to determine the + content type via the file's suffix. + + + + + description lambda-list [[declaration* | documentation]] form* + + Defines a handler as if + by + DEFUN and optionally registers it with a + URI so that it will be found + by DISPATCH-EASY-HANDLERS. +

+ description is either a + symbol name or a list matching the + destructuring + lambda list +

+ 
(name &key uri acceptor-names default-parameter-type default-request-type).
+ lambda-list is a list the elements of which + are either a symbol var or a list matching + the destructuring lambda list + 
(var &key real-name parameter-type init-form request-type).
+ The resulting handler will be a Lisp function with the + name name and keyword parameters named by + the var symbols. + Each var will be bound to the value of the + GET or POST parameter called real-name (a + string) before the body of the function is executed. + If real-name is not provided, it will be + computed + by downcasing + the symbol name of var. +

+ If uri (which is evaluated) is provided, + then it must be a string or + a function + designator for a unary function. In this case, the + handler will be returned + by DISPATCH-EASY-HANDLERS, + if uri is a string and + the script name of the current + request is uri, or + if uri designates a function and applying + this function to + the current REQUEST + object returns a true value. +

+

+ acceptor-names (which is evaluated) can be a + list of symbols which means that the handler will only be + returned by DISPATCH-EASY-HANDLERS in + acceptors which have one of these names + (see ACCEPTOR-NAME). acceptor-names can also be the + symbol T which means that the handler will be + returned by DISPATCH-EASY-HANDLERS + in every acceptor. +

+

+ Whether the GET or POST parameter (or both) will be taken into + consideration, depends on request-type + which can + be :GET, :POST, :BOTH, + or NIL. In the last case, the value of + default-request-type (the default of which + is :BOTH) will be used. +

+

+ The value of var will usually be a string + (unless it resulted from a file upload + in which case it won't be converted at all), but + if parameter-type (which is evaluated) is + provided, the string will be converted to another Lisp type by + the following rules: +

+

+ If the corresponding GET or POST parameter wasn't provided by + the client, var's value will + be NIL. If parameter-type + is 'STRING, + var's value remains as is. + If parameter-type is 'INTEGER + and the parameter string consists solely of decimal + digits, var's value will be the + corresponding integer, otherwise NIL. + If parameter-type is + 'KEYWORD, var's value will be + the keyword obtained + by interning + the upcased + parameter string into + the keyword + package. If parameter-type + is 'CHARACTER and the parameter string is of + length one, var's value will be the single + character of this string, otherwise NIL. + If parameter-type + is 'BOOLEAN, var's value will + always be T (unless it is NIL by the + first rule above, of course). + If parameter-type is any other atom, it is + supposed to be + a function + designator for a unary function which will be called to + convert the string to something else. +

+

+ Those were the rules for simple parameter types, but + parameter-type can also be a list starting + with one of the symbols + LIST, ARRAY, + or HASH-TABLE. The second value of the list must + always be a simple parameter type as in the last paragraph - + we'll call it the inner type below. +

+

+ In the case of 'LIST, all GET/POST parameters + called real-name will be collected, + converted to the inner type as by the rules above, and + assembled into a list which will be the value of + var. +

+

+ In the case of 'ARRAY, all GET/POST parameters + which have a name like the result of +

+ 
(format nil "~A[~A]" real-name n)
+ where n is a non-negative integer, will be + assembled into an array where the nth element + will be set accordingly, after conversion to the inner type. + The array, which will become the value + of var, will be big enough to hold all + matching parameters, but not bigger. Array elements not set as + described above will be NIL. Note + that VAR will always be bound to an array, which + may be empty, so it will never be NIL, even if no + appropriate GET/POST parameters are found. +

+ The full form of a 'HASH-TABLE parameter type is +

+ 
(hash-table inner-type key-type test-function)
+ but key-type + and test-function can be left out in which + case they default to 'STRING + and 'EQUAL, respectively. For this parameter type, + all GET/POST parameters which have a name like the result of + 
(format nil "~A{~A}" real-name key)
+ (where key is a string that doesn't contain + curly brackets) will become the values (after conversion + to inner-type) of a hash table with test + function test-function + where key (after conversion + to key-type) will be the corresponding key. + Note that var will always be bound to a hash + table, which may be empty, so it will never be NIL, + even if no appropriate GET/POST parameters are found. +

+ To make matters even more complicated, the three compound + parameter types also have an abbreviated form - just one of + the symbols LIST, ARRAY, + or HASH-TABLE. In this case, the inner type will + default to 'STRING. +

+

+ If parameter-type is not provided + or NIL, default-parameter-type + (the default of which is 'STRING) will be used + instead. +

+

+ If the result of the computations above would be + that var would be bound + to NIL, then init-form (if + provided) will be evaluated instead, + and var will be bound to the result of this + evaluation. +

+

+ Handlers built with this macro are constructed in such a way + that the resulting Lisp function is useful even outside of + Hunchentoot. Specifically, all the parameter computations + above will only happen if *REQUEST* is + bound, i.e. if we're within a Hunchentoot request. + Otherwise, var will always be bound to the + result of evaluating init-form unless a + corresponding keyword argument is provided. +

+

+ The example code that comes with + Hunchentoot contains an example which demonstrates some of the + features of DEFINE-EASY-HANDLER. +

+ + + + + request + + result + + This is a dispatcher which returns the appropriate handler + defined with DEFINE-EASY-HANDLER, if there is one. + + + + + + + + For each incoming request, the acceptor (in + PROCESS-CONNECTION) creates a + REQUEST object and makes it available to handlers via the special variable + *REQUEST*. This object contains all relevant + information about the request and this section collects the functions + which can be used to query such an object. In all function where + request is an optional or keyword parameter, the + default is *REQUEST*. + +

+ If you need more fine-grained control over the behaviour of request + objects, you can subclass REQUEST and initialize + the REQUEST-CLASS + slot of the ACCEPTOR class accordingly. The + acceptor will generate request objects of the class named by this + slot. +

+ + + + Objects of this class hold all the information + about an incoming request. They are created automatically by + acceptors and can be accessed by the + corresponding handler. + + You should not mess with the slots of these objects directly, but you + can subclass REQUEST in order to implement your + own behaviour. See + the REQUEST-CLASS + slot of the ACCEPTOR class. + + + + + The current REQUEST object while in the context of a request. + + + + + + optional + request + + string{, list} + + + Returns the 'X-Forwarded-For' incoming http header as the + second value in the form of a list of IP addresses and the first + element of this list as the first value if this header exists. + Otherwise returns the value of REMOTE-ADDR as the only value. + + + + + name + optional + request + + string + + + Returns the GET or the POST parameter with name + name (a string) - or NIL + if there is none. If both a GET and a POST parameter with + the same name exist the GET parameter is returned. Search + is case-sensitive. See also + GET-PARAMETER and + POST-PARAMETER. + + + + + name optional request + string + + Returns the value of the GET parameter (as provided via the + request URI) named by the string name as a + string (or NIL if there ain't no GET parameter + with this name). Note that only the first value will be + returned if the client provided more than one GET parameter + with the name name. See + also GET-PARAMETERS*. + + + + + name optional request + string + + Returns the value of the POST parameter (as provided in the + request's body) named by the + string name. Note that only the first value + will be returned if the client provided more than one POST + parameter with the name name. This value + will usually be a string (or NIL if there ain't + no POST parameter with this name). If, however, the browser + sent a file through + a + multipart/form-data + form, the value of this function is a three-element list + 
(path file-name content-type)
+ where path is a pathname denoting the place + were the uploaded file was + stored, file-name (a string) is the file + name sent by the browser, and content-type + (also a string) is the content type sent by the browser. The + file denoted by path will be deleted after + the request has been handled - you have to move or copy it + somewhere else if you want to keep it. +

+ POST parameters will only be computed if the content type of + the request body was multipart/form-data + or application/x-www-form-urlencoded. Although + this function is called POST-PARAMETER, you can + instruct Hunchentoot to compute these parameters for other + request methods by + setting *METHODS-FOR-POST-PARAMETERS*. +

+

+ See also POST-PARAMETERS + and *TMP-DIRECTORY*. +

+ + + + + optional request + alist + + Returns + an alist + of all GET parameters (as provided via the request + URI). The car + of each element of this list is the parameter's name while + the cdr + is its value (as a string). The elements of this list are in + the same order as they were within the request URI. See + also GET-PARAMETER. + + + + + optional request + alist + + Returns + an alist + of all POST parameters (as provided via the request's + body). The car + of each element of this list is the parameter's name while + the cdr + is its value. The elements of this list are in the same order + as they were within the request's body. +

+ See also POST-PARAMETER. +

+ + + + + A list of the request method types (as keywords) for which + Hunchentoot will try to compute post-parameters. + + + + + name + optional + request + + string + + + Returns the cookie with the name name (a string) as sent by the + browser - or NIL if there is none. + + + + + + optional + request + + alist + + Returns an alist of all cookies associated with the REQUEST object + request. + + + + + + optional + request + + host + + Returns the 'Host' incoming http header value. + + + + + + optional + request + + string + + + Returns the query string of the REQUEST object request. That's + the part behind the question mark (i.e. the GET parameters). + + + + + + optional + request + + result + + + Returns the 'Referer' (sic!) http header. + + + + + + optional + request + + keyword + + + Returns the request method as a Lisp keyword. + + + + + + optional + request + + uri + + + Returns the request URI. + + + + + + optional + request + + keyword + + + Returns the request protocol as a Lisp keyword. + + + + + + optional + request + + result + + + Returns the 'User-Agent' http header. + + + + + name + optional + request + + header + + + Returns the incoming header with name + name. name can be + a keyword (recommended) or a string. + + + + + + optional + request + + alist + + + Returns an alist of the incoming headers associated with the + REQUEST object + request. + + + + + + optional + request + + address + + + Returns the address the current request originated from. + + + + + + optional + request + + port + + + Returns the port the current request originated from. + + + + + + optional + request + + address + + + The IP address of the local system that the client connected to. + + + + + + optional + request + + port + + + The TCP port number of the local system that the client connected to. + + + + + + optional + request + + script-name + + + Returns the file name of the REQUEST + object request. That's the + requested URI without the query string (i.e the GET + parameters). + + + + + symbol + optional + request + + value, present-p + + + This accessor can be used to associate arbitrary + data with the the symbol symbol in the REQUEST object + request. present-p is true if such data was found, otherwise NIL. + + + + + symbol + optional + request + + | + + + Removes the value associated with symbol from the REQUEST object + request. + + + + + + optional + request + + result + + + Returns as two values the user and password (if any) as + encoded in the 'AUTHORIZATION' header. Returns + NIL if there is no such header. + + + + + + The external format used to compute the REQUEST object. + + + + + + If this is not NIL, it should be a unary + function which will be called with a pathname for each file + which is uploaded to Hunchentoot. The + pathname denotes the temporary file to which the uploaded + file is written. The hook is called directly before the + file is created. At this point, + *REQUEST* is already bound to the + current REQUEST object, but obviously + you can't access the post parameters yet. + + + + + + key + request external-format force-text force-binary want-stream + + raw-body-or-stream + + Returns the content sent by the client in the request body if + there was any (unless the content type + was multipart/form-data in which + case NIL is returned). By default, the result is + a string if the type of the Content-Type + media type + is "text", and a vector of octets otherwise. In + the case of a string, the external format to be used to decode + the content will be determined from the charset + parameter sent by the client (or + otherwise *HUNCHENTOOT-DEFAULT-EXTERNAL-FORMAT* + will be used). +

+ You can also provide an external format explicitly (through + external-format) in which case the result + will unconditionally be a string. Likewise, you can provide + a true value for force-text which will + force Hunchentoot to act as if the type of the media type + had been "text" + (with external-format taking precedence + if provided). Or you can provide a true value + for force-binary which means that you + want a vector of octets at any rate. (If both + force-text + and force-binary are true, an error will + be signaled.) +

+

+ If, however, you provide a true value + for want-stream, the other parameters are + ignored and you'll get the content (flexi) stream to read + from it yourself. It is then your responsibility to read + the correct amount of data, because otherwise you won't be + able to return a response to the client. The stream will + have + its octet + position set to 0. If the client provided + a Content-Length header, the stream will also + have a + corresponding bound, + so no matter whether the client used chunked encoding or + not, you can always read until EOF. +

+

+ If the content type of the request + was multipart/form-data + or application/x-www-form-urlencoded, the + content has been read by Hunchentoot already and you can't + read from the stream anymore. +

+

+ You can call RAW-POST-DATA more than once + per request, but you can't mix calls which have different + values for want-stream. +

+

+ Note that this function is slightly misnamed because a + client can send content even if the request method is not + POST. +

+ + + + + + + key + request external-format + + | + + + Recomputes the GET and POST parameters for the REQUEST object + request. This only makes sense if you're switching external formats + during the request. + + + + + request + + nil + + + This function is called by PROCESS-CONNECTION + after the incoming headers have been read. It + calls HANDLE-REQUEST (and is more or less just a + thin wrapper around it) to select and call a + handler and send the output of this handler to + the client. Note that PROCESS-CONNECTION is + called once per connection and loops in case of a persistent + connection while PROCESS-REQUEST is called anew + for each request. +

+ The return value of this function is ignored. +

+

+ Like PROCESS-CONNECTION, this is another function + the behaviour of which you should only modify if you really, really + know what you're doing. +

+ + + + + acceptor request + + content + + + This function is called by PROCESS-REQUEST once + the request has been read and a REQUEST object + has been created. Its job is to actually handle the request, i.e. to + return something to the client. +

+ The default method calls the + acceptor's request dispatcher, but you + can of course implement a different behaviour. The default method + also sets up standard error handling for + the handler. +

+

+ Might be a good place to bind or rebind special variables which can + then be accessed by your handlers. +

+ + + + + acceptor request + + content + + + This function is called to actually dispatch the request + once the standard logging and error handling has been set + up. ACCEPTOR subclasses implement + methods for this function in order to perform their own + request routing. If a method does not want to handle the + request, it is supposed to invoke CALL-NEXT-METHOD + so that the next ACCEPTOR in the + inheritance chain gets a chance to handle the request. + + + + + + request + + cookies + + + + + request + + get-parameters + + + + + name request + + result + + + + + + + request + + headers + + + + + request + + post-parameters + + + + + request + + query-string + + + + + request + + address + + + + + request + + port + + + + + request + + address + + + + + request + + port + + + + + request + + acceptor + + + + + request + + method + + + + + request + + uri + + + + + request + + protocol + + + + + request + + result + + + + + These are various generic readers which are used + to read information about a REQUEST object. If you are writing a + handler, you should not use these readers but instead utilize the + corresponding functions with an asterisk at the end of their name, + also listed in this section. These generic readers are only + exported for users who want to create their own subclasses of + REQUEST. + + + + + + + + + For each incoming request, the acceptor + (in PROCESS-CONNECTION) creates + a REPLY object and makes it available + to handlers via the special variable + *REPLY*. This object contains all relevant + information (except for the content body) about the reply that will be + sent to the client and this section collects the functions which can + be used to query and modify such an object. In all function + where reply is an optional or keyword parameter, + the default is *REPLY*. + +

+ If you need more fine-grained control over the behaviour of reply + objects, you can subclass REPLY and initialize + the REPLY-CLASS + slot of the ACCEPTOR class accordingly. The + acceptor will generate reply objects of the class named by this + slot. +

+ + + + Objects of this class hold all the information about an + outgoing reply. They are created automatically by + Hunchentoot and can be accessed and modified by the + corresponding handler. +

+ You should not mess with the slots of these objects directly, but you + can subclass REPLY in order to implement your own behaviour. See the + :reply-class initarg + of the ACCEPTOR class. +

+ + + + + + The current REPLY object in the context of a request. + + + + + name + optional + reply + + string + + + HEADER-OUT returns the outgoing http + header named by the keyword name if + there is one, otherwise NIL. SETF + of HEADER-OUT changes the current value + of the header named name. If no header + named name exists, it is created. For + backwards compatibility, name can also + be a string in which case the association between a header + and its name is case-insensitive. +

+ Note that the header 'Set-Cookie' cannot be queried by + HEADER-OUT and must not be set by + SETF of HEADER-OUT. See + also HEADERS-OUT*, + CONTENT-TYPE*, + CONTENT-LENGTH*, + COOKIES-OUT*, and + COOKIE-OUT. +

+ + + + + + optional + reply + + alist + + Returns an alist of the outgoing headers associated with the + REPLY object reply. See also HEADER-OUT. + + + + + + optional + reply + + content-length + + + The outgoing 'Content-Length' http header of reply. + + + + + + optional + reply + + content-type + + + The outgoing 'Content-Type' http header of reply. + + + + + name + optional + reply + + result + + + Returns the current value of the outgoing cookie named + name. Search is case-sensitive. + + + + + + optional + reply + + alist + + + Returns or sets an alist of the outgoing cookies associated with the + REPLY object + reply. + + + + + + optional + reply + + return-code + + + Gets or sets the http return code of + reply. The return code of each + REPLY object is initially set to + +HTTP-OK+. + + + + + stream + + Sends the initial status line and all headers as determined + by the REPLY + object *REPLY*. Returns + a binary + stream to which the body of the reply can be written. Once + this function has been called, further changes + to *REPLY* don't have any effect. + Also, automatic handling of errors (i.e. sending the + corresponding status code to the browser, etc.) is turned + off for this request and functions + like REDIRECT or + to ABORT-REQUEST-HANDLER won't have the + desired effect once the headers are sent. +

+ If your handlers return the full body as a string or as an + array of octets, you should not call this function. + If a handler calls SEND-HEADERS , its + return value is ignored. +

+ + + + + + optional + reply + + external-format + + + Gets or sets the external format of reply which is used for character output. + + + + + + The default content-type header which is returned to the client. + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + The values of these constants are 100, 101, 200, 201, 202, + 203, 204, 205, 206, 207, 300, 301, 302, 303, 304, 305, 307, + 400, 401, 402, 403, 404, 405, 406, 407, 408, 409, 410, 411, + 412, 413, 414, 415, 416, 417, 424, 500, 501, 502, 503, 504, + and 505. See RETURN-CODE. + + + + + + reply + + content-length + + + + + reply + + content-type + + + + + reply + + headers-out + + + + + These are various generic readers which are used + to read information about a REPLY object. If you are writing a + handler, you should not use these readers but instead utilize the + corresponding functions with an asterisk at the end of their name, + also listed in this section. These generic readers are only + exported for users who want to create their own subclasses of + REPLY. + + + + + + reply + + result + + + + + reply + + result + + + + + reply + + result + + + + + These are various generic accessors which are + used to query and modify a REPLY objects. If + you are writing a + handler, you should not use these + accessors but instead utilize the corresponding functions with an + asterisk at the end of their name, also listed in this section. + These generic accessors are only exported for users who want to + create their own subclasses of + REPLY. + + + + + + + + Hunchentoot supports sessions: Once a request + handler has called START-SESSION, Hunchentoot + uses either cookies or (if the client doesn't send the cookies + back) rewrites URLs to keep + track of this client, i.e. to provide a kind of 'state' for the + stateless http protocol. The session associated with the client is a + CLOS object which can be used + to store arbitrary data between requests. +

+ Hunchentoot makes some reasonable effort to prevent eavesdroppers from + hijacking sessions (see below), but this should not be considered + really secure. Don't store sensitive data in sessions and rely solely + on the session mechanism as a safeguard against malicious users who + want to get at this data! +

+

+ For each request there's one SESSION object which is accessible to the + handler via the special + variable *SESSION*. This object holds all the + information available about the session and can be accessed with the + functions described in this chapter. Note that the internal structure + of SESSION objects should be considered opaque + and may change in future releases of Hunchentoot. +

+

+ Sessions are automatically verified for + validity and age when the REQUEST object is + instantiated, i.e. if *SESSION* is not NIL then + this session is valid (as far as Hunchentoot is concerned) and + not too old. Old sessions + are automatically removed. +

+

+ Hunchentoot also provides a SESSION-REGENERATE-COOKIE-VALUE + function that creates a new cookie value. This helps to prevent against + session fixation + attacks, and should be used when a user logs in according to the application. +

+ + + + SESSION objects are + automatically maintained by Hunchentoot. They should not be created + explicitly with MAKE-INSTANCE but implicitly + with START-SESSION and they should be treated as + opaque objects. +

+ You can ignore Hunchentoot's SESSION objects and + implement your own sessions if you provide corresponding methods for + SESSION-COOKIE-VALUE + and SESSION-VERIFY. +

+ + + + + + + session + + + Returns the current SESSION + object. If there is no current session, creates one and updates the + corresponding data structures. In this case the function will also + send a session cookie to the browser. + + + + + symbol + optional + session + + value, present-p + + + This accessor can be used to associate arbitrary data with the the + symbol symbol in the SESSION + object session. present-p is + true if such data was found, otherwise NIL. The default + value for session is + *SESSION*. +

+ If SETF of SESSION-VALUE is called + with session being NIL then a + session is automatically instantiated + with START-SESSION. +

+ + + + + symbol + optional + session + + | + + + Removes the value associated with + symbol from + session if there is one. + + + + + + The current session while in the context of a request, or + NIL. + + + + + session + + | + + + Completely removes the SESSION object + session from Hunchentoot's + internal session database. + + + + + + optional + acceptor + + | + + + Removes all stored sessions of + acceptor. The default for + acceptor is + *ACCEPTOR*. + + + + + session + + cookie + + + Regenerates the session cookie value. This should be used + when a user logs in according to the application to prevent + against session fixation attacks. The cookie value being + dependent on ID, USER-AGENT, REMOTE-ADDR, START, and + *SESSION-SECRET*, the only value we can change is START to + regenerate a new value. Since we're generating a new cookie, + it makes sense to have the session being restarted, in + time. That said, because of this fact, calling this function + twice in the same second will regenerate twice the same + value. + + + + + + Whether HTML pages should possibly be rewritten for cookie-less + session-management. + + + + + + The content types for which url-rewriting is OK. See + *REWRITE-FOR-SESSION-URLS*. + + + + + + Whether the client's remote IP (as returned by REAL-REMOTE-ADDR) + should be encoded into the session string. If this value is true, a + session will cease to be accessible if the client's remote IP changes. +

+ This might for example be an issue if the client uses a proxy server + which doesn't send correct 'X-Forwarded-For' headers. +

+ + + + + session + + remote-addr + + + The remote IP address of the client when this session was started (as + returned by REAL-REMOTE-ADDR). + + + + + Whether the 'User-Agent' header should + be encoded into the session string. If this value is true, a session + will cease to be accessible if the client sends a different + 'User-Agent' header. + + + + + session + + user-agent + + + The incoming 'User-Agent' header that + was sent when this session was created. + + + + + session + + max-time + + + Gets or sets the time (in seconds) after + which session expires if it's not used. + + + + + + + The default time (in seconds) after which a session times out. + + + + + + A session GC (see function SESSION-GC) will happen every + *SESSION-GC-FREQUENCY* requests (counting only + requests which create a new session) if this variable is + not NIL. See SESSION-CREATED. + + + + + + + | + + + Removes sessions from the current session database which are + too old - see SESSION-TOO-OLD-P. + + + + + session + + generalized-boolean + + + Returns true if the SESSION object session has not been active in + the last (session-max-time session) seconds. + + + + + session + + session-id + + + The unique ID (an INTEGER) of the session. + + + + + session + + universal-time + + + The time this session was started. + + + + + + + + For everyday session usage, you will probably just + use START-SESSION, + SESSION-VALUE, + and maybe DELETE-SESSION-VALUE + and *SESSION*. However, there are two ways to + customize the way Hunchentoot maintains sessions. +

+ One way is to mostly leave the session mechanism intact but to tweak + it a bit: +

    +
  • The publicly visible part of a session is encoded using a + secret which you can set yourself.
    • +
  • And it is stored using a cookie (or GET + parameter) name that you can + override.
    • +
  • Each session receives a new ID when + it is created and you can implement a more robust way to do that.
    • +
  • You can arrange to be called whenever a session + is created to trigger some action. You + might also do this to invent your own + session garbage collection.
    • +
  • By default, all sessions are stored in a global alist in memory. + You can't change the alist part, but you can distribute your sessions + over different "databases".
    • +
  • By default, every operation which modifies sessions or one of the + session databases is guarded by a global lock, but you can arrange to + provide different locks for this.
    • +
+

+

+ The other way to customize Hunchentoot's sessions is to completely + replace them. This is actually pretty easy: Create your own class to + store state (which doesn't have to and probably shouldn't inherit + from SESSION) and implement methods for + SESSION-VERIFY + and SESSION-COOKIE-VALUE - that's it. + Hunchentoot will continue to use cookies and/or to rewrite URLs to + keep track of session state and it will store "the current session" + (whatever that is in your implementation) + in *SESSION*. Everything else (like persisting + sessions, GC, getting and setting values) you'll have to take care of + yourself and the other session functions + (like START-SESSION or + SESSION-VALUE) won't work anymore. (Almost) + total freedom, but a lot of responsibility as well... :) +

+ + + + A random ASCII string that's used to encode the public + session data. This variable is initially unbound and will + be set (using RESET-SESSION-SECRET) the + first time a session is created, if necessary. You can + prevent this from happening if you set the value yourself + before starting acceptors. + + + + + + + secret + + + Sets *SESSION-SECRET* to a + new random value. All old sessions will cease to be valid. + + + + + acceptor + + name + + + Returns the name (a string) of the cookie (or + the GET parameter) which is used to store a session on the client + side. The default is to use the + string "hunchentoot-session", but you can + specialize this function if you want another name. + + + + + acceptor new-session + + result + + + This function is called whenever a new session + has been created. There's a default method which might trigger + a session GC based on the value of + *SESSION-GC-FREQUENCY*. +

+ The return value is ignored. +

+ + + + + acceptor + + id + + + Returns the next sequential session ID, an + integer, which should be unique per session. The default method uses + a simple global counter and isn't guarded by a lock. For a + high-performance production environment you might consider using a + more robust implementation. + + + + + acceptor + + database + + + Returns the current session database which is an + alist where each car is a session's ID and the cdr is the + corresponding SESSION object itself. The default + is to use a global list for all acceptors. + + + + + acceptor + key + whole-db-p + + lock + + + A function which returns a lock that will be + used to prevent concurrent access to sessions. The first argument + will be the acceptor that handles the + current request, the second argument is true + if the whole (current) session database is modified. If it + is NIL, only one existing session in the database is + modified. +

+ This function can return NIL which means that sessions or + session databases will be modified without a lock held (for example + for single-threaded environments). The default is to always return a + global lock (ignoring the acceptor argument) for + Lisps that support threads and NIL otherwise. +

+ + + + + request + + session-or-nil + + + Tries to get a session identifier from the cookies + (or alternatively from the GET parameters) sent by the client (see + SESSION-COOKIE-NAME + and SESSION-COOKIE-VALUE). This identifier is + then checked for validity against the REQUEST + object + request. On success the corresponding session object (if not too + old) is returned (and updated). Otherwise NIL is returned. +

+ A default method is provided and you only need to write your own one + if you want to maintain your own sessions. +

+ + + + + session + + string + + + Returns a string which can be used to safely + restore the session session if as session has + already been established. This is used as the value stored in the + session cookie or in the corresponding GET parameter and verified + by SESSION-VERIFY. +

+ A default + method is provided and there's no reason to change it unless you + want to use your own session objects. +

+ + + + + + + + Outgoing cookies are stored in the request's REPLY + object (see COOKIE-OUT + and COOKIES-OUT*). They are CLOS objects + defined like this: + + 
(defclass cookie ()
+  ((name :initarg :name
+         :reader cookie-name
+         :type string
+         :documentation "The name of the cookie - a string.")
+   (value :initarg :value
+          :accessor cookie-value
+          :initform ""
+          :documentation "The value of the cookie. Will be URL-encoded when sent to the browser.")
+   (expires :initarg :expires
+            :initform nil
+            :accessor cookie-expires
+            :documentation "The time (a universal time) when the cookie expires (or NIL).")
+   (max-age :initarg :max-age
+            :initform nil
+            :accessor cookie-max-age
+            :documentation "The time delta (in seconds) after which the cookie expires (or NIL).")
+   (path :initarg :path
+         :initform nil
+         :accessor cookie-path
+         :documentation "The path this cookie is valid for (or NIL).")
+   (domain :initarg :domain
+           :initform nil
+           :accessor cookie-domain
+           :documentation "The domain this cookie is valid for (or NIL).")
+   (secure :initarg :secure
+           :initform nil
+           :accessor cookie-secure
+           :documentation "A generalized boolean denoting whether this is a secure cookie.")
+   (http-only :initarg :http-only
+              :initform nil
+              :accessor cookie-http-only
+              :documentation "A generalized boolean denoting whether this is a HttpOnly cookie.")))
+
+ + The reader + COOKIE-NAME and + the accessors + COOKIE-VALUE, COOKIE-EXPIRES, COOKIE-MAX-AGE, + COOKIE-PATH, COOKIE-DOMAIN, COOKIE-SECURE, + and COOKIE-HTTP-ONLY are all exported from + the HUNCHENTOOT package. For now, the class name itself is not exported. + + + + name key value expires path + domain secure http-only reply + + cookie + + Creates a COOKIE object from the parameters + provided to this function and adds it to the outgoing cookies + of the REPLY object + reply. If a cookie with the same name + (case-sensitive) already exists, it is replaced. The default + for reply + is *REPLY*. The default + for value is the empty string. + + + + + cookie optional reply + cookie + + Adds the COOKIE object cookie + to the outgoing cookies of + the REPLY object + reply. If a cookie with the same name + (case-sensitive) already exists, it is replaced. The default + for reply is *REPLY*. + + + + + + Hunchentoot can log accesses and diagnostic messages to two + separate destinations, which can be either files in the file + system or streams. Logging can also be disabled by setting the + ACCESS-LOG-DESTINATION and + MESSAGE-LOG-DESTINATION slots in the + ACCEPTOR to NIL. The two + slots can be initialized by providing the + :ACCESS-LOG-DESTINATION and :MESSAGE-LOG-DESTINATION + initialization arguments when creating the acceptor or set by + setting the slots through its + ACCEPTOR-MESSAGE-LOG-DESTINATION and + ACCEPTOR-ACCESS-LOG-DESTINATION accessors. +

+ When the path for the message or accept log is set to a + variable holding an output stream, hunchentoots writes + corresponding log entries to that stream. By default, + Hunchentoot logs to *STANDARD-ERROR*. +

+

+ Access logging is done in a format similar to what + the Apache web server can write so that logfile analysis using + standard tools is possible. Errors during request processing are + logged to a separate file. +

+

+ The standard logging mechanism is deliberately simple and slow. The + log files are opened for each log entry and closed again after + writing, and access to them is protected by a global lock. Derived + acceptor classes can implement methods for the + ACCEPTOR-LOG-MESSAGE and + ACCEPTOR-LOG-ACCESS generic functions in order to + log differently (e.g. to a central logging server or in a different + file format. +

+

+ Errors happening within a handler + which are not caught by the handler itself are handled by + Hunchentoot by logging them to the established + ACCEPTOR-MESSAGE-LOG-DESTINATION. +

+ + + log-level format-string + rest + format-arguments + + result + + + Convenience function which calls the message + logger of the current acceptor (if there is one) with the same + arguments it accepts. Returns NIL if there is no message + logger or whatever the message logger returns. +

+ This is the function which Hunchentoot itself uses to log errors it + catches during request processing. +

+ + + + + + Whether Lisp errors in request handlers should be logged. + + + + + + Whether Lisp backtraces should be logged. Only + has an effect if *LOG-LISP-ERRORS-P* is true + as well. + + + + + + Whether Lisp warnings in request handlers should be logged. + + + + + + Log level for Lisp errors. Should be one + of :ERROR (the default), :WARNING, + or :INFO. + + + + + + Log level for Lisp warnings. + Should be one of :ERROR, :WARNING + (the default), or :INFO. + + + + + +

+ This section describes how Hunchentoot deals with exceptional + situations. See also the secion about logging. +

+

+ When an error occurs while processing a request, Hunchentoot's + default behavior is to catch the error, log it and + optionally display it to the client in the HTML response. + This behavior can be customized through the values of a number + of special variables, which are documented below. +

+ + + + If the value of this variable is NIL + (the default is T), then errors which happen while a + request is handled aren't caught as usual, but + instead your + Lisp's debugger + is invoked. + This variable should obviously always be set to a true value + in a production environment. + See MAYBE-INVOKE-DEBUGGER + if you want to fine-tune this behaviour. + + + + + + Whether Lisp errors should be shown in HTML output. Note + that this only affects canned responses generated by Lisp. + If an error template is present for the "internal server + error" status code, this special variable is not used (see + acceptor-status-message). + + + + + + Whether Lisp backtraces should be shown in HTML output if + *SHOW-LISP-ERRORS-P* is true and an error occurs. + + + + + condition + + | + + + This generic function is called whenever a + condition condition + is signaled in Hunchentoot. You might want to specialize it on + specific condition classes for debugging purposes. The default + method invokes + the debugger with condition if + *CATCH-ERRORS-P* is NIL. + + + + + + Superclass for all conditions related to Hunchentoot. + + + + + + Superclass for all errors related to Hunchentoot and a subclass of HUNCHENTOOT-CONDITION. + + + + + + Signalled if a function was called with incosistent or illegal parameters. A subclass of HUNCHENTOOT-ERROR. + + + + + + Superclass for all warnings related to Hunchentoot and a subclass of HUNCHENTOOT-CONDITION. + + + + + + + + Various functions and variables which didn't fit into one of the + other categories. + + + + optional + result + + result + + + This function can be called by a request handler + at any time to immediately abort handling the request. This works as + if the handler had returned result. See the + source code of REDIRECT for an example. + + + + + time optional request + | + + This function is designed to be used inside + a handler. If the client has sent an + 'If-Modified-Since' header + (see RFC 2616, + section 14.25) and the time specified matches the universal + time + time then the + header +HTTP-NOT-MODIFIED+ with no content + is immediately returned to the client. +

+ Note that for this function to be useful you should usually + send 'Last-Modified' headers back to the client. See the + code + of CREATE-STATIC-FILE-DISPATCHER-AND-HANDLER + for an example. +

+ + + + + path optional content-type + nil + + Sends the file denoted by the pathname designator + path with content type + content-type to the client. Sets the + necessary handlers. In particular the function employs + HANDLE-IF-MODIFIED-SINCE. +

+ If content-type is NIL the + function tries to determine the correct content type from + the file's suffix or falls back + to "application/octet-stream" as a last resort. +

+

+ Note that this function + calls SEND-HEADERS internally, so after + you've called it, the headers are sent and the return value + of your handler is ignored. +

+ + + + + target key host port protocol add-session-id code + | + + Sends back appropriate headers to redirect the client + to target (a string). +

+ If target is a full URL starting with a + scheme, host, port, + and protocol are ignored. + Otherwise, target should denote the path + part of a URL, protocol must be one of + the keywords :HTTP or :HTTPS, and + the URL to redirect to will be constructed + from host, port, protocol, + and target. +

+

+ code must be a 3xx HTTP redirection + status code to send to the client. It defaults to 302 + ("Found"). If host is not provided, + the current host (see HOST) will be + used. If protocol is the keyword + :HTTPS, the client will be redirected to a + https URL, if it's :HTTP it'll be sent to a + http URL. If both host and + protocol aren't provided, then the + value of protocol will match the + current request. +

+ + + + + optional realm + | + + Sends back appropriate headers to require basic HTTP + authentication + (see RFC 2617) + for the realm realm. The default value + for realm is "Hunchentoot". + + + + + + + | + + + Adds appropriate headers to completely prevent caching on most browsers. + + + + + + optional + acceptor + + generalized-boolean + + + Whether the current connection to the client is secure. See ACCEPTOR-SSL-P. + + + + + return-code + + string + + + Returns a reason phrase for the HTTP return code return-code + (which should be an integer) or NIL for return codes Hunchentoot + doesn't know. + + + + + + optional + time + + string + + + Generates a time string according to RFC 1123. Default is current time. + This can be used to send a 'Last-Modified' header - see HANDLE-IF-MODIFIED-SINCE. + + + + + string + optional + external-format + + string + + + URL-encodes a string using the external format external-format. The default for external-format is the value of *HUNCHENTOOT-DEFAULT-EXTERNAL-FORMAT*. + + + + + string + optional + external-format + + string + + + Decodes a URL-encoded string which is assumed to + be encoded using the external + format external-format, i.e. this is the inverse + of URL-ENCODE. It is assumed that you'll rarely + need this function, if ever. But just in case - here it is. The + default for external-format is the value + of *HUNCHENTOOT-DEFAULT-EXTERNAL-FORMAT*. + + + + + string + + result + + + Escapes the characters #\<, #\>, #\', #\", and #\& for HTML output. + + + + + object + generalized-boolean + + This function tests whether object is a + non-empty string which is a token according + to RFC + 2068 (i.e. whether it may be used for, say, cookie names). + + + + + pathspec + + result + + + Given a pathname designator pathspec returns the MIME type + (as a string) corresponding to the suffix of the file denoted by + pathspec (or NIL). + + + + + + + generalized-boolean + + + Returns true if in the context of a request. Otherwise, NIL. + + + + + + This should be a pathname denoting a directory where temporary + files can be stored. It is used for file + uploads. + + + + + + If this variable is not NIL, it should be bound to a stream to + which incoming and outgoing headers will be written for debugging + purposes. + + + + + + + A designator for a function without arguments which is called on a + regular basis if *CLEANUP-INTERVAL* is not NIL. The initial value is + the name of a function which invokes a garbage collection on 32-bit + versions of LispWorks. +

+ This variable is only available on LispWorks. +

+ + + + + + Should be NIL or a positive integer. The system calls + *CLEANUP-FUNCTION* + whenever *CLEANUP-INTERVAL* new worker threads + (counted globally across all acceptors) have been created unless the + value is NIL. The initial value is 100. +

+ This variable is only available on LispWorks. +

+ + + + + + + Hunchentoot comes with a test script which verifies that the + example web server responds as expected. This test script uses the + Drakma HTTP client library + and thus shares a significant amount of its base code with + Hunchentoot itself. Still, running the test script is a useful + confidence test, and it is also possible to run the script across + machines in order to verify a new Hunchentoot (or, for that matter + Drakma) port. +

+ To run the confidence test, start + the example web server. Then, in your Lisp + listener, type +

(hunchentoot-test:test-hunchentoot "http://localhost:4242")
+You will see some diagnostic output and a summary line that +reports whether any tests have failed. (You can also use the +example certificate and key files in the test directory and +start and test an https server instead.) +

+ + + base-url key + | + + Runs the built-in confidence + test. base-url is the base URL to use + for testing, it should not have a trailing slash. The keyword + arguments accepted are for future extension and should not + currently be used. +

+ The script expects the Hunchentoot example test server to be + running at the given base-url and + retrieves various pages from that server, expecting certain + responses. +

+ + + + + + By default, Hunchentoot intercepts all errors that occur while + executing request handlers, logs them to the log file and displays + a static error page to the user. While developing applications, + you may want to change that behavior so that the debugger is + invoked when an error occurs. You can set + the *CATCH-ERRORS-P* to NIL to + make that happen. Alternatively, you may want to have Hunchentoot + display detailed error information in the error response page. + You can set the *SHOW-LISP-ERRORS-P* to a + true value to make that happen. If you don't want to see Lisp + backtraces in these error pages, you can + set *SHOW-LISP-BACKTRACES-P* + to NIL. + + + + + Hunchentoot's predecessor TBNL + (which is short for "To Be Named Later") grew over the years as a + toolkit that I used for various commercial and private + projects. In August 2003, Daniel Barlow started + a review of + web APIs on + the lispweb mailing + list and + I described + the API of my hitherto-unreleased bunch of code (and christened it + "TBNL"). +

+ It turned out that + Jeff Caldwell had + worked on something similar so he emailed me and proposed to + join our efforts. As I had no immediate plans to release my code + (which was poorly organized, undocumented, and mostly + CMUCL-specific), I gave it to Jeff and he worked towards a + release. He added docstrings, refactored, added some stuff, and + based it on KMRCL to make it portable across several Lisp + implementations. +

+

+ Unfortunately, Jeff is at least as busy as I am so he didn't + find the time to finish a full release. But in spring 2004 I + needed a documented version of the code for a client of mine who + thought it would be good if the toolkit were publicly available + under an open source license. So I took Jeff's code, refactored + again (to sync with the changes I had done in the meantime), and + added documentation. This resulted in TBNL 0.1.0 (which + initially required mod_lisp as its front-end). +

+

+ In March 2005, Bob Hutchinson sent patches which enabled TBNL to + use other front-ends than mod_lisp. This made me aware that + TBNL was already almost a full web server, so + eventually I wrote Hunchentoot which was a full web + server, implemented as a wrapper around TBNL. Hunchentoot 0.1.0 + was released at the end of 2005 and was originally + LispWorks-only. +

+

+ Hunchentoot 0.4.0, released in October 2006, was the first + release which also worked with other Common Lisp + implementations. It is a major rewrite and also incorporates + most of TBNL and replaces it completely. +

+

+ Hunchentoot 1.0.0, released in February 2009, is again a major + rewrite and should be considered work in progress. It moved to + using + the usocket + and Bordeaux + Threads libraries for non-LispWorks Lisps, thereby removing most of + the platform dependent code. Threading behaviour was made + controllable through the introduction of + taskmasters. mod_lisp + support and several other things were removed in this release to + simplify the code base (and partly due to the lack of interest). + Several architectural changes (lots of them not + backwards-compatible) were made to ease customization of + Hunchentoot's behaviour. A significant part of the 1.0.0 + redesign was done + by Hans Hübner. +

+ + + + + Here are all exported symbols of the HUNCHENTOOT + package in alphabetical order linked to their corresponding + documentation entries: + + + + + + + + Thanks to Jeff Caldwell - TBNL would not have been released + without his efforts. Thanks + to Stefan + Scholl and Travis Cross for various additions and fixes to + TBNL, to Michael + Weber for initial file upload code, and + to Janis Dzerins for + his RFC 2388 + code. Thanks to Bob Hutchison for his code for multiple + front-ends (which made me realize that TBNL was already pretty + close to a "real" web server) and the initial UTF-8 example. + Thanks to Hans Hübner + for a lot of architectural and implementation enhancements for the + 1.0.0 release and also for transferring the documentation to sane + XHTML. Thanks to John + Foderaro's AllegroServe + for inspiration. Thanks to Uwe von + Loh for + the Hunchentoot + logo. + +

+ Hunchentoot originally used code + from ACL-COMPAT, + specifically the chunking code from Jochen Schmidt. (This has been + replaced by Chunga.) When I ported + Hunchentoot to other Lisps than LispWorks, I stole code from + ACL-COMPAT, KMRCL, + and trivial-sockets for + implementation-dependent stuff like sockets and MP. (This has been replaced by + Bordeaux + Threads + and usocket.) +

+

+ Parts of this documentation were prepared + with DOCUMENTATION-TEMPLATE, + no animals were harmed. +

+ +

+ BACK TO MY HOMEPAGE + +

+ diff --git a/deps/hunchentoot/easy-handlers.lisp b/deps/hunchentoot/easy-handlers.lisp new file mode 100644 index 0000000..2874585 --- /dev/null +++ b/deps/hunchentoot/easy-handlers.lisp @@ -0,0 +1,347 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*- + +;;; 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 :hunchentoot) + +(defvar *dispatch-table* (list 'dispatch-easy-handlers) + "A global list of dispatch functions.") + +(defvar *easy-handler-alist* nil + "An alist of \(URI acceptor-names function) lists defined by +DEFINE-EASY-HANDLER.") + +(defun compute-real-name (symbol) + "Computes the `real' paramater name \(a string) from the Lisp +symbol SYMBOL. Used in cases where no parameter name is +provided." + ;; we just downcase the symbol's name + (string-downcase symbol)) + +(defun convert-parameter (argument type) + "Converts the string ARGUMENT to TYPE where TYPE is one of the +symbols STRING, CHARACTERS, INTEGER, KEYWORD, or BOOLEAN - or +otherwise a function designator for a function of one argument. +ARGUMENT can also be NIL in which case this function also returns +NIL unconditionally." + (when (listp argument) + ;; this if for the case that ARGUMENT is NIL or the result of a + ;; file upload + (return-from convert-parameter argument)) + (case type + (string argument) + (character (and (= (length argument) 1) + (char argument 0))) + (integer (ignore-errors* (parse-integer argument :junk-allowed t))) + (keyword (as-keyword argument :destructivep nil)) + (boolean t) + (otherwise (funcall type argument)))) + +(defun compute-simple-parameter (parameter-name type parameter-reader) + "Retrieves the parameter named PARAMETER-NAME using the reader +PARAMETER-READER and converts it to TYPE." + (convert-parameter (funcall parameter-reader parameter-name) type)) + +(defun compute-list-parameter (parameter-name type parameters) + "Retrieves all parameters from PARAMETERS which are named +PARAMETER-NAME, converts them to TYPE, and returns a list of +them." + (loop for (name . value) in parameters + when (string= name parameter-name) + collect (convert-parameter value type))) + +(defun compute-array-parameter (parameter-name type parameters) + "Retrieves all parameters from PARAMETERS which are named like +\"PARAMETER-NAME[N]\" \(where N is a non-negative integer), +converts them to TYPE, and returns an array where the Nth element +is the corresponding value." + ;; see + #+:sbcl (declare (sb-ext:muffle-conditions warning)) + (let* ((index-value-list + (loop for (full-name . value) in parameters + for index = (register-groups-bind (name index-string) + ("^(.*)\\[(\\d+)\\]$" full-name) + (when (string= name parameter-name) + (parse-integer index-string))) + when index + collect (cons index (convert-parameter value type)))) + (array (make-array (1+ (reduce #'max index-value-list + :key #'car + :initial-value -1)) + :initial-element nil))) + (loop for (index . value) in index-value-list + do (setf (aref array index) value)) + array)) + +(defun compute-hash-table-parameter (parameter-name type parameters key-type test-function) + "Retrieves all parameters from PARAMETERS which are named like +\"PARAMETER-NAME{FOO}\" \(where FOO is any sequence of characters +not containing curly brackets), converts them to TYPE, and +returns a hash table with test function TEST-FUNCTION where the +corresponding value is associated with the key FOO \(converted to +KEY-TYPE)." + (let ((hash-table (make-hash-table :test test-function))) + (loop for (full-name . value) in parameters + for key = (register-groups-bind (name key-string) + ("^(.*){([^{}]+)}$" full-name) + (when (string= name parameter-name) + (convert-parameter key-string key-type))) + when key + do (setf (gethash key hash-table) + (convert-parameter value type))) + hash-table)) + +(defun compute-parameter (parameter-name parameter-type request-type) + "Computes and returns the parameter\(s) called PARAMETER-NAME +and converts it/them according to the value of PARAMETER-TYPE. +REQUEST-TYPE is one of :GET, :POST, or :BOTH." + (when (member parameter-type '(list array hash-table)) + (setq parameter-type (list parameter-type 'string))) + (let ((parameter-reader (ecase request-type + (:get #'get-parameter) + (:post #'post-parameter) + (:both #'parameter))) + (parameters (and (listp parameter-type) + (case request-type + (:get (get-parameters*)) + (:post (post-parameters*)) + (:both (append (get-parameters*) (post-parameters*))))))) + (cond ((atom parameter-type) + (compute-simple-parameter parameter-name parameter-type parameter-reader)) + ((and (null (cddr parameter-type)) + (eq (first parameter-type) 'list)) + (compute-list-parameter parameter-name (second parameter-type) parameters)) + ((and (null (cddr parameter-type)) + (eq (first parameter-type) 'array)) + (compute-array-parameter parameter-name (second parameter-type) parameters)) + ((and (null (cddddr parameter-type)) + (eq (first parameter-type) 'hash-table)) + (compute-hash-table-parameter parameter-name (second parameter-type) parameters + (or (third parameter-type) 'string) + (or (fourth parameter-type) 'equal))) + (t (parameter-error "Don't know what to do with parameter type ~S." parameter-type))))) + +(defun make-defun-parameter (description default-parameter-type default-request-type) + "Creates a keyword parameter to be used by DEFINE-EASY-HANDLER. +DESCRIPTION is one of the elements of DEFINE-EASY-HANDLER's +LAMBDA-LIST and DEFAULT-PARAMETER-TYPE and DEFAULT-REQUEST-TYPE +are the global default values." + (when (atom description) + (setq description (list description))) + (destructuring-bind (parameter-name &key (real-name (compute-real-name parameter-name)) + parameter-type init-form request-type) + description + `(,parameter-name (or (and (boundp '*request*) + (compute-parameter ,real-name + ,(or parameter-type default-parameter-type) + ,(or request-type default-request-type))) + ,init-form)))) + +(defmacro define-easy-handler (description lambda-list &body body) + "Defines a handler with the body BODY and optionally registers +it with a URI so that it will be found by DISPATCH-EASY-HANDLERS. +DESCRIPTION is either a symbol NAME or a list matching the +destructuring lambda list + + (name &key uri acceptor-names default-parameter-type default-request-type). + +LAMBDA-LIST is a list the elements of which are either a symbol +VAR or a list matching the destructuring lambda list + + (var &key real-name parameter-type init-form request-type). + +The resulting handler will be a Lisp function with the name NAME +and keyword parameters named by the VAR symbols. Each VAR will +be bound to the value of the GET or POST parameter called +REAL-NAME \(a string) before BODY is executed. If REAL-NAME is +not provided, it will be computed by downcasing the symbol name +of VAR. + +If URI \(which is evaluated) is provided, then it must be a string or +a function designator for a function of one argument. In this case, +the handler will be returned by DISPATCH-EASY-HANDLERS, if URI is a +string and the script name of a request is URI, or if URI designates a +function and applying this function to the current request object +returns a true value. + +ACCEPTOR-NAMES \(which is evaluated) can be a list of symbols which +means that the handler will be returned by DISPATCH-EASY-HANDLERS in +acceptors which have one of these names \(see ACCEPTOR-NAME). +ACCEPTOR-NAMES can also be the symbol T which means that the handler +will be returned by DISPATCH-EASY-HANDLERS in every acceptor. + +Whether the GET or POST parameter \(or both) will be taken into +consideration, depends on REQUEST-TYPE which can +be :GET, :POST, :BOTH, or NIL. In the last case, the value of +DEFAULT-REQUEST-TYPE \(the default of which is :BOTH) will be +used. + +The value of VAR will usually be a string \(unless it resulted from a +file upload in which case it won't be converted at all), but if +PARAMETER-TYPE \(which is evaluated) is provided, the string will be +converted to another Lisp type by the following rules: + +If the corresponding GET or POST parameter wasn't provided by the +client, VAR's value will be NIL. If PARAMETER-TYPE is 'STRING, VAR's +value remains as is. If PARAMETER-TYPE is 'INTEGER and the parameter +string consists solely of decimal digits, VAR's value will be the +corresponding integer, otherwise NIL. If PARAMETER-TYPE is 'KEYWORD, +VAR's value will be the keyword obtained by interning the upcased +parameter string into the keyword package. If PARAMETER-TYPE is +'CHARACTER and the parameter string is of length one, VAR's value will +be the single character of this string, otherwise NIL. If +PARAMETER-TYPE is 'BOOLEAN, VAR's value will always be T \(unless it +is NIL by the first rule above, of course). If PARAMETER-TYPE is any +other atom, it is supposed to be a function designator for a unary +function which will be called to convert the string to something else. + +Those were the rules for `simple' types, but PARAMETER-TYPE can +also be a list starting with one of the symbols LIST, ARRAY, or +HASH-TABLE. The second value of the list must always be a simple +parameter type as in the last paragraph - we'll call it the +`inner type' below. + +In the case of 'LIST, all GET/POST parameters called REAL-NAME +will be collected, converted to the inner type, and assembled +into a list which will be the value of VAR. + +In the case of 'ARRAY, all GET/POST parameters which have a name +like the result of + + (format nil \"~A[~A]\" real-name n) + +where N is a non-negative integer, will be assembled into an +array where the Nth element will be set accordingly, after +conversion to the inner type. The array, which will become the +value of VAR, will be big enough to hold all matching parameters, +but not bigger. Array elements not set as described above will +be NIL. Note that VAR will always be bound to an array, which +may be empty, so it will never be NIL, even if no appropriate +GET/POST parameters are found. + +The full form of a 'HASH-TABLE parameter type is + + (hash-table inner-type key-type test-function), + +but KEY-TYPE and TEST-FUNCTION can be left out in which case they +default to 'STRING and 'EQUAL, respectively. For this parameter +type, all GET/POST parameters which have a name like the result +of + + (format nil \"~A{~A}\" real-name key) + +\(where KEY is a string that doesn't contain curly brackets) will +become the values \(after conversion to INNER-TYPE) of a hash +table with test function TEST-FUNCTION where KEY \(after +conversion to KEY-TYPE) will be the corresponding key. Note that +VAR will always be bound to a hash table, which may be empty, so +it will never be NIL, even if no appropriate GET/POST parameters +are found. + +To make matters even more complicated, the three compound +parameter types also have an abbreviated form - just one of the +symbols LIST, ARRAY, or HASH-TABLE. In this case, the inner type +will default to 'STRING. + +If PARAMETER-TYPE is not provided or NIL, DEFAULT-PARAMETER-TYPE +\(the default of which is 'STRING) will be used instead. + +If the result of the computations above would be that VAR would +be bound to NIL, then INIT-FORM \(if provided) will be evaluated +instead, and VAR will be bound to the result of this evaluation. + +Handlers built with this macro are constructed in such a way that +the resulting Lisp function is useful even outside of +Hunchentoot. Specifically, all the parameter computations above +will only happen if *REQUEST* is bound, i.e. if we're within a +Hunchentoot request. Otherwise, VAR will always be bound to the +result of evaluating INIT-FORM unless a corresponding keyword +argument is provided." + (when (atom description) + (setq description (list description))) + (destructuring-bind (name &key uri (acceptor-names t) + (default-parameter-type ''string) + (default-request-type :both)) + description + `(progn + ,@(when uri + (list + (with-rebinding (uri) + `(progn + (setq *easy-handler-alist* + (delete-if (lambda (list) + (and (or (equal ,uri (first list)) + (eq ',name (third list))) + (or (eq ,acceptor-names t) + (intersection ,acceptor-names + (second list))))) + *easy-handler-alist*)) + (push (list ,uri ,acceptor-names ',name) *easy-handler-alist*))))) + (defun ,name (&key ,@(loop for part in lambda-list + collect (make-defun-parameter part + default-parameter-type + default-request-type))) + ,@body)))) + +;; help the LispWorks IDE to find these definitions +#+:lispworks +(dspec:define-form-parser define-easy-handler (description) + `(,define-easy-handler ,(if (atom description) description (first description)))) + +#+:lispworks +(dspec:define-dspec-alias define-easy-handler (name) + `(defun ,name)) + +(defun dispatch-easy-handlers (request) + "This is a dispatcher which returns the appropriate handler +defined with DEFINE-EASY-HANDLER, if there is one." + (loop for (uri acceptor-names easy-handler) in *easy-handler-alist* + when (and (or (eq acceptor-names t) + (find (acceptor-name *acceptor*) acceptor-names :test #'eq)) + (cond ((stringp uri) + (string= (script-name request) uri)) + (t (funcall uri request)))) + do (return easy-handler))) + +(defclass easy-acceptor (acceptor) + () + (:documentation "This is the acceptor of the ``easy'' Hunchentoot framework.")) + +(defmethod acceptor-dispatch-request ((acceptor easy-acceptor) request) + "The easy request dispatcher which selects a request handler +based on a list of individual request dispatchers all of which can +either return a handler or neglect by returning NIL." + (loop for dispatcher in *dispatch-table* + for action = (funcall dispatcher request) + when action return (funcall action) + finally (call-next-method))) + +#-:hunchentoot-no-ssl +(defclass easy-ssl-acceptor (easy-acceptor ssl-acceptor) + () + (:documentation "This is an acceptor that mixes the ``easy'' + Hunchentoot with SSL connections.")) diff --git a/deps/hunchentoot/headers.lisp b/deps/hunchentoot/headers.lisp new file mode 100644 index 0000000..d4fd8e1 --- /dev/null +++ b/deps/hunchentoot/headers.lisp @@ -0,0 +1,279 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*- + +;;; 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 :hunchentoot) + +(defgeneric write-header-line (key value stream) + (:documentation "Accepts a string KEY and a Lisp object VALUE and +writes them directly to the client as an HTTP header line.") + (:method (key (string string) stream) + (write-string key stream) + (write-char #\: stream) + (write-char #\Space stream) + (let ((start 0)) + (loop + (let ((end (or (position #\Newline string :start start) + (length string)))) + ;; skip empty lines, as they confuse certain HTTP clients + (unless (eql start end) + (unless (zerop start) + (write-char #\Tab stream)) + (write-string string stream :start start :end end) + (write-char #\Return stream) + (write-char #\Linefeed stream)) + (setf start (1+ end)) + (when (<= (length string) start) + (return)))))) + (:method (key (number number) stream) + (write-header-line key (write-to-string number :escape nil :readably nil :base 10) stream)) + (:method (key value stream) + (write-header-line key (princ-to-string value) stream))) + +(defun maybe-add-charset-to-content-type-header (content-type external-format) + "Given the contents of a CONTENT-TYPE header, add a charset= + attribute describing the given EXTERNAL-FORMAT if no charset= + attribute is already present and the content type is a text content + type. Returns the augmented content type." + (if (and (cl-ppcre:scan "(?i)^text" content-type) + (not (cl-ppcre:scan "(?i);\\s*charset=" content-type))) + (format nil "~A; charset=~(~A~)" content-type (flex:external-format-name external-format)) + content-type)) + +(defun start-output (return-code &optional (content nil content-provided-p)) + "Sends all headers and maybe the content body to +*HUNCHENTOOT-STREAM*. Returns immediately and does nothing if called +more than once per request. Called by PROCESS-REQUEST and/or +SEND-HEADERS. The RETURN-CODE argument represents the integer return +code of the request. The corresponding reason phrase is determined by +calling the REASON-PHRASE function. The CONTENT provided represents +the body data to send to the client, if any. If it is not specified, +no body is written to the client. The handler function is expected to +directly write to the stream in this case. + +Returns the stream that is connected to the client." + (let* ((chunkedp (and (acceptor-output-chunking-p *acceptor*) + (eq (server-protocol *request*) :http/1.1) + ;; only turn chunking on if the content + ;; length is unknown at this point... + (null (or (content-length*) content-provided-p)))) + (request-method (request-method *request*)) + (head-request-p (eq request-method :head)) + content-modified-p) + (multiple-value-bind (keep-alive-p keep-alive-requested-p) + (keep-alive-p *request*) + (when keep-alive-p + (setq keep-alive-p + ;; use keep-alive if there's a way for the client to + ;; determine when all content is sent (or if there + ;; is no content) + (or chunkedp + head-request-p + (eql (return-code*) +http-not-modified+) + (content-length*) + content))) + ;; now set headers for keep-alive and chunking + (when chunkedp + (setf (header-out :transfer-encoding) "chunked")) + (cond (keep-alive-p + (setf *finish-processing-socket* nil) + (when (and (acceptor-read-timeout *acceptor*) + (or (not (eq (server-protocol *request*) :http/1.1)) + keep-alive-requested-p)) + ;; persistent connections are implicitly assumed for + ;; HTTP/1.1, but we return a 'Keep-Alive' header if the + ;; client has explicitly asked for one + (unless (header-out :connection) ; allowing for handler overriding + (setf (header-out :connection) "Keep-Alive")) + (setf (header-out :keep-alive) + (format nil "timeout=~D" (acceptor-read-timeout *acceptor*))))) + ((not (header-out-set-p :connection)) + (setf (header-out :connection) "Close")))) + (unless (and (header-out-set-p :server) + (null (header-out :server))) + (setf (header-out :server) (or (header-out :server) + (acceptor-server-name *acceptor*)))) + (setf (header-out :date) (rfc-1123-date)) + (when (and (stringp content) + (not content-modified-p) + (starts-with-one-of-p (or (content-type*) "") + *content-types-for-url-rewrite*)) + ;; if the Content-Type header starts with one of the strings + ;; in *CONTENT-TYPES-FOR-URL-REWRITE* then maybe rewrite the + ;; content + (setq content (maybe-rewrite-urls-for-session content))) + (when (stringp content) + ;; if the content is a string, convert it to the proper external format + (setf content (string-to-octets content :external-format (reply-external-format*)) + (content-type*) (maybe-add-charset-to-content-type-header (content-type*) + (reply-external-format*)))) + (when content + ;; whenever we know what we're going to send out as content, set + ;; the Content-Length header properly; maybe the user specified + ;; a different content length, but that will wrong anyway + (setf (header-out :content-length) (length content))) + ;; send headers only once + (when *headers-sent* + (return-from start-output)) + (setq *headers-sent* t) + (send-response *acceptor* + *hunchentoot-stream* + return-code + :headers (headers-out*) + :cookies (cookies-out*) + :content (unless head-request-p + content)) + ;; when processing a HEAD request, exit to return from PROCESS-REQUEST + (when head-request-p + (throw 'request-processed nil)) + (when chunkedp + ;; turn chunking on after the headers have been sent + (unless (typep *hunchentoot-stream* 'chunked-stream) + (setq *hunchentoot-stream* (make-chunked-stream *hunchentoot-stream*))) + (setf (chunked-stream-output-chunking-p *hunchentoot-stream*) t)) + *hunchentoot-stream*)) + +(defun send-response (acceptor stream status-code + &key headers cookies content) + "Send a HTTP response to the STREAM and log the event in ACCEPTOR. + STATUS-CODE is the HTTP status code used in the response. HEADERS + and COOKIES are used to create the response header. If CONTENT is + provided, it is sent as the response body. + + If *HEADER-STREAM* is not NIL, the response headers are written to + that stream when they are written to the client. + + STREAM is returned." + (when content + (setf (content-length*) (length content))) + (when (content-length*) + (if (assoc :content-length headers) + (setf (cdr (assoc :content-length headers)) (content-length*)) + (push (cons :content-length (content-length*)) headers))) + ;; access log message + (acceptor-log-access acceptor :return-code status-code) + ;; Read post data to clear stream - Force binary mode to avoid OCTETS-TO-STRING overhead. + (raw-post-data :force-binary t) + (let* ((client-header-stream (flex:make-flexi-stream stream :external-format +latin-1+)) + (header-stream (if *header-stream* + (make-broadcast-stream *header-stream* client-header-stream) + client-header-stream))) + ;; start with status line + (format header-stream "HTTP/1.1 ~D ~A~C~C" status-code (reason-phrase status-code) #\Return #\Linefeed) + ;; write all headers from the REPLY object + (loop for (key . value) in headers + when value + do (write-header-line (as-capitalized-string key) value header-stream)) + ;; now the cookies + (loop for (nil . cookie) in cookies + do (write-header-line "Set-Cookie" (stringify-cookie cookie) header-stream)) + (format header-stream "~C~C" #\Return #\Linefeed)) + ;; now optional content + (when content + (write-sequence content stream) + (finish-output stream)) + stream) + +(defun send-headers () + "Sends the initial status line and all headers as determined by the +REPLY object *REPLY*. Returns a binary stream to which the body of +the reply can be written. Once this function has been called, further +changes to *REPLY* don't have any effect. Also, automatic handling of +errors \(i.e. sending the corresponding status code to the browser, +etc.) is turned off for this request. If your handlers return the +full body as a string or as an array of octets you should NOT call +this function. + +This function does not return control to the caller during HEAD +request processing." + (start-output (return-code*))) + +(defun read-initial-request-line (stream) + "Reads and returns the initial HTTP request line, catching permitted +errors and handling *BREAK-EVEN-WHILE-READING-REQUEST-TYPE-P*. If no +request could be read, returns NIL. At this point, both an +end-of-file as well as a timeout condition are normal; end-of-file +will occur when the client has decided to not send another request but +to close the connection instead, a timeout indicates that the +connection timeout established by Hunchentoot has expired and we do +not want to wait for another request any longer." + (handler-case + (let ((*current-error-message* "While reading initial request line:")) + (with-mapped-conditions () + (read-line* stream))) + ((or end-of-file #-:lispworks usocket:timeout-error) ()))) + +(defun send-bad-request-response (stream &optional additional-info) + "Send a ``Bad Request'' response to the client." + (write-sequence (flex:string-to-octets + (format nil "HTTP/1.0 ~D ~A~C~CConnection: close~C~C~C~CYour request could not be interpreted by this HTTP server~C~C~@[~A~]~C~C" + +http-bad-request+ (reason-phrase +http-bad-request+) #\Return #\Linefeed + #\Return #\Linefeed #\Return #\Linefeed #\Return #\Linefeed additional-info #\Return #\Linefeed)) + stream)) + +(defun printable-ascii-char-p (char) + (<= 32 (char-code char) 126)) + +(defun get-request-data (stream) + "Reads incoming headers from the client via STREAM. Returns as +multiple values the headers as an alist, the method, the URI, and the +protocol of the request." + (with-character-stream-semantics + (let ((first-line (read-initial-request-line stream))) + (when first-line + (unless (every #'printable-ascii-char-p first-line) + (send-bad-request-response stream "Non-ASCII character in request line") + (return-from get-request-data nil)) + (destructuring-bind (&optional method url-string protocol) + (split "\\s+" first-line :limit 3) + (unless url-string + (send-bad-request-response stream) + (return-from get-request-data nil)) + (when *header-stream* + (format *header-stream* "~A~%" first-line)) + (let ((headers (and protocol (read-http-headers stream *header-stream*)))) + ;; maybe handle 'Expect: 100-continue' header + (when-let (expectations (cdr (assoc* :expect headers))) + (when (member "100-continue" (split "\\s*,\\s*" expectations) :test #'equalp) + ;; according to 14.20 in the RFC - we should actually + ;; check if we have to respond with 417 here + (let ((continue-line + (format nil "HTTP/1.1 ~D ~A" + +http-continue+ + (reason-phrase +http-continue+)))) + (write-sequence (map 'list #'char-code continue-line) stream) + (write-sequence +crlf+ stream) + (write-sequence +crlf+ stream) + (force-output stream) + (when *header-stream* + (format *header-stream* "~A~%" continue-line))))) + (values headers + (as-keyword method) + url-string + (if protocol + (as-keyword (trim-whitespace protocol)) + :http/0.9)))))))) diff --git a/deps/hunchentoot/hunchentoot.asd b/deps/hunchentoot/hunchentoot.asd new file mode 100644 index 0000000..e0c045a --- /dev/null +++ b/deps/hunchentoot/hunchentoot.asd @@ -0,0 +1,102 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- + +;;; 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 :hunchentoot-asd + (:use :cl :asdf)) + +(in-package :hunchentoot-asd) + +(defsystem :hunchentoot + :serial t + :version "1.2.38" + :description "Hunchentoot is a HTTP server based on USOCKET and + BORDEAUX-THREADS. It supports HTTP 1.1, serves static files, has a + simple framework for user-defined handlers and can be extended + through subclassing." + :license "BSD-2-Clause" + :depends-on (:chunga + :cl-base64 + :cl-fad + :cl-ppcre + :flexi-streams + #-(or :lispworks :hunchentoot-no-ssl) :cl+ssl + :md5 + :rfc2388 + :trivial-backtrace + #-:lispworks :usocket + #-:lispworks :bordeaux-threads) + :components ((:module url-rewrite + :serial t + :components ((:file "packages") + (:file "specials") + (:file "primitives") + (:file "util") + (:file "url-rewrite"))) + (:file "packages") + #+:lispworks (:file "lispworks") + #-:lispworks (:file "compat") + (:file "specials") + (:file "conditions") + (:file "mime-types") + (:file "util") + (:file "log") + (:file "cookie") + (:file "reply") + (:file "request") + (:file "session") + (:file "misc") + (:file "headers") + (:file "set-timeouts") + (:file "taskmaster") + (:file "acceptor") + #-:hunchentoot-no-ssl (:file "ssl") + (:file "easy-handlers"))) + +(defsystem :hunchentoot-test + :description "Self test functionality for the Hunchentoot HTTP server." + :components ((:module "test" + :serial t + :components ((:file "packages") + (:file "test-handlers") + (:file "script-engine") + (:file "script")))) + :depends-on (:hunchentoot :cl-who :cl-ppcre :drakma)) + +(defmethod perform ((o test-op) (c (eql (find-system 'hunchentoot)))) + (load (merge-pathnames "run-test.lisp" (system-source-directory c)))) + +(defsystem :hunchentoot-dev + :description "Development tools for Hunchentoot development and releases" + :components ((:file "make-docstrings")) + :depends-on (:hunchentoot + :hunchentoot-test + :xpath + :cxml-stp + :swank)) diff --git a/deps/hunchentoot/lispworks.lisp b/deps/hunchentoot/lispworks.lisp new file mode 100755 index 0000000..4fd20a3 --- /dev/null +++ b/deps/hunchentoot/lispworks.lisp @@ -0,0 +1,145 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*- + +;;; 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 :hunchentoot) + +(eval-when (:compile-toplevel :load-toplevel :execute) + ;; make sure socket code is loaded + (require "comm")) + +(defun get-env-variable-as-directory (name) + "Retrieves the environment variable named NAME and interprets it as +the pathname of a directory which is returned." + (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 "/")))))) + +(defmacro with-rebinding (bindings &body body) + "Renaming LW:REBINDING for better indentation." + `(lw:rebinding ,bindings ,@body)) + +#+(and :lispworks4.4 (or :win32 :linux)) +(let ((id :system-cons-free-chain)) + (unless (scm::patch-id-loaded-p id) + (error "You need a patch to improve the performance of this code. Request patch ~S for ~A for ~A from lisp-support@lispworks.com using the Report Bug command." + id (lisp-implementation-type) + #+:win32 "Windows" + #+:linux "Linux"))) + +(defvar *cleanup-interval* 100 + "Should be NIL or a positive integer. The system calls +*CLEANUP-FUNCTION* whenever *CLEANUP-INTERVAL* new worker threads +\(counted globally across all acceptors) have been created unless the +value is NIL. The initial value is 100. + +This variable is only available on LispWorks.") + +(defvar *cleanup-function* 'cleanup-function + "A designator for a function without arguments which is called on a +regular basis if *CLEANUP-INTERVAL* is not NIL. The initial value is +the name of a function which invokes a garbage collection on 32-bit +versions of LispWorks. + +This variable is only available on LispWorks.") + +(defvar *worker-counter* 0 + "Internal counter used to count worker threads. Needed for +*CLEANUP-FUNCTION*.") + +(defun cleanup-function () + "The default for *CLEANUP-FUNCTION*. Invokes a GC on 32-bit +LispWorks." + #-:lispworks-64bit + (hcl:mark-and-sweep 2)) + +(defun get-peer-address-and-port (socket) + "Returns the peer address and port of the socket SOCKET as two +values. The address is returned as a string in dotted IP address +notation." + (multiple-value-bind (peer-addr peer-port) + (comm:get-socket-peer-address socket) + (values (ignore-errors (comm:ip-address-string peer-addr)) peer-port))) + +(defun get-local-address-and-port (socket) + "Returns the local address and port of the socket SOCKET as two +values. The address is returned as a string in dotted IP address +notation." + (multiple-value-bind (local-addr local-port) + (comm:get-socket-address socket) + (values (ignore-errors (comm:ip-address-string local-addr)) local-port))) + +(eval-when (:compile-toplevel :load-toplevel) + (when (let ((sym (find-symbol "STREAM-READ-TIMEOUT" :stream))) + (and sym (fboundp sym))) + (pushnew :stream-has-timeouts *features*))) + +(defun make-socket-stream (socket acceptor) + "Returns a stream for the socket SOCKET. The ACCEPTOR argument is +used to set the timeouts." + #-stream-has-timeouts + (when (acceptor-write-timeout acceptor) + (parameter-error "You need LispWorks 5 or higher for write timeouts.")) + (make-instance 'comm:socket-stream + :socket socket + :direction :io + :read-timeout (acceptor-read-timeout acceptor) + #+stream-has-timeouts #+stream-has-timeouts + :write-timeout (acceptor-write-timeout acceptor) + :element-type 'octet)) + +(defun make-lock (name) + "Simple wrapper to allow LispWorks and Bordeaux Threads to coexist." + (mp:make-lock :name name)) + +(defmacro with-lock-held ((lock) &body body) + "Simple wrapper to allow LispWorks and Bordeaux Threads to coexist." + `(mp:with-lock (,lock) ,@body)) + +;; some help for the IDE +(dspec:define-dspec-alias defvar-unbound (name) + `(defparameter ,name)) + +(dspec:define-dspec-alias def-http-return-code (name) + `(defconstant ,name)) + +(editor:setup-indent "defvar-unbound" 1 2 4) + +(editor:setup-indent "def-http-return-code" 1 2 4) + +(editor:setup-indent "handler-case*" 1 2 4) + +(defun make-condition-variable (&key name) + (declare (ignore name)) + (mp:make-condition-variable)) + +(defun condition-variable-signal (condition-variable) + (mp:condition-variable-signal condition-variable)) + +(defun condition-variable-wait (condition-variable lock) + (mp:condition-variable-wait condition-variable lock)) diff --git a/deps/hunchentoot/log.lisp b/deps/hunchentoot/log.lisp new file mode 100644 index 0000000..d761692 --- /dev/null +++ b/deps/hunchentoot/log.lisp @@ -0,0 +1,66 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*- + +;;; 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 :hunchentoot) + +(defmacro with-log-stream ((stream-var destination lock) &body body) + "Helper macro to write log entries. STREAM-VAR is a symbol that +will be bound to the logging stream during the execution of BODY. +DESTINATION is the logging destination, which can be either a pathname +designator of the log file, a symbol designating an open stream or NIL +if no logging should be done. LOCK refers to the lock that should be +held during the logging operation. If DESTINATION is a pathname, a +flexi stream with UTF-8 encoding will be created and bound to +STREAM-VAR. If an error occurs while writing to the log file, that +error will be logged to *ERROR-OUTPUT*. + +Note that logging to a file involves opening and closing the log file +for every logging operation, which is overall costly. Web servers +with high throughput demands should make use of a specialized logging +function rather than relying on Hunchentoot's default logging +facility." + (with-unique-names (binary-stream) + (with-rebinding (destination) + (let ((body body)) + `(when ,destination + (with-lock-held (,lock) + (etypecase ,destination + ((or string pathname) + (with-open-file (,binary-stream ,destination + :direction :output + :element-type 'octet + :if-does-not-exist :create + :if-exists :append + #+:openmcl :sharing #+:openmcl :lock) + (let ((,stream-var (make-flexi-stream ,binary-stream :external-format +utf-8+))) + ,@body))) + (stream + (let ((,stream-var ,destination)) + (prog1 (progn ,@body) + (finish-output ,destination))))))))))) + diff --git a/deps/hunchentoot/make-docstrings.lisp b/deps/hunchentoot/make-docstrings.lisp new file mode 100644 index 0000000..993a295 --- /dev/null +++ b/deps/hunchentoot/make-docstrings.lisp @@ -0,0 +1,228 @@ +;; -*- Lisp -*- + +(defpackage :make-docstrings + (:use :cl) + (:export #:parse-doc)) + +(in-package :make-docstrings) + +(defclass formatting-stream (trivial-gray-streams:fundamental-character-input-stream) + ((understream :initarg :understream + :reader understream) + (width :initarg :width + :initform (error "missing :width argument to formatting-stream creation") + :reader width) + (column :initform 0 + :accessor column) + (word-wrap-p :initform t + :accessor word-wrap-p) + (word-buffer :initform (make-array 1000 + :element-type 'character + :adjustable t + :fill-pointer 0) + :reader word-buffer))) + +(defun write-char% (char stream) + (incf (column stream)) + (write-char char (understream stream))) + +(defun print-newline (stream) + (write-char #\Newline (understream stream)) + (setf (column stream) 0)) + +(defun buffer-not-empty-p (stream) + (plusp (length (word-buffer stream)))) + +(defun maybe-flush-word (stream) + (when (buffer-not-empty-p stream) + (cond + ((< (width stream) (+ (column stream) (length (word-buffer stream)))) + (print-newline stream)) + ((plusp (column stream)) + (write-char% #\Space stream))) + (loop for char across (word-buffer stream) + do (write-char% char stream)) + (setf (fill-pointer (word-buffer stream)) 0))) + +(defmethod trivial-gray-streams:stream-write-char ((stream formatting-stream) char) + (if (word-wrap-p stream) + (cond + ((eql #\Space char) + (maybe-flush-word stream)) + ((eql #\Newline char) + (maybe-flush-word stream) + (print-newline stream)) + (t + (vector-push-extend char (word-buffer stream)))) + (write-char char (understream stream)))) + +(defmethod trivial-gray-streams:stream-line-column (stream) + (+ (column stream) (length (word-buffer stream)))) + +(defmethod trivial-gray-streams:stream-write-string ((stream formatting-stream) string &optional start end) + (loop for i from (or start 0) below (or end (length string)) + do (write-char (char string i) stream))) + +(defmethod trivial-gray-streams:stream-terpri ((stream formatting-stream)) + (write-char #\Newline stream)) + +(defmethod close ((stream formatting-stream) &key abort) + (unless abort + (maybe-flush-word stream))) + +(defmethod (setf word-wrap-p) :before (new-value (stream formatting-stream)) + (maybe-flush-word stream) + (when (buffer-not-empty-p stream) + (print-newline stream))) + +(defun test-wrap-stream (text) + (with-output-to-string (s) + (with-open-stream (s (make-instance 'formatting-stream :understream s :width 20)) + (write-string text s) + (setf (word-wrap-p s) nil) + (format s "~&OFF~%") + (write-string text s) + (format s "~&ON~%") + (setf (word-wrap-p s) t) + (write-string text s)))) + +(defmacro replace-regexp (place regex replacement) + `(setf ,place (cl-ppcre:regex-replace-all ,regex ,place ,replacement))) + +(defun collapse-whitespace (string) + (replace-regexp string "[ \\t]*\\n[ \\t]*" #.(make-string 1 :initial-element #\Newline)) + (replace-regexp string "(?= mismatch (length prefix))) + handler)))) + +(defun create-regex-dispatcher (regex handler) + "Creates a request dispatch function which will dispatch to the +function denoted by HANDLER if the file name of the current request +matches the CL-PPCRE regular expression REGEX." + (let ((scanner (create-scanner regex))) + (lambda (request) + (and (scan scanner (script-name request)) + handler)))) + +(defun abort-request-handler (&optional result) + "This function can be called by a request handler at any time to +immediately abort handling the request. This works as if the handler +had returned RESULT. See the source code of REDIRECT for an example." + (throw 'handler-done result)) + +(defun maybe-handle-range-header (file) + "Helper function for handle-static-file. Determines whether the + requests specifies a Range header. If so, parses the header and + position the already opened file to the location specified. Returns + the number of bytes to transfer from the file. Invalid specified + ranges are reported to the client with a HTTP 416 status code." + (let ((bytes-to-send (file-length file))) + (cl-ppcre:register-groups-bind + (start end) + ("^bytes=(\\d+)-(\\d*)$" (header-in* :range) :sharedp t) + ;; body won't be executed if regular expression does not match + (setf start (parse-integer start)) + (setf end (if (> (length end) 0) + (parse-integer end) + (1- (file-length file)))) + (when (or (< start 0) + (>= end (file-length file))) + (setf (return-code*) +http-requested-range-not-satisfiable+ + (header-out :content-range) (format nil "bytes 0-~D/~D" (1- (file-length file)) (file-length file))) + (throw 'handler-done + (format nil "invalid request range (requested ~D-~D, accepted 0-~D)" + start end (1- (file-length file))))) + (file-position file start) + (setf (return-code*) +http-partial-content+ + bytes-to-send (1+ (- end start)) + (header-out :content-range) (format nil "bytes ~D-~D/~D" start end (file-length file)))) + bytes-to-send)) + +(defun handle-static-file (pathname &optional content-type) + "A function which acts like a Hunchentoot handler for the file +denoted by PATHNAME. Sends a content type header corresponding to +CONTENT-TYPE or \(if that is NIL) tries to determine the content type +via the file's suffix." + (when (or (wild-pathname-p pathname) + (not (fad:file-exists-p pathname)) + (fad:directory-exists-p pathname)) + ;; file does not exist + (setf (return-code*) +http-not-found+) + (abort-request-handler)) + (unless content-type + (setf content-type (mime-type pathname))) + (let ((time (or (file-write-date pathname) + (get-universal-time))) + bytes-to-send) + (setf (content-type*) (or (and content-type + (maybe-add-charset-to-content-type-header content-type (reply-external-format*))) + "application/octet-stream") + (header-out :last-modified) (rfc-1123-date time) + (header-out :accept-ranges) "bytes") + (handle-if-modified-since time) + (with-open-file (file pathname + :direction :input + :element-type 'octet) + (setf bytes-to-send (maybe-handle-range-header file) + (content-length*) bytes-to-send) + (let ((out (send-headers)) + (buf (make-array +buffer-length+ :element-type 'octet))) + (loop + (when (zerop bytes-to-send) + (return)) + (let* ((chunk-size (min +buffer-length+ bytes-to-send))) + (unless (eql chunk-size (read-sequence buf file :end chunk-size)) + (error "can't read from input file")) + (write-sequence buf out :end chunk-size) + (decf bytes-to-send chunk-size))) + (finish-output out))))) + +(defun create-static-file-dispatcher-and-handler (uri path &optional content-type) + "Creates and returns a request dispatch function which will dispatch +to a handler function which emits the file denoted by the pathname +designator PATH with content type CONTENT-TYPE if the SCRIPT-NAME of +the request matches the string URI. If CONTENT-TYPE is NIL, tries to +determine the content type via the file's suffix." + ;; the dispatcher + (lambda (request) + (when (string= (script-name request) uri) + ;; the handler + (lambda () + (handle-static-file path content-type))))) + +(defun create-folder-dispatcher-and-handler (uri-prefix base-path &optional content-type) + "Creates and returns a dispatch function which will dispatch to a +handler function which emits the file relative to BASE-PATH that is +denoted by the URI of the request relative to URI-PREFIX. URI-PREFIX +must be a string ending with a slash, BASE-PATH must be a pathname +designator for an existing directory. If CONTENT-TYPE is not NIL, +it'll be the content type used for all files in the folder." + (unless (and (stringp uri-prefix) + (plusp (length uri-prefix)) + (char= (char uri-prefix (1- (length uri-prefix))) #\/)) + (parameter-error "~S must be string ending with a slash." uri-prefix)) + (unless (fad:directory-pathname-p base-path) + (parameter-error "~S is supposed to denote a directory." base-path)) + (flet ((handler () + (let ((request-path (request-pathname *request* uri-prefix))) + (when (null request-path) + (setf (return-code*) +http-forbidden+) + (abort-request-handler)) + (handle-static-file (merge-pathnames request-path base-path) content-type)))) + (create-prefix-dispatcher uri-prefix #'handler))) + +(defun no-cache () + "Adds appropriate headers to completely prevent caching on most browsers." + (setf (header-out :expires) + "Mon, 26 Jul 1997 05:00:00 GMT" + (header-out :cache-control) + "no-store, no-cache, must-revalidate, post-check=0, pre-check=0" + (header-out :pragma) + "no-cache" + (header-out :last-modified) + (rfc-1123-date)) + (values)) + +(defun redirect (target &key (host (host *request*) host-provided-p) + port + (protocol (if (ssl-p) :https :http)) + (add-session-id (not (or host-provided-p + (starts-with-scheme-p target) + (cookie-in (session-cookie-name *acceptor*))))) + (code +http-moved-temporarily+)) + "Redirects the browser to TARGET which should be a string. If +TARGET is a full URL starting with a scheme, HOST, PORT and PROTOCOL +are ignored. Otherwise, TARGET should denote the path part of a URL, +PROTOCOL must be one of the keywords :HTTP or :HTTPS, and the URL to +redirect to will be constructed from HOST, PORT, PROTOCOL, and TARGET. +Adds a session ID if ADD-SESSION-ID is true. If CODE is a 3xx +redirection code, it will be sent as status code." + (check-type code (integer 300 399)) + (let ((url (if (starts-with-scheme-p target) + target + (format nil "~A://~A~@[:~A~]~A" + (ecase protocol + ((:http) "http") + ((:https) "https")) + (if port + (first (ppcre:split ":" (or host ""))) + host) + port target)))) + (when add-session-id + (setq url (add-cookie-value-to-url url :replace-ampersands-p nil))) + (setf (header-out :location) url + (return-code*) code) + (abort-request-handler))) + +(defun require-authorization (&optional (realm "Hunchentoot")) + "Sends back appropriate headers to require basic HTTP authentication +\(see RFC 2617) for the realm REALM." + (setf (header-out :www-authenticate) + (format nil "Basic realm=\"~A\"" (quote-string realm)) + (return-code *reply*) + +http-authorization-required+) + (abort-request-handler)) diff --git a/deps/hunchentoot/packages.lisp b/deps/hunchentoot/packages.lisp new file mode 100644 index 0000000..b88ae37 --- /dev/null +++ b/deps/hunchentoot/packages.lisp @@ -0,0 +1,295 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- + +;;; 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 #:hunchentoot + (:nicknames #:tbnl) + (:use :cl :cl-ppcre :chunga :flexi-streams :url-rewrite) + (:shadow #:defconstant + #:url-encode) + #+:lispworks + (:import-from :lw #:with-unique-names #:when-let) + (:export #:*acceptor* + #:*catch-errors-p* + #+:lispworks + #:*cleanup-function* + #+:lispworks + #:*cleanup-interval* + #:*content-types-for-url-rewrite* + #:*default-connection-timeout* + #:*default-content-type* + #:*dispatch-table* + #:*file-upload-hook* + #:*handle-http-errors-p* + #:*header-stream* + #:*http-error-handler* + #:*hunchentoot-default-external-format* + #:*hunchentoot-version* + #:*lisp-errors-log-level* + #:*lisp-warnings-log-level* + #:*log-lisp-backtraces-p* + #:*log-lisp-errors-p* + #:*log-lisp-warnings-p* + #:*methods-for-post-parameters* + #:*reply* + #:*request* + #:*rewrite-for-session-urls* + #:*session* + #:*session-gc-frequency* + #:*session-max-time* + #:*session-secret* + #:*show-lisp-backtraces-p* + #:*show-lisp-errors-p* + #:*tmp-directory* + #:*use-remote-addr-for-sessions* + #:*use-user-agent-for-sessions* + #:+http-accepted+ + #:+http-authorization-required+ + #:+http-bad-gateway+ + #:+http-bad-request+ + #:+http-conflict+ + #:+http-continue+ + #:+http-created+ + #:+http-expectation-failed+ + #:+http-failed-dependency+ + #:+http-forbidden+ + #:+http-gateway-time-out+ + #:+http-gone+ + #:+http-internal-server-error+ + #:+http-length-required+ + #:+http-method-not-allowed+ + #:+http-moved-permanently+ + #:+http-moved-temporarily+ + #:+http-multi-status+ + #:+http-multiple-choices+ + #:+http-network-authentication-required+ + #:+http-no-content+ + #:+http-non-authoritative-information+ + #:+http-not-acceptable+ + #:+http-not-found+ + #:+http-not-implemented+ + #:+http-not-modified+ + #:+http-ok+ + #:+http-partial-content+ + #:+http-payment-required+ + #:+http-precondition-failed+ + #:+http-precondition-required+ + #:+http-proxy-authentication-required+ + #:+http-request-entity-too-large+ + #:+http-request-header-fields-too-large+ + #:+http-request-time-out+ + #:+http-request-uri-too-large+ + #:+http-requested-range-not-satisfiable+ + #:+http-reset-content+ + #:+http-see-other+ + #:+http-service-unavailable+ + #:+http-switching-protocols+ + #:+http-temporary-redirect+ + #:+http-too-many-requests+ + #:+http-unsupported-media-type+ + #:+http-use-proxy+ + #:+http-version-not-supported+ + #:abort-request-handler + #:accept-connections + #:acceptor + #:acceptor-access-log-destination + #:acceptor-address + #:acceptor-listen-backlog + #:acceptor-dispatch-request + #:acceptor-error-template-directory + #:acceptor-input-chunking-p + #:acceptor-log-access + #:acceptor-log-message + #:acceptor-message-log-destination + #:acceptor-name + #:acceptor-output-chunking-p + #:acceptor-persistent-connections-p + #:acceptor-port + #:acceptor-read-timeout + #:acceptor-remove-session + #:acceptor-reply-class + #:acceptor-request-class + #:acceptor-ssl-p + #-:hunchentoot-no-ssl #:acceptor-ssl-certificate-file + #-:hunchentoot-no-ssl #:acceptor-ssl-privatekey-file + #-:hunchentoot-no-ssl #:acceptor-ssl-privatekey-password + #:acceptor-status-message + #:acceptor-write-timeout + #:acceptor-document-root + #:acceptor-error-template-directory + #:authorization + #:aux-request-value + #:client-as-string + #:content-length + #:content-length* + #:content-type + #:content-type* + #:cookie-domain + #:cookie-expires + #:cookie-http-only + #:cookie-in + #:cookie-max-age + #:cookie-name + #:cookie-out + #:cookie-path + #:cookie-secure + #:cookie-value + #:cookies-in + #:cookies-in* + #:cookies-out + #:cookies-out* + #:create-folder-dispatcher-and-handler + #:create-prefix-dispatcher + #:create-regex-dispatcher + #:create-request-handler-thread + #:create-static-file-dispatcher-and-handler + #:decrement-taskmaster-thread-count + #:default-document-directory + #:define-easy-handler + #:delete-aux-request-value + #:delete-session-value + #:dispatch-easy-handlers + #:easy-acceptor + #-:hunchentoot-no-ssl #:easy-ssl-acceptor + #:escape-for-html + #:execute-acceptor + #:get-parameter + #:get-parameters + #:get-parameters* + #:handle-incoming-connection + #:handle-if-modified-since + #:handle-request + #:handle-static-file + #:header-in + #:header-in* + #:header-out + #:headers-in + #:headers-in* + #:headers-out + #:headers-out* + #:host + #:http-token-p + #:hunchentoot-condition + #:hunchentoot-error + #:hunchentoot-warning + #:increment-taskmaster-thread-count + #:initialize-connection-stream + #:log-message* + #:maybe-invoke-debugger + #:mime-type + #:multi-threaded-taskmaster + #:next-session-id + #:no-cache + #:one-thread-per-connection-taskmaster + #:parameter + #:parameter-error + #:post-parameter + #:post-parameters + #:post-parameters* + #:process-connection + #:process-request + #:query-string + #:query-string* + #:raw-post-data + #:real-remote-addr + #:reason-phrase + #:recompute-request-parameters + #:redirect + #:referer + #:regenerate-session-cookie-value + #:remote-addr + #:remote-addr* + #:remote-port + #:remote-port* + #:local-addr + #:local-addr* + #:local-port + #:local-port* + #:remove-session + #:reply + #:reply-external-format + #:reply-external-format* + #:request + #:request-acceptor + #:request-method + #:request-method* + #:request-pathname + #:request-uri + #:request-uri* + #:require-authorization + #:reset-connection-stream + #:reset-sessions + #:reset-session-secret + #:return-code + #:return-code* + #:rfc-1123-date + #:script-name + #:script-name* + #:send-headers + #:server-protocol + #:server-protocol* + #:session + #:session-cookie-name + #:session-cookie-value + #:session-created + #:session-db + #:session-db-lock + #:session-gc + #:session-id + #:session-max-time + #:session-remote-addr + #:session-start + #:session-too-old-p + #:session-user-agent + #:session-value + #:session-verify + #:set-cookie + #:set-cookie* + #:shutdown + #:single-threaded-taskmaster + #-:hunchentoot-no-ssl #:ssl-acceptor + #:ssl-p + #:start + #:start-listening + #:start-session + #:start-thread + #:started-p + #:stop + #:taskmaster + #:taskmaster-acceptor + #:taskmaster-max-accept-count + #:taskmaster-max-thread-count + #:taskmaster-thread-count + #:too-many-taskmaster-requests + #:url-decode + #:url-encode + #:user-agent + #:within-request-p + #:detach-socket + #:bad-request)) diff --git a/deps/hunchentoot/release-checklist.txt b/deps/hunchentoot/release-checklist.txt new file mode 100644 index 0000000..afef4bb --- /dev/null +++ b/deps/hunchentoot/release-checklist.txt @@ -0,0 +1,5 @@ +What do do for a release: + +Update version number in hunchentoot.asd and doc/index.xml +Update CHANGELOG (keep format) +Create html documentation (cd doc; make) diff --git a/deps/hunchentoot/reply.lisp b/deps/hunchentoot/reply.lisp new file mode 100644 index 0000000..194d5d4 --- /dev/null +++ b/deps/hunchentoot/reply.lisp @@ -0,0 +1,157 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*- + +;;; 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 :hunchentoot) + +(defclass reply () + ((content-type :reader content-type + :documentation "The outgoing 'Content-Type' http +header which defaults to the value of *DEFAULT-CONTENT-TYPE*.") + (content-length :reader content-length + :initform nil + :documentation "The outgoing 'Content-Length' +http header which defaults NIL. If this is NIL, Hunchentoot will +compute the content length.") + (headers-out :initform nil + :reader headers-out + :documentation "An alist of the outgoing http headers +not including the 'Set-Cookie', 'Content-Length', and 'Content-Type' +headers. Use the functions HEADER-OUT and \(SETF HEADER-OUT) to +modify this slot.") + (return-code :initform +http-ok+ + :accessor return-code + :documentation "The http return code of this +reply. The return codes Hunchentoot can handle are defined in +specials.lisp.") + (external-format :initform *hunchentoot-default-external-format* + :accessor reply-external-format + :documentation "The external format of the reply - +used for character output.") + (cookies-out :initform nil + :accessor cookies-out + :documentation "The outgoing cookies. This slot's +value should only be modified by the functions defined in +cookies.lisp.")) + (:documentation "Objects of this class hold all the information +about an outgoing reply. They are created automatically by +Hunchentoot and can be accessed and modified by the corresponding +handler. + +You should not mess with the slots of these objects directly, but you +can subclass REPLY in order to implement your own behaviour. See the +REPLY-CLASS slot of the ACCEPTOR class.")) + +(defmethod initialize-instance :after ((reply reply) &key) + (setf (header-out :content-type reply) *default-content-type*)) + +(defun headers-out* (&optional (reply *reply*)) + "Returns an alist of the outgoing headers associated with the +REPLY object REPLY." + (headers-out reply)) + +(defun cookies-out* (&optional (reply *reply*)) + "Returns an alist of the outgoing cookies associated with the +REPLY object REPLY." + (cookies-out reply)) + +(defun (setf cookies-out*) (new-value &optional (reply *reply*)) + "Sets the alist of the outgoing cookies associated with the REPLY +object REPLY." + (setf (cookies-out reply) new-value)) + +(defun content-type* (&optional (reply *reply*)) + "The outgoing 'Content-Type' http header of REPLY." + (content-type reply)) + +(defun (setf content-type*) (new-value &optional (reply *reply*)) + "Sets the outgoing 'Content-Type' http header of REPLY." + (setf (header-out :content-type reply) new-value)) + +(defun content-length* (&optional (reply *reply*)) + "The outgoing 'Content-Length' http header of REPLY." + (content-length reply)) + +(defun (setf content-length*) (new-value &optional (reply *reply*)) + "Sets the outgoing 'Content-Length' http header of REPLY." + (setf (header-out :content-length reply) new-value)) + +(defun return-code* (&optional (reply *reply*)) + "The http return code of REPLY. The return codes Hunchentoot can +handle are defined in specials.lisp." + (return-code reply)) + +(defun (setf return-code*) (new-value &optional (reply *reply*)) + "Sets the http return code of REPLY." + (setf (return-code reply) new-value)) + +(defun reply-external-format* (&optional (reply *reply*)) + "The external format of REPLY which is used for character output." + (reply-external-format reply)) + +(defun (setf reply-external-format*) (new-value &optional (reply *reply*)) + "Sets the external format of REPLY." + (setf (reply-external-format reply) new-value)) + +(defun header-out-set-p (name &optional (reply *reply*)) + "Returns a true value if the outgoing http header named NAME has +been specified already. NAME should be a keyword or a string." + (assoc* name (headers-out reply))) + +(defun header-out (name &optional (reply *reply*)) + "Returns the current value of the outgoing http header named NAME. +NAME should be a keyword or a string." + (cdr (assoc name (headers-out reply)))) + +(defun cookie-out (name &optional (reply *reply*)) + "Returns the current value of the outgoing cookie named +NAME. Search is case-sensitive." + (cdr (assoc name (cookies-out reply) :test #'string=))) + +(defgeneric (setf header-out) (new-value name &optional reply) + (:documentation "Changes the current value of the outgoing http +header named NAME \(a keyword or a string). If a header with this +name doesn't exist, it is created.") + (:method (new-value (name symbol) &optional (reply *reply*)) + ;; the default method + (let ((entry (assoc name (headers-out reply)))) + (if entry + (setf (cdr entry) new-value) + (setf (slot-value reply 'headers-out) + (acons name new-value (headers-out reply)))) + new-value)) + (:method (new-value (name string) &optional (reply *reply*)) + "If NAME is a string, it is converted to a keyword first." + (setf (header-out (as-keyword name :destructivep nil) reply) new-value)) + (:method :after (new-value (name (eql :content-length)) &optional (reply *reply*)) + "Special case for the `Content-Length' header." + (check-type new-value integer) + (setf (slot-value reply 'content-length) new-value)) + (:method :after (new-value (name (eql :content-type)) &optional (reply *reply*)) + "Special case for the `Content-Type' header." + (check-type new-value (or null string)) + (setf (slot-value reply 'content-type) new-value))) diff --git a/deps/hunchentoot/request.lisp b/deps/hunchentoot/request.lisp new file mode 100644 index 0000000..75d4aa0 --- /dev/null +++ b/deps/hunchentoot/request.lisp @@ -0,0 +1,622 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*- + +;;; 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 :hunchentoot) + +(defclass request () + ((acceptor :initarg :acceptor + :documentation "The acceptor which created this request +object." + :reader request-acceptor) + (headers-in :initarg :headers-in + :documentation "An alist of the incoming headers." + :reader headers-in) + (method :initarg :method + :documentation "The request method as a keyword." + :reader request-method) + (uri :initarg :uri + :documentation "The request URI as a string." + :reader request-uri) + (server-protocol :initarg :server-protocol + :documentation "The HTTP protocol as a keyword." + :reader server-protocol) + (local-addr :initarg :local-addr + :documentation "The IP address of the local system +that the client connected to." + :reader local-addr) + (local-port :initarg :local-port + :documentation "The TCP port number of the local +system that the client connected to." + :reader local-port) + (remote-addr :initarg :remote-addr + :documentation "The IP address of the client that +initiated this request." + :reader remote-addr) + (remote-port :initarg :remote-port + :documentation "The TCP port number of the client +socket from which this request originated." + :reader remote-port) + (content-stream :initarg :content-stream + :reader content-stream + :documentation "A stream from which the request +body can be read if there is one.") + (cookies-in :initform nil + :documentation "An alist of the cookies sent by the client." + :reader cookies-in) + (get-parameters :initform nil + :documentation "An alist of the GET parameters sent +by the client." + :reader get-parameters) + (post-parameters :initform nil + :documentation "An alist of the POST parameters +sent by the client." + :reader post-parameters) + (script-name :initform nil + :documentation "The URI requested by the client without +the query string." + :reader script-name) + (query-string :initform nil + :documentation "The query string of this request." + :reader query-string) + (session :initform nil + :accessor session + :documentation "The session object associated with this +request.") + (aux-data :initform nil + :accessor aux-data + :documentation "Used to keep a user-modifiable alist with +arbitrary data during the request.") + (raw-post-data :initform nil + :documentation "The raw string sent as the body of a +POST request, populated only if not a multipart/form-data request.")) + (:documentation "Objects of this class hold all the information +about an incoming request. They are created automatically by +acceptors and can be accessed by the corresponding handler. + +You should not mess with the slots of these objects directly, but you +can subclass REQUEST in order to implement your own behaviour. See +the REQUEST-CLASS slot of the ACCEPTOR class.")) + +(defgeneric process-request (request) + (:documentation "This function is called by PROCESS-CONNECTION after +the incoming headers have been read. It calls HANDLE-REQUEST to +select and call a handler and sends the output of this handler to the +client using START-OUTPUT. Note that PROCESS-CONNECTION is called +once per connection and loops in case of a persistent connection while +PROCESS-REQUEST is called anew for each request. + +Essentially, you can view process-request as a thin wrapper around +HANDLE-REQUEST. + +The return value of this function is ignored.")) + +(defun convert-hack (string external-format) + "The rfc2388 package is buggy in that it operates on a character +stream and thus only accepts encodings which are 8 bit transparent. +In order to support different encodings for parameter values +submitted, we post process whatever string values the rfc2388 package +has returned." + (flex:octets-to-string (map '(vector (unsigned-byte 8) *) 'char-code string) + :external-format external-format)) + +(defun parse-rfc2388-form-data (stream content-type-header external-format) + "Creates an alist of POST parameters from the stream STREAM which is +supposed to be of content type 'multipart/form-data'." + (let* ((parsed-content-type-header (rfc2388:parse-header content-type-header :value)) + (boundary (or (cdr (rfc2388:find-parameter + "BOUNDARY" + (rfc2388:header-parameters parsed-content-type-header))) + (return-from parse-rfc2388-form-data)))) + (loop for part in (rfc2388:parse-mime stream boundary) + for headers = (rfc2388:mime-part-headers part) + for content-disposition-header = (rfc2388:find-content-disposition-header headers) + for name = (cdr (rfc2388:find-parameter + "NAME" + (rfc2388:header-parameters content-disposition-header))) + when name + collect (cons (convert-hack name external-format) + (let ((contents (rfc2388:mime-part-contents part))) + (if (pathnamep contents) + (list contents + (convert-hack (rfc2388:get-file-name headers) external-format) + (rfc2388:content-type part :as-string t)) + (convert-hack contents external-format))))))) + +(defun get-post-data (&key (request *request*) want-stream (already-read 0)) + "Reads the request body from the stream and stores the raw contents +\(as an array of octets) in the corresponding slot of the REQUEST +object. Returns just the stream if WANT-STREAM is true. If there's a +Content-Length header, it is assumed, that ALREADY-READ octets have +already been read." + (let* ((headers-in (headers-in request)) + (content-length (when-let (content-length-header (cdr (assoc :content-length headers-in + :test #'eq))) + (parse-integer content-length-header :junk-allowed t))) + (content-stream (content-stream request))) + (setf (slot-value request 'raw-post-data) + (cond (want-stream + (let ((stream (make-flexi-stream content-stream :external-format +latin-1+))) + (when content-length + (setf (flexi-stream-bound stream) content-length)) + stream)) + ((and content-length (> content-length already-read)) + (decf content-length already-read) + (when (input-chunking-p) + ;; see RFC 2616, section 4.4 + (log-message* :warning "Got Content-Length header although input chunking is on.")) + (let ((content (make-array content-length :element-type 'octet))) + (read-sequence content content-stream) + content)) + ((input-chunking-p) + (loop with buffer = (make-array +buffer-length+ :element-type 'octet) + with content = (make-array 0 :element-type 'octet :adjustable t) + for index = 0 then (+ index pos) + for pos = (read-sequence buffer content-stream) + do (adjust-array content (+ index pos)) + (replace content buffer :start1 index :end2 pos) + while (= pos +buffer-length+) + finally (return content))))))) + +(defmethod initialize-instance :after ((request request) &rest init-args) + "The only initarg for a REQUEST object is :HEADERS-IN. All other +slot values are computed in this :AFTER method." + (declare (ignore init-args)) + (with-slots (headers-in cookies-in get-parameters script-name query-string session) + request + (handler-case* + (let* ((uri (request-uri request)) + (match-start (position #\? uri)) + (external-format (or (external-format-from-content-type (cdr (assoc* :content-type headers-in))) + +utf-8+))) + (cond + (match-start + (setq script-name (url-decode (subseq uri 0 match-start) external-format) + query-string (subseq uri (1+ match-start)))) + (t (setq script-name (url-decode uri external-format)))) + ;; some clients (e.g. ASDF-INSTALL) send requests like + ;; "GET http://server/foo.html HTTP/1.0"... + (setq script-name (regex-replace "^https?://[^/]+" script-name "")) + ;; compute GET parameters from query string and cookies from + ;; the incoming 'Cookie' header + (setq get-parameters + (let ((*substitution-char* #\?)) + (form-url-encoded-list-to-alist (split "&" query-string) external-format)) + cookies-in + (cookies-to-alist (split "\\s*[,;]\\s*" (cdr (assoc :cookie headers-in + :test #'eq)))) + session (session-verify request) + *session* session)) + (error (condition) + (log-message* :error "Error when creating REQUEST object: ~A" condition) + ;; we assume it's not our fault... + (setf (return-code*) +http-bad-request+))))) + +(defmethod process-request (request) + "Standard implementation for processing a request." + (catch 'request-processed ; used by HTTP HEAD handling to end request processing in a HEAD request (see START-OUTPUT) + (let (*tmp-files* + *headers-sent* + (*request* request)) + (unwind-protect + (with-mapped-conditions () + (labels + ((report-error-to-client (error &optional backtrace) + (when *log-lisp-errors-p* + (log-message* *lisp-errors-log-level* "~A~@[~%~A~]" error (when *log-lisp-backtraces-p* + backtrace))) + (start-output +http-internal-server-error+ + (acceptor-status-message *acceptor* + +http-internal-server-error+ + :error (princ-to-string error) + :backtrace (princ-to-string backtrace))))) + (multiple-value-bind (contents error backtrace) + ;; skip dispatch if bad request + (when (eql (return-code *reply*) +http-ok+) + (catch 'handler-done + (handle-request *acceptor* *request*))) + (when error + ;; error occurred in request handler + (report-error-to-client error backtrace)) + (unless *headers-sent* + (handler-case + (with-debugger + (start-output (return-code *reply*) + (or contents + (acceptor-status-message *acceptor* + (return-code *reply*))))) + (error (e) + ;; error occurred while writing to the client. attempt to report. + (report-error-to-client e))))))) + (dolist (path *tmp-files*) + (when (and (pathnamep path) (probe-file path)) + ;; the handler may have chosen to (re)move the uploaded + ;; file, so ignore errors that happen during deletion + (ignore-errors* + (delete-file path)))))))) + +(defun within-request-p () + "True if we're in the context of a request, otherwise nil." + (and (boundp '*request*) *request*)) + +(defun parse-multipart-form-data (request external-format) + "Parse the REQUEST body as multipart/form-data, assuming that its +content type has already been verified. Returns the form data as +alist or NIL if there was no data or the data could not be parsed." + (handler-case* + (let ((content-stream (make-flexi-stream (content-stream request) :external-format +latin-1+))) + (prog1 + (parse-rfc2388-form-data content-stream (header-in :content-type request) external-format) + (let ((stray-data (get-post-data :already-read (flexi-stream-position content-stream)))) + (when (and stray-data (plusp (length stray-data))) + (hunchentoot-warn "~A octets of stray data after form-data sent by client." + (length stray-data)))))) + (error (condition) + (log-message* :error "While parsing multipart/form-data parameters: ~A" condition) + nil))) + +(defun maybe-read-post-parameters (&key (request *request*) force external-format) + "Make surce that any POST parameters in the REQUEST are parsed. The +body of the request must be either application/x-www-form-urlencoded +or multipart/form-data to be considered as containing POST parameters. +If FORCE is true, parsing is done unconditionally. Otherwise, parsing +will only be done if the RAW-POST-DATA slot in the REQUEST is false. +EXTERNAL-FORMAT specifies the external format of the data in the +request body. By default, the encoding is determined from the +Content-Type header of the request or from +*HUNCHENTOOT-DEFAULT-EXTERNAL-FORMAT* if none is found." + (when (and (header-in :content-type request) + (member (request-method request) *methods-for-post-parameters* :test #'eq) + (or force + (not (slot-value request 'raw-post-data))) + ;; can't reparse multipart posts, even when FORCEd + (not (eq t (slot-value request 'raw-post-data)))) + (unless (or (header-in :content-length request) + (input-chunking-p)) + (log-message* :warning "Can't read request body because there's ~ +no Content-Length header and input chunking is off.") + (return-from maybe-read-post-parameters nil)) + (handler-case* + (multiple-value-bind (type subtype charset) + (parse-content-type (header-in :content-type request)) + (let ((external-format (or external-format + (when charset + (handler-case + (make-external-format charset :eol-style :lf) + (error () + (hunchentoot-warn "Ignoring ~ +unknown character set ~A in request content type." + charset)))) + *hunchentoot-default-external-format*))) + (setf (slot-value request 'post-parameters) + (cond ((and (string-equal type "application") + (string-equal subtype "x-www-form-urlencoded")) + (form-url-encoded-list-to-alist + (split "&" (raw-post-data :request request :external-format +latin-1+)) + external-format)) + ((and (string-equal type "multipart") + (string-equal subtype "form-data")) + (prog1 (parse-multipart-form-data request external-format) + (setf (slot-value request 'raw-post-data) t))))))) + (error (condition) + (log-message* :error "Error when reading POST parameters from body: ~A" condition) + ;; this is not the right thing to do because it could happen + ;; that we aren't finished reading from the request stream and + ;; can't send a reply - to be revisited + (setf (return-code*) +http-bad-request+ + *finish-processing-socket* t) + (abort-request-handler))))) + +(defun recompute-request-parameters (&key (request *request*) + (external-format *hunchentoot-default-external-format*)) + "Recomputes the GET and POST parameters for the REQUEST object +REQUEST. This only makes sense if you're switching external formats +during the request." + (maybe-read-post-parameters :request request :force t :external-format external-format) + (setf (slot-value request 'get-parameters) + (form-url-encoded-list-to-alist (split "&" (query-string request)) external-format)) + (values)) + +(defun script-name* (&optional (request *request*)) + "Returns the file name of the REQUEST object REQUEST. That's the +requested URI without the query string \(i.e the GET parameters)." + (script-name request)) + +(defun query-string* (&optional (request *request*)) + "Returns the query string of the REQUEST object REQUEST. That's +the part behind the question mark \(i.e. the GET parameters)." + (query-string request)) + +(defun get-parameters* (&optional (request *request*)) + "Returns an alist of the GET parameters associated with the REQUEST +object REQUEST." + (get-parameters request)) + +(defmethod post-parameters :before ((request request)) + ;; Force here because if someone calls POST-PARAMETERS they actually + ;; want them, regardless of why the RAW-POST-DATA has been filled + ;; in. (For instance, if SEND-HEADERS has been called, filling in + ;; RAW-POST-DATA, and then subsequent code calls POST-PARAMETERS, + ;; without the :FORCE flag POST-PARAMETERS would return NIL.) + (maybe-read-post-parameters + :request request :force (not (slot-value request 'post-parameters)))) + +(defun post-parameters* (&optional (request *request*)) + "Returns an alist of the POST parameters associated with the REQUEST +object REQUEST." + (post-parameters request)) + +(defun headers-in* (&optional (request *request*)) + "Returns an alist of the incoming headers associated with the +REQUEST object REQUEST." + (headers-in request)) + +(defun cookies-in* (&optional (request *request*)) + "Returns an alist of all cookies associated with the REQUEST object +REQUEST." + (cookies-in request)) + +(defgeneric header-in (name request) + (:documentation "Returns the incoming header with name NAME. NAME +can be a keyword \(recommended) or a string.") + (:method (name request) + (cdr (assoc* name (headers-in request))))) + +(defun header-in* (name &optional (request *request*)) + "Returns the incoming header with name NAME. NAME can be a keyword +\(recommended) or a string." + (header-in name request)) + +(defun authorization (&optional (request *request*)) + "Returns as two values the user and password \(if any) as encoded in +the 'AUTHORIZATION' header. Returns NIL if there is no such header." + (let* ((authorization (header-in :authorization request)) + (start (and authorization + (> (length authorization) 5) + (string-equal "Basic" authorization :end2 5) + (scan "\\S" authorization :start 5)))) + (when start + (destructuring-bind (&optional user password) + (split ":" (base64:base64-string-to-string (subseq authorization start)) :limit 2) + (values user password))))) + +(defun remote-addr* (&optional (request *request*)) + "Returns the address the current request originated from." + (remote-addr request)) + +(defun remote-port* (&optional (request *request*)) + "Returns the port the current request originated from." + (remote-port request)) + +(defun local-addr* (&optional (request *request*)) + "Returns the address the current request connected to." + (local-addr request)) + +(defun local-port* (&optional (request *request*)) + "Returns the port the current request connected to." + (local-port request)) + +(defun real-remote-addr (&optional (request *request*)) + "Returns the 'X-Forwarded-For' incoming http header as the +second value in the form of a list of IP addresses and the first +element of this list as the first value if this header exists. +Otherwise returns the value of REMOTE-ADDR as the only value." + (let ((x-forwarded-for (header-in :x-forwarded-for request))) + (cond (x-forwarded-for (let ((addresses (split "\\s*,\\s*" x-forwarded-for))) + (values (first addresses) addresses))) + (t (remote-addr request))))) + +(defun host (&optional (request *request*)) + "Returns the 'Host' incoming http header value." + (header-in :host request)) + +(defun request-uri* (&optional (request *request*)) + "Returns the request URI." + (request-uri request)) + +(defun request-method* (&optional (request *request*)) + "Returns the request method as a Lisp keyword." + (request-method request)) + +(defun server-protocol* (&optional (request *request*)) + "Returns the request protocol as a Lisp keyword." + (server-protocol request)) + +(defun user-agent (&optional (request *request*)) + "Returns the 'User-Agent' http header." + (header-in :user-agent request)) + +(defun cookie-in (name &optional (request *request*)) + "Returns the cookie with the name NAME \(a string) as sent by the +browser - or NIL if there is none." + (cdr (assoc name (cookies-in request) :test #'string=))) + +(defun referer (&optional (request *request*)) + "Returns the 'Referer' \(sic!) http header." + (header-in :referer request)) + +(defun get-parameter (name &optional (request *request*)) + "Returns the GET parameter with name NAME \(a string) - or NIL if +there is none. Search is case-sensitive." + (cdr (assoc name (get-parameters request) :test #'string=))) + +(defun post-parameter (name &optional (request *request*)) + "Returns the POST parameter with name NAME \(a string) - or NIL if +there is none. Search is case-sensitive." + (cdr (assoc name (post-parameters request) :test #'string=))) + +(defun parameter (name &optional (request *request*)) + "Returns the GET or the POST parameter with name NAME \(a string) - +or NIL if there is none. If both a GET and a POST parameter with the +same name exist the GET parameter is returned. Search is +case-sensitive." + (or (get-parameter name request) + (post-parameter name request))) + +(defun handle-if-modified-since (time &optional (request *request*)) + "Handles the 'If-Modified-Since' header of REQUEST. The date string +is compared to the one generated from the supplied universal time +TIME." + (let ((if-modified-since (header-in :if-modified-since request)) + (time-string (rfc-1123-date time))) + ;; simple string comparison is sufficient; see RFC 2616 14.25 + (when (and if-modified-since + (equal if-modified-since time-string)) + (setf (slot-value *reply* 'content-length) nil + (slot-value *reply* 'headers-out) (remove :content-length (headers-out*) :key #'car) + (return-code*) +http-not-modified+) + (abort-request-handler)) + (values))) + +(defun external-format-from-content-type (content-type) + "Creates and returns an external format corresponding to the value +of the content type header provided in CONTENT-TYPE. If the content +type was not set or if the character set specified was invalid, NIL is +returned." + (when content-type + (when-let (charset (nth-value 2 (parse-content-type content-type))) + (handler-case + (make-external-format (as-keyword charset) :eol-style :lf) + (error () + (hunchentoot-warn "Invalid character set ~S in request has been ignored." + charset)))))) + +(defun raw-post-data (&key (request *request*) external-format force-text force-binary want-stream) + "Returns the content sent by the client if there was any \(unless +the content type was \"multipart/form-data\"). By default, the result +is a string if the type of the `Content-Type' media type is \"text\", +and a vector of octets otherwise. In the case of a string, the +external format to be used to decode the content will be determined +from the `charset' parameter sent by the client \(or otherwise +*HUNCHENTOOT-DEFAULT-EXTERNAL-FORMAT* will be used). + +You can also provide an external format explicitly \(through +EXTERNAL-FORMAT) in which case the result will unconditionally be a +string. Likewise, you can provide a true value for FORCE-TEXT which +will force Hunchentoot to act as if the type of the media type had +been \"text\". Or you can provide a true value for FORCE-BINARY which +means that you want a vector of octets at any rate. + +If, however, you provide a true value for WANT-STREAM, the other +parameters are ignored and you'll get the content \(flexi) stream to +read from it yourself. It is then your responsibility to read the +correct amount of data, because otherwise you won't be able to return +a response to the client. If the content type of the request was +`multipart/form-data' or `application/x-www-form-urlencoded', the +content has been read by Hunchentoot already and you can't read from +the stream anymore. + +You can call RAW-POST-DATA more than once per request, but you can't +mix calls which have different values for WANT-STREAM. + +Note that this function is slightly misnamed because a client can send +content even if the request method is not POST." + (when (and force-binary force-text) + (parameter-error "It doesn't make sense to set both FORCE-BINARY and FORCE-TEXT to a true value.")) + (unless (or external-format force-binary) + (setq external-format (or (external-format-from-content-type (header-in :content-type request)) + (when force-text + *hunchentoot-default-external-format*)))) + (let ((raw-post-data (or (slot-value request 'raw-post-data) + (get-post-data :request request :want-stream want-stream)))) + (cond ((typep raw-post-data 'stream) raw-post-data) + ((member raw-post-data '(t nil)) nil) + (external-format (octets-to-string raw-post-data :external-format external-format)) + (t raw-post-data)))) + +(defun aux-request-value (symbol &optional (request *request*)) + "Returns the value associated with SYMBOL from the request object +REQUEST \(the default is the current request) if it exists. The +second return value is true if such a value was found." + (when request + (let ((found (assoc symbol (aux-data request) :test #'eq))) + (values (cdr found) found)))) + +(defsetf aux-request-value (symbol &optional request) + (new-value) + "Sets the value associated with SYMBOL from the request object +REQUEST \(default is *REQUEST*). If there is already a value +associated with SYMBOL it will be replaced." + (with-rebinding (symbol) + (with-unique-names (place %request) + `(let* ((,%request (or ,request *request*)) + (,place (assoc ,symbol (aux-data ,%request) :test #'eq))) + (cond + (,place + (setf (cdr ,place) ,new-value)) + (t + (push (cons ,symbol ,new-value) + (aux-data ,%request)) + ,new-value)))))) + +(defun delete-aux-request-value (symbol &optional (request *request*)) + "Removes the value associated with SYMBOL from the request object +REQUEST." + (when request + (setf (aux-data request) + (delete symbol (aux-data request) + :key #'car :test #'eq))) + (values)) + +(defun parse-path (path) + "Return a relative pathname that has been verified to not contain + any directory traversals or explicit device or host fields. Returns + NIL if the path is not acceptable." + (when (every #'graphic-char-p path) + (let* ((pathname (#+sbcl sb-ext:parse-native-namestring + #+ccl ccl:native-to-pathname + ;; Just disallow anything with :wild components later. + #-(or ccl sbcl) parse-namestring + (remove #\\ (regex-replace "^/*" path "")))) + (directory (pathname-directory pathname))) + (when (and (or (null (pathname-host pathname)) + (equal (pathname-host pathname) + (pathname-host *default-pathname-defaults*))) + (or (null (pathname-device pathname)) + (equal (pathname-device pathname) + (pathname-device *default-pathname-defaults*))) + (or (null directory) + (and (eql (first directory) :relative) + ;; only string components, no :UP traversals or :WILD + (every #'stringp (rest directory)))) + #-(or sbcl ccl) ;; parse-native-namestring should handle this + (and + (typep (pathname-name pathname) '(or null string)) ; no :WILD + (typep (pathname-type pathname) '(or null string))) + (not (equal (file-namestring pathname) ".."))) + pathname)))) + +(defun request-pathname (&optional (request *request*) drop-prefix) + "Construct a relative pathname from the request's SCRIPT-NAME. +If DROP-PREFIX is given, pathname construction starts at the first path +segment after the prefix. +" + (let ((path (script-name request))) + (if drop-prefix + (when (starts-with-p path drop-prefix) + (parse-path (subseq path (length drop-prefix)))) + (parse-path path)))) diff --git a/deps/hunchentoot/run-test.lisp b/deps/hunchentoot/run-test.lisp new file mode 100644 index 0000000..a6f104c --- /dev/null +++ b/deps/hunchentoot/run-test.lisp @@ -0,0 +1,87 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*- + +;;; Copyright (c) 2011, Hans Huebner. 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 *test-port* 4241) + +(asdf:oos 'asdf:load-op :hunchentoot-test) + +(defun run-tests () + (format t "~&;; Starting web server on localhost:~A." *test-port*) + (force-output) + (let ((server (hunchentoot:start (make-instance 'hunchentoot:easy-acceptor :port *test-port*)))) + (unwind-protect + (progn + (format t "~&;; Sleeping 2 seconds to give the server some time to start...") + (force-output) + (sleep 2) + (format t "~&;; Now running confidence tests.") + (force-output) + (hunchentoot-test:test-hunchentoot (format nil "http://localhost:~A" *test-port*))) + (format t "~&;; Stopping server.") + (force-output) + (hunchentoot:stop server) + (format t "~&;; Cleaning temporary files.") + (hunchentoot-test::clean-tmp-dir)))) + +#-sbcl +(run-tests) + +;;; KLUDGE (by Nikodemus Siivola) +;;; +;;; SBCL grabs a massive lock in WITH-COMPILATION-UNIT, which ASDF +;;; uses in PERFORM-PLAN ... which makes spawning threads during testing +;;; problematic to say the least. +;;; +;;; So, release the world lock for the duration. Nikodemus says that in this +;;; specific usage this should be safe --- and promises that people who copy +;;; this code and use it elsewhere will burn in hell for their sins. +;;; +;;; More promisingly, he swears up and down that that massive lock from +;;; W-C-U will be gone by early 2012 at the latest, so this will not be +;;; an eternal kludge, we hope. +(defun %call-without-world-lock-kludge (thunk) + #+(and sbcl sb-thread) + (let ((s (find-symbol "**WORLD-LOCK**" :sb-c))) + (if (and s (boundp s)) + (let ((lock (symbol-value s))) + (unwind-protect + (progn + (if (sb-thread:holding-mutex-p lock) + (sb-thread:release-mutex lock) + (setf lock nil)) + (funcall thunk)) + (when lock + (sb-thread:grab-mutex lock)))) + (funcall thunk))) + #-(and sbcl sb-thread) + (funcall thunk)) + +#+sbcl +(%call-without-world-lock-kludge 'run-tests) \ No newline at end of file diff --git a/deps/hunchentoot/session.lisp b/deps/hunchentoot/session.lisp new file mode 100644 index 0000000..41bb714 --- /dev/null +++ b/deps/hunchentoot/session.lisp @@ -0,0 +1,381 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*- + +;;; 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 :hunchentoot) + +(defgeneric session-db-lock (acceptor &key whole-db-p) + (:documentation "A function which returns a lock that will be used +to prevent concurrent access to sessions. The first argument will be +the acceptor that handles the current request, the second argument is +true if the whole \(current) session database is modified. If it is +NIL, only one existing session in the database is modified. + +This function can return NIL which means that sessions or session +databases will be modified without a lock held \(for example for +single-threaded environments). The default is to always return a +global lock \(ignoring the ACCEPTOR argument) for Lisps that support +threads and NIL otherwise.")) + +(defmethod session-db-lock ((acceptor t) &key (whole-db-p t)) + (declare (ignore whole-db-p)) + *global-session-db-lock*) + +(defmacro with-session-lock-held ((lock) &body body) + "This is like WITH-LOCK-HELD except that it will accept NIL as a +\"lock\" and just execute BODY in this case." + (with-unique-names (thunk) + (with-rebinding (lock) + `(flet ((,thunk () ,@body)) + (cond (,lock (with-lock-held (,lock) (,thunk))) + (t (,thunk))))))) + +(defgeneric session-db (acceptor) + (:documentation "Returns the current session database which is an +alist where each car is a session's ID and the cdr is the +corresponding SESSION object itself. The default is to use a global +list for all acceptors.")) + +(defmethod session-db ((acceptor t)) + *session-db*) + +(defgeneric (setf session-db) (new-value acceptor) + (:documentation "Modifies the current session database. See SESSION-DB.")) + +(defmethod (setf session-db) (new-value (acceptor t)) + (setq *session-db* new-value)) + +(defgeneric next-session-id (acceptor) + (:documentation "Returns the next sequential session ID, an integer, +which should be unique per session. The default method uses a simple +global counter and isn't guarded by a lock. For a high-performance +production environment you might consider using a more robust +implementation.")) + +(let ((session-id-counter 0)) + (defmethod next-session-id ((acceptor t)) + (incf session-id-counter))) + +(defclass session () + ((session-id :initform (next-session-id (request-acceptor *request*)) + :reader session-id + :type integer + :documentation "The unique ID \(an INTEGER) of the session.") + (session-string :reader session-string + :documentation "The session string encodes enough +data to safely retrieve this session. It is sent to the browser as a +cookie value or as a GET parameter.") + (user-agent :initform (user-agent *request*) + :reader session-user-agent + :documentation "The incoming 'User-Agent' header that +was sent when this session was created.") + (remote-addr :initform (real-remote-addr *request*) + :reader session-remote-addr + :documentation "The remote IP address of the client +when this session was started as returned by REAL-REMOTE-ADDR.") + (session-start :initform (get-universal-time) + :reader session-start + :documentation "The time this session was started.") + (last-click :initform (get-universal-time) + :reader session-last-click + :documentation "The last time this session was used.") + (session-data :initarg :session-data + :initform nil + :reader session-data + :documentation "Data associated with this session - +see SESSION-VALUE.") + (max-time :initarg :max-time + :initform *session-max-time* + :accessor session-max-time + :type fixnum + :documentation "The time \(in seconds) after which this +session expires if it's not used.")) + (:documentation "SESSION objects are automatically maintained by +Hunchentoot. They should not be created explicitly with MAKE-INSTANCE +but implicitly with START-SESSION and they should be treated as opaque +objects. + +You can ignore Hunchentoot's SESSION objects altogether and implement +your own sessions if you provide corresponding methods for +SESSION-COOKIE-VALUE and SESSION-VERIFY.")) + +(defun encode-session-string (id user-agent remote-addr start) + "Creates a uniquely encoded session string based on the values ID, +USER-AGENT, REMOTE-ADDR, and START" + (unless (boundp '*session-secret*) + (hunchentoot-warn "Session secret is unbound. Using Lisp's RANDOM function to initialize it.") + (reset-session-secret)) + ;; *SESSION-SECRET* is used twice due to known theoretical + ;; vulnerabilities of MD5 encoding + (md5-hex (concatenate 'string + *session-secret* + (md5-hex (format nil "~A~A~@[~A~]~@[~A~]~A" + *session-secret* + id + (and *use-user-agent-for-sessions* + user-agent) + (and *use-remote-addr-for-sessions* + remote-addr) + start))))) + +(defun stringify-session (session) + "Creates a string representing the SESSION object SESSION. See +ENCODE-SESSION-STRING." + (encode-session-string (session-id session) + (session-user-agent session) + (session-remote-addr session) + (session-start session))) + +(defmethod initialize-instance :after ((session session) &rest init-args) + "Set SESSION-STRING slot after the session has been initialized." + (declare (ignore init-args)) + (setf (slot-value session 'session-string) (stringify-session session))) + +(defun session-gc () + "Removes sessions from the current session database which are too +old - see SESSION-TOO-OLD-P." + (with-session-lock-held ((session-db-lock *acceptor*)) + (setf (session-db *acceptor*) + (loop for id-session-pair in (session-db *acceptor*) + for (nil . session) = id-session-pair + when (session-too-old-p session) + do (acceptor-remove-session *acceptor* session) + else + collect id-session-pair))) + (values)) + +(defun session-value (symbol &optional (session *session*)) + "Returns the value associated with SYMBOL from the session object +SESSION \(the default is the current session) if it exists." + (when session + (let ((found (assoc symbol (session-data session) :test #'eq))) + (values (cdr found) found)))) + +(defsetf session-value (symbol &optional session) + (new-value) + "Sets the value associated with SYMBOL from the session object +SESSION. If there is already a value associated with SYMBOL it will be +replaced. Will automatically start a session if none was supplied and +there's no session for the current request." + (with-rebinding (symbol) + (with-unique-names (place %session) + `(let ((,%session (or ,session (start-session)))) + (with-session-lock-held ((session-db-lock *acceptor* :whole-db-p nil)) + (let* ((,place (assoc ,symbol (session-data ,%session) :test #'eq))) + (cond + (,place + (setf (cdr ,place) ,new-value)) + (t + (push (cons ,symbol ,new-value) + (slot-value ,%session 'session-data)) + ,new-value)))))))) + +(defun delete-session-value (symbol &optional (session *session*)) + "Removes the value associated with SYMBOL from SESSION if there is +one." + (when session + (setf (slot-value session 'session-data) + (delete symbol (session-data session) + :key #'car :test #'eq))) + (values)) + +(defgeneric session-cookie-value (session) + (:documentation "Returns a string which can be used to safely +restore the session SESSION if as session has already been +established. This is used as the value stored in the session cookie +or in the corresponding GET parameter and verified by SESSION-VERIFY. + +A default method is provided and there's no reason to change it unless +you want to use your own session objects.")) + +(defmethod session-cookie-value ((session session)) + (and session + (format nil + "~D:~A" + (session-id session) + (session-string session)))) + +(defgeneric session-cookie-name (acceptor) + (:documentation "Returns the name \(a string) of the cookie \(or the +GET parameter) which is used to store a session on the client side. +The default is to use the string \"hunchentoot-session\", but you can +specialize this function if you want another name.")) + +(defmethod session-cookie-name ((acceptor t)) + "hunchentoot-session") + +(defgeneric session-created (acceptor new-session) + (:documentation "This function is called whenever a new session has +been created. There's a default method which might trigger a session +GC based on the value of *SESSION-GC-FREQUENCY*. + +The return value is ignored.")) + +(let ((global-session-usage-counter 0)) + (defmethod session-created ((acceptor t) (session t)) + "Counts session usage globally and triggers session GC if +necessary." + (when (and *session-gc-frequency* + (zerop (mod (incf global-session-usage-counter) + *session-gc-frequency*))) + (session-gc)))) + +(defun start-session () + "Returns the current SESSION object. If there is no current session, +creates one and updates the corresponding data structures. In this +case the function will also send a session cookie to the browser." + (let ((session (session *request*))) + (when session + (return-from start-session session)) + (setf session (make-instance 'session) + (session *request*) session) + (with-session-lock-held ((session-db-lock *acceptor*)) + (setf (session-db *acceptor*) + (acons (session-id session) session (session-db *acceptor*)))) + (set-cookie (session-cookie-name *acceptor*) + :value (session-cookie-value session) + :path "/" + :http-only t) + (session-created *acceptor* session) + (setq *session* session))) + +(defun remove-session (session) + "Completely removes the SESSION object SESSION from Hunchentoot's +internal session database." + (set-cookie (session-cookie-name *acceptor*) + :value "deleted" + :path "/" + :expires 0) + (with-session-lock-held ((session-db-lock *acceptor*)) + (acceptor-remove-session *acceptor* session) + (setf (session-db *acceptor*) + (delete (session-id session) (session-db *acceptor*) + :key #'car :test #'=))) + (values)) + +(defun session-too-old-p (session) + "Returns true if the SESSION object SESSION has not been active in +the last \(SESSION-MAX-TIME SESSION) seconds." + (< (+ (session-last-click session) (session-max-time session)) + (get-universal-time))) + +(defun get-stored-session (id) + "Returns the SESSION object corresponding to the number ID if the +session has not expired. Will remove the session if it has expired but +will not create a new one." + (let ((session + (cdr (assoc id (session-db *acceptor*) :test #'=)))) + (when (and session + (session-too-old-p session)) + (when *reply* + (log-message* :info "Session with ID ~A too old" id)) + (remove-session session) + (setq session nil)) + session)) + +(defun regenerate-session-cookie-value (session) + "Regenerates the cookie value. This should be used +when a user logs in according to the application to prevent against +session fixation attacks. The cookie value being dependent on ID, +USER-AGENT, REMOTE-ADDR, START, and *SESSION-SECRET*, the only value +we can change is START to regenerate a new value. Since we're +generating a new cookie, it makes sense to have the session being +restarted, in time. That said, because of this fact, calling this +function twice in the same second will regenerate twice the same value." + (setf (slot-value session 'session-start) (get-universal-time) + (slot-value session 'session-string) (stringify-session session)) + (set-cookie (session-cookie-name *acceptor*) + :value (session-cookie-value session) + :path "/" + :http-only t)) + +(defgeneric session-verify (request) + (:documentation "Tries to get a session identifier from the cookies +\(or alternatively from the GET parameters) sent by the client (see +SESSION-COOKIE-NAME and SESSION-COOKIE-VALUE). This identifier is +then checked for validity against the REQUEST object REQUEST. On +success the corresponding session object \(if not too old) is returned +\(and updated). Otherwise NIL is returned. + +A default method is provided and you only need to write your own one +if you want to maintain your own sessions.")) + +(defmethod session-verify ((request request)) + (let ((session-identifier (or (when-let (session-cookie (cookie-in (session-cookie-name *acceptor*) request)) + (url-decode session-cookie)) + (get-parameter (session-cookie-name *acceptor*) request)))) + (when (and (stringp session-identifier) + (scan "^\\d+:.+" session-identifier)) + (destructuring-bind (id-string session-string) + (split ":" session-identifier :limit 2) + (let* ((id (parse-integer id-string)) + (session (get-stored-session id)) + (user-agent (user-agent request)) + (remote-addr (remote-addr request))) + (cond + ((and session + (string= session-string + (session-string session)) + (string= session-string + (encode-session-string id + user-agent + (real-remote-addr request) + (session-start session)))) + ;; the session key presented by the client is valid + (setf (slot-value session 'last-click) (get-universal-time)) + session) + (session + ;; the session ID pointed to an existing session, but the + ;; session string did not match the expected session string + (log-message* :warning + "Fake session identifier '~A' (User-Agent: '~A', IP: '~A')" + session-identifier user-agent remote-addr) + ;; remove the session to make sure that it can't be used + ;; again; the original legitimate user will be required to + ;; log in again + (remove-session session) + nil) + (t + ;; no session was found under the ID given, presumably + ;; because it has expired. + (log-message* :info + "No session for session identifier '~A' (User-Agent: '~A', IP: '~A')" + session-identifier user-agent remote-addr) + nil))))))) + +(defun reset-session-secret () + "Sets *SESSION-SECRET* to a new random value. All old sessions will +cease to be valid." + (setq *session-secret* (create-random-string 10 36))) + +(defun reset-sessions (&optional (acceptor *acceptor*)) + "Removes ALL stored sessions of ACCEPTOR." + (with-session-lock-held ((session-db-lock acceptor)) + (loop for (nil . session) in (session-db acceptor) + do (acceptor-remove-session acceptor session)) + (setq *session-db* nil)) + (values)) diff --git a/deps/hunchentoot/set-timeouts.lisp b/deps/hunchentoot/set-timeouts.lisp new file mode 100644 index 0000000..e00e95d --- /dev/null +++ b/deps/hunchentoot/set-timeouts.lisp @@ -0,0 +1,85 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- + +;;; 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 :hunchentoot) + +(defun set-timeouts (usocket read-timeout write-timeout) + "Sets up timeouts on the given USOCKET object. READ-TIMEOUT is the +read timeout period, WRITE-TIMEOUT is the write timeout, specified in +\(fractional) seconds. The timeouts can either be implemented using +the low-level socket options SO_RCVTIMEO and SO_SNDTIMEO or some +other, implementation specific mechanism. On platforms that do not +support separate read and write timeouts, both must be equal or an +error will be signaled. READ-TIMEOUT and WRITE-TIMEOUT may be NIL, +which means that the corresponding socket timeout value will not be +set." + (declare (ignorable usocket read-timeout write-timeout)) + ;; add other Lisps here if necessary + #+(or :sbcl :cmu :abcl) + (unless (eql read-timeout write-timeout) + (parameter-error "Read and write timeouts for socket must be equal.")) + #+:clisp + (when read-timeout + (socket:socket-options (usocket:socket usocket) :SO-RCVTIMEO read-timeout)) + #+:clisp + (when write-timeout + (socket:socket-options (usocket:socket usocket) :SO-SNDTIMEO write-timeout)) + #+:ecl + (when read-timeout + (setf (sb-bsd-sockets:sockopt-receive-timeout (usocket:socket usocket)) + read-timeout)) + #+:ecl + (when write-timeout + (setf (sb-bsd-sockets:sockopt-send-timeout (usocket:socket usocket)) + write-timeout)) + #+:openmcl + (when read-timeout + (setf (ccl:stream-input-timeout (usocket:socket usocket)) + read-timeout)) + #+:openmcl + (when write-timeout + (setf (ccl:stream-output-timeout (usocket:socket usocket)) + write-timeout)) + #+:sbcl + (when read-timeout + (setf (sb-impl::fd-stream-timeout (usocket:socket-stream usocket)) + (coerce read-timeout 'single-float))) + #+:cmu + (setf (lisp::fd-stream-timeout (usocket:socket-stream usocket)) + (coerce read-timeout 'integer)) + #+:abcl + (when read-timeout + (java:jcall (java:jmethod "java.net.Socket" "setSoTimeout" "int") + (usocket:socket usocket) + (* 1000 read-timeout))) + #+:abcl + (when write-timeout + (warn "Unimplemented.")) + #-(or :clisp :allegro :openmcl :sbcl :lispworks :cmu :ecl :abcl) + (not-implemented 'set-timeouts)) + diff --git a/deps/hunchentoot/specials.lisp b/deps/hunchentoot/specials.lisp new file mode 100644 index 0000000..a0c98ce --- /dev/null +++ b/deps/hunchentoot/specials.lisp @@ -0,0 +1,310 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*- + +;;; 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 :hunchentoot) + +(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)))) + +(eval-when (:compile-toplevel :execute :load-toplevel) + (defmacro defvar-unbound (name &optional (doc-string "")) + "Convenience macro to declare unbound special variables with a +documentation string." + `(progn + (defvar ,name) + (setf (documentation ',name 'variable) ,doc-string) + ',name)) + + (defvar *http-reason-phrase-map* (make-hash-table) + "Used to map numerical return codes to reason phrases.") + + (defmacro def-http-return-code (name value reason-phrase) + "Shortcut to define constants for return codes. NAME is a +Lisp symbol, VALUE is the numerical value of the return code, and +REASON-PHRASE is the phrase \(a string) to be shown in the +server's status line." + `(eval-when (:compile-toplevel :execute :load-toplevel) + (defconstant ,name ,value ,(format nil "HTTP return code \(~A) for '~A'." + value reason-phrase)) + (setf (gethash ,value *http-reason-phrase-map*) ,reason-phrase)))) + +(defconstant +crlf+ + (make-array 2 :element-type '(unsigned-byte 8) + :initial-contents (mapcar 'char-code '(#\Return #\Linefeed))) + "A 2-element array consisting of the character codes for a CRLF +sequence.") + +(def-http-return-code +http-continue+ 100 "Continue") +(def-http-return-code +http-switching-protocols+ 101 "Switching Protocols") +(def-http-return-code +http-ok+ 200 "OK") +(def-http-return-code +http-created+ 201 "Created") +(def-http-return-code +http-accepted+ 202 "Accepted") +(def-http-return-code +http-non-authoritative-information+ 203 "Non-Authoritative Information") +(def-http-return-code +http-no-content+ 204 "No Content") +(def-http-return-code +http-reset-content+ 205 "Reset Content") +(def-http-return-code +http-partial-content+ 206 "Partial Content") +(def-http-return-code +http-multi-status+ 207 "Multi-Status") +(def-http-return-code +http-multiple-choices+ 300 "Multiple Choices") +(def-http-return-code +http-moved-permanently+ 301 "Moved Permanently") +(def-http-return-code +http-moved-temporarily+ 302 "Moved Temporarily") +(def-http-return-code +http-see-other+ 303 "See Other") +(def-http-return-code +http-not-modified+ 304 "Not Modified") +(def-http-return-code +http-use-proxy+ 305 "Use Proxy") +(def-http-return-code +http-temporary-redirect+ 307 "Temporary Redirect") +(def-http-return-code +http-bad-request+ 400 "Bad Request") +(def-http-return-code +http-authorization-required+ 401 "Authorization Required") +(def-http-return-code +http-payment-required+ 402 "Payment Required") +(def-http-return-code +http-forbidden+ 403 "Forbidden") +(def-http-return-code +http-not-found+ 404 "Not Found") +(def-http-return-code +http-method-not-allowed+ 405 "Method Not Allowed") +(def-http-return-code +http-not-acceptable+ 406 "Not Acceptable") +(def-http-return-code +http-proxy-authentication-required+ 407 "Proxy Authentication Required") +(def-http-return-code +http-request-time-out+ 408 "Request Time-out") +(def-http-return-code +http-conflict+ 409 "Conflict") +(def-http-return-code +http-gone+ 410 "Gone") +(def-http-return-code +http-length-required+ 411 "Length Required") +(def-http-return-code +http-precondition-failed+ 412 "Precondition Failed") +(def-http-return-code +http-request-entity-too-large+ 413 "Request Entity Too Large") +(def-http-return-code +http-request-uri-too-large+ 414 "Request-URI Too Large") +(def-http-return-code +http-unsupported-media-type+ 415 "Unsupported Media Type") +(def-http-return-code +http-requested-range-not-satisfiable+ 416 "Requested range not satisfiable") +(def-http-return-code +http-expectation-failed+ 417 "Expectation Failed") +(def-http-return-code +http-failed-dependency+ 424 "Failed Dependency") +(def-http-return-code +http-precondition-required+ 428 "Precondition Required") +(def-http-return-code +http-too-many-requests+ 429 "Too Many Requests") +(def-http-return-code +http-request-header-fields-too-large+ 431 "Request Header Fields Too Large") +(def-http-return-code +http-internal-server-error+ 500 "Internal Server Error") +(def-http-return-code +http-not-implemented+ 501 "Not Implemented") +(def-http-return-code +http-bad-gateway+ 502 "Bad Gateway") +(def-http-return-code +http-service-unavailable+ 503 "Service Unavailable") +(def-http-return-code +http-gateway-time-out+ 504 "Gateway Time-out") +(def-http-return-code +http-version-not-supported+ 505 "Version not supported") +(def-http-return-code +http-network-authentication-required+ 511 "Network Authentication Required") + +(defconstant +day-names+ + #("Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun") + "The three-character names of the seven days of the week - needed +for cookie date format.") + +(defconstant +month-names+ + #("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec") + "The three-character names of the twelve months - needed for cookie +date format.") + +(defvar *rewrite-for-session-urls* t + "Whether HTML pages should possibly be rewritten for cookie-less +session-management.") + +(defvar *content-types-for-url-rewrite* + '("text/html" "application/xhtml+xml") + "The content types for which url-rewriting is OK. See +*REWRITE-FOR-SESSION-URLS*.") + +(defvar *the-random-state* (make-random-state t) + "A fresh random state.") + +(defvar-unbound *session-secret* + "A random ASCII string that's used to encode the public session +data. This variable is initially unbound and will be set \(using +RESET-SESSION-SECRET) the first time a session is created, if +necessary. You can prevent this from happening if you set the value +yourself before starting acceptors.") + +(defvar-unbound *hunchentoot-stream* + "The stream representing the socket Hunchentoot is listening on.") + +(defvar-unbound *finish-processing-socket* + "Will be set to T if PROCESS-CONNECTION is to stop processing more + requests on the current socket connection.") + +(defvar-unbound *close-hunchentoot-stream* + "This variable is set to NIL during the processing of a handler to +tell the acceptor not to close the connection after it is done.") + +(defvar *headers-sent* nil + "Used internally to check whether the reply headers have +already been sent for this request.") + +(defvar *file-upload-hook* nil + "If this is not NIL, it should be a unary function which will +be called with a pathname for each file which is uploaded to +Hunchentoot. The pathname denotes the temporary file to which +the uploaded file is written. The hook is called directly before +the file is created.") + +(defvar *session-db* nil + "The default \(global) session database.") + +(defvar *session-max-time* #.(* 30 60) + "The default time \(in seconds) after which a session times out.") + +(defvar *session-gc-frequency* 50 + "A session GC \(see function SESSION-GC) will happen every +*SESSION-GC-FREQUENCY* requests \(counting only requests which create +a new session) if this variable is not NIL. See SESSION-CREATED.") + +(defvar *use-user-agent-for-sessions* t + "Whether the 'User-Agent' header should be encoded into the session +string. If this value is true, a session will cease to be accessible +if the client sends a different 'User-Agent' header.") + +(defvar *use-remote-addr-for-sessions* nil + "Whether the client's remote IP \(as returned by REAL-REMOTE-ADDR) +should be encoded into the session string. If this value is true, a +session will cease to be accessible if the client's remote IP changes. + +This might for example be an issue if the client uses a proxy server +which doesn't send correct 'X_FORWARDED_FOR' headers.") + +(defvar *default-content-type* "text/html" + "The default content-type header which is returned to the client. +If this is text content type, the character set used for encoding the +response will automatically be added to the content type in a +``charset'' attribute.") + +(defvar *methods-for-post-parameters* '(:post) + "A list of the request method types \(as keywords) for which +Hunchentoot will try to compute POST-PARAMETERS.") + +(defvar *header-stream* nil + "If this variable is not NIL, it should be bound to a stream to +which incoming and outgoing headers will be written for debugging +purposes.") + +(defvar *show-lisp-errors-p* nil + "Whether Lisp errors in request handlers should be shown in HTML output.") + +(defvar *show-lisp-backtraces-p* t + "Whether Lisp errors shown in HTML output should contain backtrace information.") + +(defvar *log-lisp-errors-p* t + "Whether Lisp errors in request handlers should be logged.") + +(defvar *log-lisp-backtraces-p* t + "Whether Lisp backtraces should be logged. Only has an effect if +*LOG-LISP-ERRORS-P* is true as well.") + +(defvar *log-lisp-warnings-p* t + "Whether Lisp warnings in request handlers should be logged.") + +(defvar *lisp-errors-log-level* :error + "Log level for Lisp errors. Should be one of :ERROR \(the default), +:WARNING, or :INFO.") + +(defvar *lisp-warnings-log-level* :warning + "Log level for Lisp warnings. Should be one of :ERROR, :WARNING +\(the default), or :INFO.") + +(defvar *message-log-lock* (make-lock "global-message-log-lock") + "A global lock to prevent concurrent access to the log file used by +the ACCEPTOR-LOG-MESSAGE function.") + +(defvar *access-log-lock* (make-lock "global-access-log-lock") + "A global lock to prevent concurrent access to the log file used by +the ACCEPTOR-LOG-ACCESS function.") + +(defvar *catch-errors-p* t + "Whether Hunchentoot should catch and log errors \(or rather invoke +the debugger).") + +(defvar-unbound *acceptor* + "The current ACCEPTOR object while in the context of a request.") + +(defvar-unbound *request* + "The current REQUEST object while in the context of a request.") + +(defvar-unbound *reply* + "The current REPLY object while in the context of a request.") + +(defvar-unbound *session* + "The current session while in the context of a request, or NIL.") + +(defconstant +implementation-link+ + #+:cmu "http://www.cons.org/cmucl/" + #+:sbcl "http://www.sbcl.org/" + #+:allegro "http://www.franz.com/products/allegrocl/" + #+:lispworks "http://www.lispworks.com/" + #+:openmcl "http://openmcl.clozure.com/" + "A link to the website of the underlying Lisp implementation.") + +(defvar *tmp-directory* + #+(or :win32 :mswindows) "c:\\hunchentoot-temp\\" + #-(or :win32 :mswindows) "/tmp/hunchentoot/" + "Directory for temporary files created by MAKE-TMP-FILE-NAME.") + +(defvar *tmp-files* nil + "A list of temporary files created while a request was handled.") + +(defconstant +latin-1+ + (make-external-format :latin1 :eol-style :lf) + "A FLEXI-STREAMS external format used for `faithful' input and +output of binary data.") + +(defconstant +utf-8+ + (make-external-format :utf8 :eol-style :lf) + "A FLEXI-STREAMS external format used internally for logging and to +encode cookie values.") + +(defvar *hunchentoot-default-external-format* +utf-8+ + "The external format used to compute the REQUEST object.") + +(defconstant +buffer-length+ 8192 + "Length of buffers used for internal purposes.") + +(defvar *default-connection-timeout* 20 + "The default connection timeout used when an acceptor is reading +from and writing to a socket stream.") + +(eval-when (:compile-toplevel :load-toplevel :execute) + (define-symbol-macro *supports-threads-p* + #+:lispworks t + #-:lispworks bt:*supports-threads-p*)) + +(defvar *global-session-db-lock* + (load-time-value (and *supports-threads-p* (make-lock "global-session-db-lock"))) + "A global lock to prevent two threads from modifying *session-db* at +the same time \(or NIL for Lisps which don't have threads).") + +(pushnew :hunchentoot *features*) + +;; stuff for Nikodemus Siivola's HYPERDOC +;; see +;; and + +(defvar *hyperdoc-base-uri* "http://weitz.de/hunchentoot/") + +(let ((exported-symbols-alist + (loop for symbol being the external-symbols of :hunchentoot + collect (cons symbol (concatenate 'string "#" (string-downcase symbol)))))) + (defun hyperdoc-lookup (symbol type) + (declare (ignore type)) + (cdr (assoc symbol exported-symbols-alist :test #'eq)))) + +(defparameter hunchentoot:*hunchentoot-version* #.(asdf:component-version (asdf:find-system :hunchentoot))) diff --git a/deps/hunchentoot/ssl.lisp b/deps/hunchentoot/ssl.lisp new file mode 100644 index 0000000..58ecc2e --- /dev/null +++ b/deps/hunchentoot/ssl.lisp @@ -0,0 +1,119 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- + +;;; 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 :hunchentoot) + +(defclass ssl-acceptor (acceptor) + ((ssl-certificate-file :initarg :ssl-certificate-file + :reader acceptor-ssl-certificate-file + :documentation "A pathname designator for a +certificate file in PEM format.") + (ssl-privatekey-file :initarg :ssl-privatekey-file + :reader acceptor-ssl-privatekey-file + :documentation "A pathname designator for a +private key file in PEM format, or \(only on LispWorks) NIL if the +certificate file contains the private key.") + (ssl-privatekey-password :initform nil + :initarg :ssl-privatekey-password + :reader acceptor-ssl-privatekey-password + :documentation "The password for the +private key file or NIL for no password.")) + (:default-initargs + :port 443) + (:documentation "Create and START an instance of this class +\(instead of ACCEPTOR) if you want an https server. There are two +required initargs, :SSL-CERTIFICATE-FILE and :SSL-PRIVATEKEY-FILE, for +pathname designators denoting the certificate file and the key file in +PEM format. On LispWorks, you can have both in one file in which case +the second initarg is optional. You can also use the +:SSL-PRIVATEKEY-PASSWORD initarg to provide a password \(as a string) +for the key file \(or NIL, the default, for no password). + +The default port for SSL-ACCEPTOR instances is 443 instead of 80")) + +;; general implementation + +(defmethod acceptor-ssl-p ((acceptor ssl-acceptor)) + t) + +(defmethod initialize-instance :after ((acceptor ssl-acceptor) &rest initargs) + (declare (ignore initargs)) + ;; LispWorks can read both from the same file, so we can default one + #+:lispworks + (unless (slot-boundp acceptor 'ssl-privatekey-file) + (setf (slot-value acceptor 'ssl-privatekey-file) + (acceptor-ssl-certificate-file acceptor))) + ;; OpenSSL doesn't know much about Lisp pathnames... + (setf (slot-value acceptor 'ssl-privatekey-file) + (namestring (truename (acceptor-ssl-privatekey-file acceptor))) + (slot-value acceptor 'ssl-certificate-file) + (namestring (truename (acceptor-ssl-certificate-file acceptor))))) + +;; usocket implementation + +#-:lispworks +(defmethod initialize-connection-stream ((acceptor ssl-acceptor) stream) + ;; attach SSL to the stream if necessary + (call-next-method acceptor + (cl+ssl:make-ssl-server-stream stream + :certificate (acceptor-ssl-certificate-file acceptor) + :key (acceptor-ssl-privatekey-file acceptor) + :password (acceptor-ssl-privatekey-password acceptor)))) + +;; LispWorks implementation + +#+:lispworks +(defun make-ssl-server-stream (socket-stream &key certificate-file privatekey-file privatekey-password) + "Given the acceptor socket stream SOCKET-STREAM attaches SSL to the +stream using the certificate file CERTIFICATE-FILE and the private key +file PRIVATEKEY-FILE. Both of these values must be namestrings +denoting the location of the files and will be fed directly to +OpenSSL. If PRIVATEKEY-PASSWORD is not NIL then it should be the +password for the private key file \(if necessary). Returns the +stream." + (flet ((ctx-configure-callback (ctx) + (when privatekey-password + (comm:set-ssl-ctx-password-callback ctx :password privatekey-password)) + (comm:ssl-ctx-use-certificate-file ctx + certificate-file + comm:ssl_filetype_pem) + (comm:ssl-ctx-use-privatekey-file ctx + privatekey-file + comm:ssl_filetype_pem))) + (comm:attach-ssl socket-stream + :ctx-configure-callback #'ctx-configure-callback) + socket-stream)) + +#+:lispworks +(defmethod initialize-connection-stream ((acceptor ssl-acceptor) stream) + ;; attach SSL to the stream if necessary + (call-next-method acceptor + (make-ssl-server-stream stream + :certificate-file (acceptor-ssl-certificate-file acceptor) + :privatekey-file (acceptor-ssl-privatekey-file acceptor) + :privatekey-password (acceptor-ssl-privatekey-password acceptor)))) diff --git a/deps/hunchentoot/taskmaster.lisp b/deps/hunchentoot/taskmaster.lisp new file mode 100644 index 0000000..deffd10 --- /dev/null +++ b/deps/hunchentoot/taskmaster.lisp @@ -0,0 +1,479 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Base: 10 -*- + +;;; 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 :hunchentoot) + +(defclass taskmaster () + ((acceptor :accessor taskmaster-acceptor + :documentation "A backpointer to the acceptor instance +this taskmaster works for.")) + (:documentation "An instance of this class is responsible for +distributing the work of handling requests for its acceptor. This is +an \"abstract\" class in the sense that usually only instances of +subclasses of TASKMASTER will be used.")) + +(defgeneric execute-acceptor (taskmaster) + (:documentation "This is a callback called by the acceptor once it +has performed all initial processing to start listening for incoming +connections \(see START-LISTENING). It usually calls the +ACCEPT-CONNECTIONS method of the acceptor, but depending on the +taskmaster instance the method might be called from a new thread.")) + +(defgeneric handle-incoming-connection (taskmaster socket) + (:documentation "This function is called by the acceptor to start +processing of requests on a new incoming connection. SOCKET is the +usocket instance that represents the new connection \(or a socket +handle on LispWorks). The taskmaster starts processing requests on +the incoming connection by calling the PROCESS-CONNECTION method of +the acceptor instance. The SOCKET argument is passed to +PROCESS-CONNECTION as an argument.")) + +(defgeneric shutdown (taskmaster) + (:documentation "Shuts down the taskmaster, i.e. frees all resources +that were set up by it. For example, a multi-threaded taskmaster +might terminate all threads that are currently associated with it. +This function is called by the acceptor's STOP method.")) + +(defgeneric create-request-handler-thread (taskmaster socket) + (:documentation + "Create a new thread in which to process the request. + This thread will call PROCESS-CONNECTION to process the request.")) + +(defgeneric too-many-taskmaster-requests (taskmaster socket) + (:documentation + "Signal a \"too many requests\" error, just prior to closing the connection.")) + +(defgeneric taskmaster-max-thread-count (taskmaster) + (:documentation + "The maximum number of request threads this taskmaster will simultaneously + run before refusing or queueing new connections requests. If the value + is null, then there is no limit.") + (:method ((taskmaster taskmaster)) + "Default method -- no limit on the number of threads." + nil)) + +(defgeneric taskmaster-max-accept-count (taskmaster) + (:documentation + "The maximum number of connections this taskmaster will accept before refusing + new connections. If supplied, this must be greater than MAX-THREAD-COUNT. + The number of queued requests is the difference between MAX-ACCEPT-COUNT + and MAX-THREAD-COUNT.") + (:method ((taskmaster taskmaster)) + "Default method -- no limit on the number of connections." + nil)) + +(defgeneric taskmaster-thread-count (taskmaster) + (:documentation + "Returns the current number of taskmaster requests.") + (:method ((taskmaster taskmaster)) + "Default method -- claim there is one connection thread." + 1)) + +(defgeneric increment-taskmaster-thread-count (taskmaster) + (:documentation + "Atomically increment the number of taskmaster requests.") + (:method ((taskmaster taskmaster)) + "Default method -- do nothing." + nil)) + +(defgeneric decrement-taskmaster-thread-count (taskmaster) + (:documentation + "Atomically decrement the number of taskmaster requests") + (:method ((taskmaster taskmaster)) + "Default method -- do nothing." + nil)) + +(defgeneric start-thread (taskmaster thunk &key name) + (:documentation + "Start a name thread in which to call the THUNK, in the context of the given TASKMASTER. +Keyword arguments provide TASKMASTER-dependent options. +Return a thread object. + +Hunchentoot taskmaster methods will call it with the taskmaster as the context, +allowing hunchentoot extensions to define specialized methods that may e.g. +wrap the thunk within a proper set of bindings and condition handlers.") + (:method ((taskmaster t) thunk &key name) + #-lispworks + (bt:make-thread thunk :name name) + #+lispworks + (mp:process-run-function name nil thunk))) + + +(defclass single-threaded-taskmaster (taskmaster) + () + (:documentation "A taskmaster that runs synchronously in the thread +where the START function was invoked \(or in the case of LispWorks in +the thread started by COMM:START-UP-SERVER). This is the simplest +possible taskmaster implementation in that its methods do nothing but +calling their acceptor \"sister\" methods - EXECUTE-ACCEPTOR calls +ACCEPT-CONNECTIONS, HANDLE-INCOMING-CONNECTION calls +PROCESS-CONNECTION.")) + +(defmethod execute-acceptor ((taskmaster single-threaded-taskmaster)) + ;; in a single-threaded environment we just call ACCEPT-CONNECTIONS + (accept-connections (taskmaster-acceptor taskmaster))) + +(defmethod handle-incoming-connection ((taskmaster single-threaded-taskmaster) socket) + ;; in a single-threaded environment we just call PROCESS-CONNECTION + (process-connection (taskmaster-acceptor taskmaster) socket)) + +(defvar *default-max-thread-count* 100) +(defvar *default-max-accept-count* (+ *default-max-thread-count* 20)) + + +(defclass multi-threaded-taskmaster (taskmaster) + ((acceptor-process + :accessor acceptor-process + :documentation + "A process that accepts incoming connections and hands them off to new processes + for request handling.")) + (:documentation "An abstract class for taskmasters that use multiple threads. +For a concrete class to instantiate, use one-thread-per-connection-taskmaster.")) + +(defmethod execute-acceptor ((taskmaster multi-threaded-taskmaster)) + (setf (acceptor-process taskmaster) + (start-thread + taskmaster + (lambda () (accept-connections (taskmaster-acceptor taskmaster))) + :name (format nil "hunchentoot-listener-~A:~A" + (or (acceptor-address (taskmaster-acceptor taskmaster)) "*") + (acceptor-port (taskmaster-acceptor taskmaster)))))) + + +;; You might think it would be nice to provide a taskmaster that takes +;; threads out of a thread pool. There are two things to consider: +;; - On a 2010-ish Linux box, thread creation takes less than 250 microseconds. +;; - Bordeaux Threads doesn't provide a way to "reset" and restart a thread, +;; and it's not clear how many Lisp implementations can do this. +;; If you're still interested, use the quux-hunchentoot extension to hunchentoot. + +(defclass one-thread-per-connection-taskmaster (multi-threaded-taskmaster) + (;; Support for bounding the number of threads we'll create + (max-thread-count + :type (or integer null) + :initarg :max-thread-count + :initform nil + :accessor taskmaster-max-thread-count + :documentation + "The maximum number of request threads this taskmaster will simultaneously + run before refusing or queueing new connections requests. If the value + is null, then there is no limit.") + (thread-count + :type integer + :initform 0 + :accessor taskmaster-thread-count + :documentation + "The number of taskmaster processing threads currently running.") + (thread-count-lock + :initform (make-lock "taskmaster-thread-count") + :reader taskmaster-thread-count-lock + :documentation + "In the absence of 'atomic-incf', we need this to atomically + increment and decrement the request count.") + (max-accept-count + :type (or integer null) + :initarg :max-accept-count + :initform nil + :accessor taskmaster-max-accept-count + :documentation + "The maximum number of connections this taskmaster will accept before refusing + new connections. If supplied, this must be greater than MAX-THREAD-COUNT. + The number of queued requests is the difference between MAX-ACCEPT-COUNT + and MAX-THREAD-COUNT.") + (accept-count + :type integer + :initform 0 + :accessor taskmaster-accept-count + :documentation + "The number of connection currently accepted by the taskmaster. These + connections are not ensured to be processed, thay may be waiting for an + empty processing slot or rejected because the load is too heavy.") + (accept-count-lock + :initform (make-lock "taskmaster-accept-count") + :reader taskmaster-accept-count-lock + :documentation + "In the absence of 'atomic-incf', we need this to atomically + increment and decrement the accept count.") + (wait-queue + :initform (make-condition-variable) + :reader taskmaster-wait-queue + :documentation + "A queue that we use to wait for a free connection.") + (wait-lock + :initform (make-lock "taskmaster-thread-lock") + :reader taskmaster-wait-lock + :documentation + "The lock for the connection wait queue.") + (worker-thread-name-format + :type (or string null) + :initarg :worker-thread-name-format + :initform "hunchentoot-worker-~A" + :accessor taskmaster-worker-thread-name-format)) + (:default-initargs + :max-thread-count *default-max-thread-count* + :max-accept-count *default-max-accept-count*) + (:documentation "A taskmaster that starts one thread for listening +to incoming requests and one new thread for each incoming connection. + +If MAX-THREAD-COUNT is null, a new thread will always be created for +each request. + +If MAX-THREAD-COUNT is supplied, the number of request threads is +limited to that. Furthermore, if MAX-ACCEPT-COUNT is not supplied, an +HTTP 503 will be sent if the thread limit is exceeded. Otherwise, if +MAX-ACCEPT-COUNT is supplied, it must be greater than MAX-THREAD-COUNT; +in this case, requests are accepted up to MAX-ACCEPT-COUNT, and only +then is HTTP 503 sent. + +It is important to note that MAX-ACCEPT-COUNT and the HTTP 503 behavior +described above is racing with the acceptor listen backlog. If we are receiving +requests faster than threads can be spawned and 503 sent, the requests will be +silently rejected by the kernel. + +In a load-balanced environment with multiple Hunchentoot servers, it's +reasonable to provide MAX-THREAD-COUNT but leave MAX-ACCEPT-COUNT null. +This will immediately result in HTTP 503 when one server is out of +resources, so the load balancer can try to find another server. + +In an environment with a single Hunchentoot server, it's reasonable +to provide both MAX-THREAD-COUNT and a somewhat larger value for +MAX-ACCEPT-COUNT. This will cause a server that's almost out of +resources to wait a bit; if the server is completely out of resources, +then the reply will be HTTP 503. + +This is the default taskmaster implementation for multi-threaded Lisp +implementations.")) + +(defmethod initialize-instance :after ((taskmaster one-thread-per-connection-taskmaster) &rest init-args) + "Ensure the if MAX-ACCEPT-COUNT is supplied, that it is greater than MAX-THREAD-COUNT." + (declare (ignore init-args)) + (when (taskmaster-max-accept-count taskmaster) + (unless (taskmaster-max-thread-count taskmaster) + (parameter-error "MAX-THREAD-COUNT must be supplied if MAX-ACCEPT-COUNT is supplied")) + (unless (> (taskmaster-max-accept-count taskmaster) (taskmaster-max-thread-count taskmaster)) + (parameter-error "MAX-ACCEPT-COUNT must be greater than MAX-THREAD-COUNT")))) + +(defmethod increment-taskmaster-accept-count ((taskmaster one-thread-per-connection-taskmaster)) + (when (taskmaster-max-accept-count taskmaster) + (with-lock-held ((taskmaster-accept-count-lock taskmaster)) + (incf (taskmaster-accept-count taskmaster))))) + +(defmethod decrement-taskmaster-accept-count ((taskmaster one-thread-per-connection-taskmaster)) + (when (taskmaster-max-accept-count taskmaster) + (with-lock-held ((taskmaster-accept-count-lock taskmaster)) + (decf (taskmaster-accept-count taskmaster))))) + +(defmethod increment-taskmaster-thread-count ((taskmaster one-thread-per-connection-taskmaster)) + (when (taskmaster-max-thread-count taskmaster) + (with-lock-held ((taskmaster-thread-count-lock taskmaster)) + (incf (taskmaster-thread-count taskmaster))))) + +(defmethod decrement-taskmaster-thread-count ((taskmaster one-thread-per-connection-taskmaster)) + (when (taskmaster-max-thread-count taskmaster) + (prog1 + (with-lock-held ((taskmaster-thread-count-lock taskmaster)) + (decf (taskmaster-thread-count taskmaster)) + (decrement-taskmaster-accept-count taskmaster)) + (when (and (taskmaster-max-accept-count taskmaster) + (< (taskmaster-thread-count taskmaster) (taskmaster-max-accept-count taskmaster))) + (note-free-connection taskmaster))))) + +(defmethod note-free-connection ((taskmaster one-thread-per-connection-taskmaster)) + "Note that a connection has been freed up" + (with-lock-held ((taskmaster-wait-lock taskmaster)) + (condition-variable-signal (taskmaster-wait-queue taskmaster)))) + +(defmethod wait-for-free-connection ((taskmaster one-thread-per-connection-taskmaster)) + "Wait for a connection to be freed up" + (with-lock-held ((taskmaster-wait-lock taskmaster)) + (loop until (< (taskmaster-thread-count taskmaster) (taskmaster-max-thread-count taskmaster)) + do (condition-variable-wait (taskmaster-wait-queue taskmaster) (taskmaster-wait-lock taskmaster))))) + +(defmethod too-many-taskmaster-requests ((taskmaster one-thread-per-connection-taskmaster) socket) + (declare (ignore socket)) + (acceptor-log-message (taskmaster-acceptor taskmaster) + :warning "Can't handle a new request, too many request threads already")) + +(defmethod create-request-handler-thread ((taskmaster one-thread-per-connection-taskmaster) socket) + "Create a thread for handling a single request" + ;; we are handling all conditions here as we want to make sure that + ;; the acceptor process never crashes while trying to create a + ;; worker thread; one such problem exists in + ;; GET-PEER-ADDRESS-AND-PORT which can signal socket conditions on + ;; some platforms in certain situations. + (handler-case* + (start-thread + taskmaster + (lambda () (handle-incoming-connection% taskmaster socket)) + :name (format nil (taskmaster-worker-thread-name-format taskmaster) (client-as-string socket))) + (error (cond) + ;; need to bind *ACCEPTOR* so that LOG-MESSAGE* can do its work. + (let ((*acceptor* (taskmaster-acceptor taskmaster))) + (ignore-errors + (close (make-socket-stream socket *acceptor*) :abort t)) + (log-message* *lisp-errors-log-level* + "Error while creating worker thread for new incoming connection: ~A" cond))))) + +;;; usocket implementation + +#-:lispworks +(defmethod shutdown ((taskmaster taskmaster)) + taskmaster) + +#-:lispworks +(defmethod shutdown ((taskmaster one-thread-per-connection-taskmaster)) + ;; just wait until the acceptor process has finished, then return + (bt:join-thread (acceptor-process taskmaster)) + taskmaster) + +#-:lispworks +(defmethod handle-incoming-connection ((taskmaster one-thread-per-connection-taskmaster) socket) + (create-request-handler-thread taskmaster socket)) + +#-lispworks +(defmethod handle-incoming-connection% ((taskmaster one-thread-per-connection-taskmaster) socket) + ;; Here's the idea, with the stipulations given in ONE-THREAD-PER-CONNECTION-TASKMASTER + ;; - If MAX-THREAD-COUNT is null, just start a taskmaster + ;; - If the connection count will exceed MAX-ACCEPT-COUNT or if MAX-ACCEPT-COUNT + ;; is null and the connection count will exceed MAX-THREAD-COUNT, + ;; return an HTTP 503 error to the client + ;; - Otherwise if we're between MAX-THREAD-COUNT and MAX-ACCEPT-COUNT, + ;; wait until the connection count drops, then handle the request + ;; - Otherwise, increment THREAD-COUNT and start a taskmaster + (increment-taskmaster-accept-count taskmaster) + (flet ((process-connection% (acceptor socket) + (increment-taskmaster-thread-count taskmaster) + (unwind-protect + (process-connection acceptor socket) + (decrement-taskmaster-thread-count taskmaster)))) + (cond ((null (taskmaster-max-thread-count taskmaster)) + ;; No limit on number of requests, just start a taskmaster + (process-connection (taskmaster-acceptor taskmaster) socket)) + ((if (taskmaster-max-accept-count taskmaster) + (>= (taskmaster-accept-count taskmaster) (taskmaster-max-accept-count taskmaster)) + (>= (taskmaster-thread-count taskmaster) (taskmaster-max-thread-count taskmaster))) + ;; Send HTTP 503 to indicate that we can't handle the request right now + (too-many-taskmaster-requests taskmaster socket) + (send-service-unavailable-reply taskmaster socket)) + ((and (taskmaster-max-accept-count taskmaster) + (>= (taskmaster-thread-count taskmaster) (taskmaster-max-thread-count taskmaster))) + ;; Wait for a request to finish, then carry on + (wait-for-free-connection taskmaster) + (process-connection% (taskmaster-acceptor taskmaster) socket)) + (t + ;; We're within both limits, just start a taskmaster + (process-connection% (taskmaster-acceptor taskmaster) socket))))) + +(defun send-service-unavailable-reply (taskmaster socket) + "A helper function to send out a quick error reply, before any state +is set up via PROCESS-REQUEST." + (let* ((acceptor (taskmaster-acceptor taskmaster)) + (*acceptor* acceptor) + (*hunchentoot-stream* (make-socket-stream socket acceptor))) + (unwind-protect + (with-conditions-caught-and-logged () + (with-mapped-conditions () + (let* ((*hunchentoot-stream* (initialize-connection-stream acceptor *hunchentoot-stream*)) + (*reply* (make-instance (acceptor-reply-class acceptor))) + (*request* (acceptor-make-request acceptor socket))) + (with-character-stream-semantics + (send-response acceptor + (flex:make-flexi-stream *hunchentoot-stream* :external-format :iso-8859-1) + +http-service-unavailable+ + :content (acceptor-status-message acceptor +http-service-unavailable+)))))) + (decrement-taskmaster-accept-count taskmaster) + (when *hunchentoot-stream* + (ignore-errors* + (finish-output *hunchentoot-stream*)) + (ignore-errors* + (close *hunchentoot-stream* :abort t)))))) + +(defun client-as-string (socket) + "A helper function which returns the client's address and port as a + string and tries to act robustly in the presence of network problems." + #-:lispworks + (let ((address (usocket:get-peer-address socket)) + (port (usocket:get-peer-port socket))) + (when (and address port) + (format nil "~A:~A" + (usocket:vector-quad-to-dotted-quad address) + port))) + #+:lispworks + (multiple-value-bind (address port) + (comm:get-socket-peer-address socket) + (when (and address port) + (format nil "~A:~A" + (comm:ip-address-string address) + port)))) + +;; LispWorks implementation + +#+:lispworks +(defmethod shutdown ((taskmaster taskmaster)) + (when-let (process (acceptor-process (taskmaster-acceptor taskmaster))) + ;; kill the main acceptor process, see LW documentation for + ;; COMM:START-UP-SERVER + (mp:process-kill process)) + taskmaster) + +#+:lispworks +(defmethod handle-incoming-connection ((taskmaster one-thread-per-connection-taskmaster) socket) + (incf *worker-counter*) + ;; check if we need to perform a global GC + (when (and *cleanup-interval* + (zerop (mod *worker-counter* *cleanup-interval*))) + (when *cleanup-function* + (funcall *cleanup-function*))) + (create-request-handler-thread taskmaster socket)) + +#+:lispworks +(defmethod handle-incoming-connection% ((taskmaster one-thread-per-connection-taskmaster) socket) + (increment-taskmaster-accept-count taskmaster) + (flet ((process-connection% (acceptor socket) + (increment-taskmaster-thread-count taskmaster) + (unwind-protect + (process-connection acceptor socket) + (decrement-taskmaster-thread-count taskmaster)))) + (cond ((null (taskmaster-max-thread-count taskmaster)) + ;; No limit on number of requests, just start a taskmaster + (process-connection (taskmaster-acceptor taskmaster) socket)) + ((if (taskmaster-max-accept-count taskmaster) + (>= (taskmaster-accept-count taskmaster) (taskmaster-max-accept-count taskmaster)) + (>= (taskmaster-thread-count taskmaster) (taskmaster-max-thread-count taskmaster))) + ;; Send HTTP 503 to indicate that we can't handle the request right now + (too-many-taskmaster-requests taskmaster socket) + (send-service-unavailable-reply taskmaster socket)) + ((and (taskmaster-max-accept-count taskmaster) + (>= (taskmaster-thread-count taskmaster) (taskmaster-max-thread-count taskmaster))) + ;; Lispworks doesn't have condition variables, so punt + (too-many-taskmaster-requests taskmaster socket) + (send-service-unavailable-reply taskmaster socket)) + (t + ;; We're within both limits, just start a taskmaster + (process-connection% (taskmaster-acceptor taskmaster) socket))))) + diff --git a/deps/hunchentoot/test/UTF-8-demo.html b/deps/hunchentoot/test/UTF-8-demo.html new file mode 100644 index 0000000..b8157db --- /dev/null +++ b/deps/hunchentoot/test/UTF-8-demo.html @@ -0,0 +1,213 @@ + + + UTF-8 test file + +

Original by Markus Kuhn, adapted for HTML by Martin Dürst.

+
+UTF-8 encoded sample plain-text file
+‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾
+
+Markus Kuhn [ˈmaʳkʊs kuːn] <mkuhn@acm.org> — 1999-08-20
+
+
+The ASCII compatible UTF-8 encoding of ISO 10646 and Unicode
+plain-text files is defined in RFC 2279 and in ISO 10646-1 Annex R.
+
+
+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), ∀x∈ℝ: ⌈x⌉ = −⌊−x⌋, α ∧ ¬β = ¬(¬α ∨ β),
+
+  ℕ ⊆ ℕ₀ ⊂ ℤ ⊂ ℚ ⊂ ℝ ⊂ ℂ, ⊥ < a ≠ b ≡ c ≤ d ≪ ⊤ ⇒ (A ⇔ B),
+
+  2H₂ + O₂ ⇌ 2H₂O, R = 4.7 kΩ, ⌀ 200 mm
+
+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 € │         ║
+  ║                      ╰─────────╯         ║
+  ╚══════════════════════════════════════════╝
+
+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:                                          █
+                                                                      ▉
+  ╔══╦══╗  ┌──┬──┐  ╭──┬──╮  ╭──┬──╮  ┏━━┳━━┓  ┎┒┏┑   ╷  ╻ ┏┯┓ ┌┰┐    ▊ ╱╲╱╲╳╳╳
+  ║┌─╨─┐║  │╔═╧═╗│  │╒═╪═╕│  │╓─╁─╖│  ┃┌─╂─┐┃  ┗╃╄┙  ╶┼╴╺╋╸┠┼┨ ┝╋┥    ▋ ╲╱╲╱╳╳╳
+  ║│╲ ╱│║  │║   ║│  ││ │ ││  │║ ┃ ║│  ┃│ ╿ │┃  ┍╅╆┓   ╵  ╹ ┗┷┛ └┸┘    ▌ ╱╲╱╲╳╳╳
+  ╠╡ ╳ ╞╣  ├╢   ╟┤  ├┼─┼─┼┤  ├╫─╂─╫┤  ┣┿╾┼╼┿┫  ┕┛┖┚     ┌┄┄┐ ╎ ┏┅┅┓ ┋ ▍ ╲╱╲╱╳╳╳
+  ║│╱ ╲│║  │║   ║│  ││ │ ││  │║ ┃ ║│  ┃│ ╽ │┃  ░░▒▒▓▓██ ┊  ┆ ╎ ╏  ┇ ┋ ▎
+  ║└─╥─┘║  │╚═╤═╝│  │╘═╪═╛│  │╙─╀─╜│  ┃└─╂─┘┃  ░░▒▒▓▓██ ┊  ┆ ╎ ╏  ┇ ┋ ▏
+  ╚══╩══╝  └──┴──┘  ╰──┴──╯  ╰──┴──╯  ┗━━┻━━┛           └╌╌┘ ╎ ┗╍╍┛ ┋  ▁▂▃▄▅▆▇█
+
+
+ + diff --git a/deps/hunchentoot/test/favicon.ico b/deps/hunchentoot/test/favicon.ico new file mode 100755 index 0000000000000000000000000000000000000000..30c7eaaf079d29700b53b04221fd1920f24eb6c3 GIT binary patch literal 318 zcmZQzU<5(|0RbS%!l1#(z#zuJz@P!d0zj+)#2|5eAT2G8Vdl)43}?=qVfg?5KR%_@ zkTY^J02`yIr~sy&oE*S38o|N>cQu@WrUb|ZITwc0-!m|%v;+N&tR5I14a^J-57-$P PJ^=9#ApQ?j2h#%pA;BDW literal 0 HcmV?d00001 diff --git a/deps/hunchentoot/test/fz.jpg b/deps/hunchentoot/test/fz.jpg new file mode 100644 index 0000000000000000000000000000000000000000..6ebe67b65dccabc3550d30bd84011f27c44e6970 GIT binary patch literal 21001 zcmbrl1$Z32wk6tTW@ct)jALeY%*@OTF*7qm%xuTZ6t|gTW@Lm03=9k){jmYw*8ySxXhT5(@3ZsC-bzE zNMv|}vv|2oWOxTw=@ycyv8yLw+4!m)<|WW})*{)TNI6WUEzE1xV1#g>)l}@9puOo3 zl|5C>BrZr36K!~Ms~cKEI=u!Fl60AWKz2y(P~Id0Fz}A4LM!T!Tlb70lSCi|_whmZ z3F#92ZhDG(XA6SAResicoi{aZJ-xl02WRiIvtqDtnk%>O6FWElfOW5=>V9;IC|1&r zbTDIm&S2OgLKo*Vhm~$Qkd8ku^?~=Pyr3aZPB}bo!zu?nyCnI->2~M1%eXf-PauT=eHri}_HuEeHyF9@fmb^Cu5( z+;w*vwu~sO&W(HuogrPz5oxe^$taI1)OQuplALj9+l9n=YF^hf5g`EtSga(d^=MHy zEYyW`#Q9qTfd+o>0TDTUdbEs*Gxj3NA?OsPsq&l}JW&8ZQ}$?6xG#ywoYqd~KK3)Z z>MS48n0j@JYaa(lAJ5X8vbI>}m-VHCt$Ng+>gQ;Ms-g zH+-^!e8~yh8*^a~L@8#x%2Oq1>3}ddiq%A}y-y~YINhWeAna1G{@Iih&EwS*j zF?DI97DQ899L=2Q6|QA{ado84+=+o;i4b`lnKlaiOj@W46~B zB;#+&&|&r5m=!K*z;=wAG;lIWVReZT*F;O7U*xbK_ck-V1i*QT}fZk%LHaJ|Oi zrLdx|T(=yG1gugm#2^aSkfrQZ)>RrE6F2HZN}5P1zCnShXGa=3VbTFy3*m;%na6Jpcat=5S>TQnA=|F^{j@( z!YV~nc%_uDn@tO$X@8na3%A^UlTU5p*E>w%^M$BC3WI(Jz%}7V`nclB9D@tK1GHB= z&@lTUj~R$tc;M6*rI{@(IjI9m_U$FvezD>K0A_G#OPHgrkYJS!tmgEj#lpm2oD}rE zm<&qTU%dx8!9#UkTc_(zRY$C=>~3iYvtbh|!f_ zs>maAj+LhZqx?pRizz7YI9Yb@bv-(9GS-dE zBz7IHl#&&ye$#E`&yy@rb!gg+OF@Q1{S|F6t!YVQrsDZna1Up$me`I(LYSBI!dX#} zKb9gduA76F1%wszH3?P)5)l#+4jzm*EWOS970l6I#7BPc7uz8sE&!kdfW-x{*`7Pz z`gqHsn3gjhLbf5wWC3C!!Jz*+)7U^WGc;PHCdzRu{6G^jH(^(?6Em0g9ydbg-pQ0W z_BlZ8BwzyZ< z>f4;DR}D!SnBit4Z^eoDa6x4bf2ofjcqIy0uNQw+n99njHrz?M3s@yMUX^iYR)IbW zuCQ;?lp^yul2t*K&-3~D6r-KFgU1`X zsX5b;bRbE4W@fA9@m04>X`%0{dI$H2S(|LJy#d);aZ8J%HRewn;2OWfOiYHGNtWeX zImE5g+bh&{TW?R$AJ^sd>LF~+#QSl)S)V``{MJZfTncJKHR11Pj^}*#R-3Wi1;s0d1hO5 ze!IEQS*-EY|1$CPRGw<#9d^#JJow&RTY)Dkcjwb8FGu3p#wSGiI30%^l0l%VXoM;+`}fHm68h$w_*VdksIMxE>FUZELKPzhL9e!qZMosB{@@ z+aqCoSTqt!c{@B_&f(!BTAWas51)#np(-b%!Q`Qo;Gkw1TZ$I;8YOx01|4A+em(fqVLckwe+8mH64Bha`-zz_@@_3fqQ1RUf&*O5Fc{mI!Y&Em7l z+mzL*#`xY+`2w8zU4{*Z&~)PXGf=;(jUM08O5R8q(>BR>b*TiejYu;t* z^+O`rheZGCH}5`gNKe7!@0`1giEHc>r-7cB?wW}vu0;gwX*w)BHL6~BhYgUP$lFl{ z_G!VI^e(N10-henXfBLGymb9}x4K!VO-=U)InUE1&oTkMpO?$;QYWn0nwQu$!dcl} z{Hp*5OkQ1fil2Tv2__1-BsiQjU-Ru*;xAS9co)!8A%dZXc@4UvHvZ11Q;4L72o1VD z82tIzHrk4S@8W5g9JeVq!TAn2^YT5Rz7RC5m#bduY-&w?(nZ&1F2tb$F3s-6+3EV` z5)_Xu&@XZ7>L=M&*<-ZkHh6L?*(|uOTIm^nfv5`POcq`u04bR8Targ$R1MGi3_B+k zMo3x>r7!8Kh46c2Sr)BF?{1egyk7fv-yP6-Zp`U}M3K@dtr4n;0Y|z<6`M(Z{E>gm z&PFV{uO3yK;}fJ#z}MuRHpk^Ki{zPG1?Zn2iz{F7A;9$3+d%NKcfV!mt&H$ z&krdB5P;^=SqJ7-8*MHhPpW#=qD|AUxAF+XSElXDklWKHWi!7ze%VHM&7Tk+M=X(n zc_-r2TPhn&8HYOMqR-_|#}*gjTNL%w$9Q)p=5qIr@p)>U8*NNyF4Lc%dx@WQdrIn` zdB~};k64Cvq<2c^rmBLnb?zu=5zn~qKgr=Tx(2eg%A&A10=IQ&H)F{?y$jbq;a6;? z+T9&S6~-3iyQ%9VXTxYiJ_2ZFe%M;j1fq)$+|BrFxY|(GI}#W za6O#V|5^G9)%6{4@j1G7Q|UP~iqsKFUZ-Z{VjeM{FcWSd9LF@llm$^^Nr#D_yK!w| z5Nj9wO2iA$9*#!%ajCd=muxN`Z?cU7nGU53U|e(|sL*^3R)|t0l_zE~j@1*cktLri zxNyu(?`H4TS5__LUh>rM%;P57WuP(->;p0)-!dZnb0~e0o7dtmG!7j0-6d5DXjQ~C z+NIL0e#jqla2u7UjO{t}$`;RcObS``7NHblo{!s3j>M0~#`1uS!ySpbh5q>J{uHBq z2OOP3O0_d+f9*B8MPRSzpucgc=b^tzX5k~ZE$cpE;qN|U;b)izpIL=tBNVt@eVZVb zX!bS}gic=)Hbc;8Q9oX7W>)NK);f_!;Qdo`Ly|2~lRIRdZIU8SbJ)QG~kkM1~DUQSLs24T!~FPJbiVbT2>@oD(dFkkNQ3UM=7 zpl;s=i6yN#-7p_A#7=}5x1u5x4L`q5-vVh=%LvY{Zfy4sIMAYEJ&jkuxZrBWRC}bm zOpRmiOb*zo-4ZD}An>-t3p&JQ>S^mTTwq&c!j6$BcMPj?yVyjTL2i4_Fgu@!v{;pu zYA`s+3M>mGHvJuhCc_gxlSrmuw5V{bq|Sz8 zfK;Ag4tzR2AgWXN9oF#1COq6&i3DX&-i^Z@ z)g0Df1{qd%unBNibbP)>&R)(cCcO@~Q&GZQqWzW=1xgwFO_K4b@H^&SzTNd?I|Jup zdC<~ppH|VEoMTbln8!+xr_SD3p1@!upYql2%w?lR=N&+tO^f@Y%`~L_4xnRL_BIa( zDl5eAZ>G4qz2qE)zvW0YST?vAAmCOjL$pzg-N;&4TX&!^}2swT^JJHunb25=BZd-|-fWVu1wry8XV zRB~wL=#G2yz43W{p)k%~rR1S|ZcZ2YG}J48qz%AXMIIj>kAQsnb|0@nm~`LL3RoJf$C>`pTmjCo^6W39^ov7C}u6nwyGBGxAlo zhlNu4ReWS=styfKe9p2-TFG2_tjbYv_0k)mKe?@XNCc+eC+$=(o512qOuPQc=6AsC zZ2Ewb0gb9D-RMzpk#xI5PVsJ}X3M(fuCvr2WK4KXy~Db}cKaYP2N_zZ5Msokp4Fp3 zfn{83{Ql!`#)6N%Goy? z^uRTAX&bY#jMGua;;Lux0Z%ylrh^`s{(;+YIviMBHVh8_8>}0%@qdB$+k3{GeUtwY zA{Voffz!dv;-YKt7q<6JUVES#y8M9Cmphp1|H7?xhv)0Hf6ZrTfWMl?f4853p|gQQ zUmU2k_4k#ZUig z{5M2N8%JV?o)?)4gWMwTWyNv)Qg zQlC0M-6OlY$z6@OSb-B2#_Mff!q*b6CS~KG2a@$5)AfglOKnO!_4+S)*~w{R)2aK+ z!a$D;Et?3%b1!cWSETaau)rv~92gD2qDdP7qeZ+J7)2wEYpx#U-$KK1MW}5O$~t^` z2M-go;T^@?B7hxW<1TZc6^~bW0|9wx3*tz_3%>SCbmJK3zS_w{rb@!g#j@b#OUW>K z=?EOPXZBRhwNyWaf1qpiO6uwn{kY!5M&&e|>b5z)t&sXi$*-V-XKlsYxy z4_Mm?_S51};EGw^6R?V|>38;z_hi9CN-CKuWBKy#Tf6Nm| z%W4KG?M8W-G(dxF;->`g5qO2u)wWsnCeKS^J#nhbj65{(K zRr{A%qOCt=s$@=t=4bC(dGzf_{p;@`wrG;eylLQD?2t74lzCUmWyS2#U#^UN%TBY{ zVy2bHpc7-x&ZvjoLg64_KUT|0pA(hbR`BshV4~o(gQkFBkxZ$zifl~G?Y6wX`6#ub zNRD)<-6er*tF`TbkW$i;qDFDJ98F39v@0b23=add8t;>IqVax1xOHqGNS^Mv~QA-e8jqnkcl?Idx zE_+yKbnB4asHS!T<#FfQ`aMIswI(4CLqmTxl}Xemm%G2udK?XXQe)vM-Ry+7%({J5 zHNdP+(F?=YMf^G#mnx8uPju0fb(vlqhJaiz(<2tgbTjxM8*BW4s9!hb^6!nUJXDK1 zN&_84l>v3}T57DE1u-{-&clYvjNk8$ zV(_2lPKczy?v3i$NQg_9F+iRp|3ZAJky->SeEJe~f9_*Vu9S`*QLPZ1yAczN)zH~M znh6#mqqe*4b0yF%%{JRrqz@r+o!MmlN3kHDP>a|SRy_S(ZoN)=sgovDHnzzW17~$~ z{H%cazqqDT;oUZH2b*DOxge@S;Vd#mJn`w|EIYtDtW8>XY(^W&K@JF~cmS8V$v#)o zrKRX`MO9-wcSMzOs41B7t@LbFeVnlqBB#Y!b0rkkwXsWX4nts2zEhq$+Pa=>*lU&H zfhYk%%qJ@(g<-4DHnxYkdllr0y%y#&mW&7aO+Tg)cp0vX9{zPXi{Akj@G`H$>J=%d zdn;o8bJdaG%iPgxLv#$Iva8WrP|h)Q1v1&pgB{=%8#ZM{ebfC?^5^W9YUGVO@5Wj$ zynbU@Fl9qw_w44tbwOo1YSw_7#%CA=YYzNz#K`X;`Zk<#k87wAVsm%zE9BWAwYW1C zUln14dAX?kGC;FVB1zKP1JaA0Hf*#KU6PcswQYJHYt|!BcO|J!7$IGL!8)fRY^7FOK4u zLpgob($Xg@8wB2}pJ!}zBHWJA0@{usvwC6V|ihZja$p0p&VTk~R)%9?v| z*3mj9HBikQ*J`x;J!xM0QLM1Rt8D%#Gc~OJu!D`mSt1!3@8JGKiZf)NNM@rp_oB+w zx(Qds;7@`m9=mr(r_@dZ&+9If?^o(8z)dKmUNFzkvC7i*X+Vemt&UOb)jV z-OwaEPS|&l&KKUFe-^UsJ%5|vFS_`bC=FG=1E2|v#FnL_BOhInxHBG9O%7X73gX`Z zk*a;A$V>4D{N_4L_!^?te zg0X5Om;z()5qDi_1~loVMo3pqhmB^unf$1|LYP#jH<@byMe{eh_^yiPp=Ni|DW_U8!*s*=nTtuOGOF8<-%LK{2HeURYp0I5}%YETQFO|wY>mvLYFNKKZ zS{;PG_QGVW6?-t9{@QSCyHx25=dp~c;`8wbLf`aKk6-uMQV|;%q+(|1OB;HKuNv_Q z?bkZ|LVH72$A1#AiiA$4> zlld2~{|^5nX~*G%?!O87_h$bg2=fsQ50+~?Qc&|lwV^}(P-VcuAi=?){=>Bb41h+) zCW5MB>`WSzRM;>ud&RnYE&QKLQ=iH9gc;nXP@=p8a799Kb-%m=J{>xYq9vsq0Z>I@ z0qrQlv=@eNvyh}>h^zyMtYXky8jybs_p;vlR@vSG5oaVNeajpIp?%(m`7-bkr5vmT=3Z6@AJ5M^4RAXv=j907o7hD z=uV9Rt$petGtT@Dsc7$SM{CimInX2oqbq#-koKHZZG-q3ZD8eXhtQKy(H zvB#hVjgW4W5#DnUm^TbA!(=;r^-dsCKh+_L+y+_T=>3yJ*dGd!92g?6fpMcxv6Jjl z8j09rer|3}x7*ro^8^RC4~y&?AlLLC!z>bq6Zu-{Zp<+o?BUm~Y$S)~@v2XA8Wg|A z?KN4t)!mm--dWNl(~nr`4TeN?0NQ3 zRcqa-;jkh!h7XC&s3y)@S~x8AA!z4)WQcU%1#Of2XW47KBZz%)T z2`$1ZV%hc8()D#Ye91IZ^#AiZzHv)u@g1DbNCT5_pL)XjBnrFg8Tvcd) z7_*2s+~JzsV4*+Yh_MCE2V`0uH^d)tOP1}E#TZ&!LaAUQ;UN{r6K3F(x75t;;`U9( zsR4F!dc0EU8^14*)`ZVRGTK?6m`n&nsThE5nR8E{HV8)WsDzot6J_a_n+D!70IEI| zt4oRpubktDvP0TNiWw2TJN97jpsG5QIo2e*+x<#i>ufQ7gB{>jq~azazlPrr@~4>c z=^jah#3AuhzD>p^eojKPuo#oOuh?z3fpE|hLbC@5p87sHA>45_%0ciIFEN1> zk;0NJ!K-wsh%%EiYoA;59)ym>uyF&rUu;;)%ao!qO80)^Bhx44R$*M?P|h$5VJV#! z2#Pakv~v4a`Zt6)*vW87PS5gZgnoL!G8YdNU?GxFh2;GpYui<=cdB&PFpd&yb)(5J4iVO7uzL8)JhZP7!IW25hNtOE zk!vopmB0k04wW`%|AJ#mmNK($a|6p7xd{>$(AZM-q>*PiZoAN3JNox;2{&gafwymK zYXqbhpF2HVfvTg(u7sr}wrpp;V}|23;gQ&wPZrlCjKhu_6+{Z=*UJ{Hesnw^6Y2%%y5wDjxXHsWmF$n*Caq(Dp!zV7%L@ZsoAdQ<%*%AwL0Aq%0NOP%{s zzF>ho;MTMS_oO=e09<)dIU7uK^RzUd$>|%=q58NGxaj63@xM~Y0oWN6(*VSUicy&Wy!`L zgWs8OD}i8BiWBmTnm~k9CGxL|Op>Y01d6aGIoV)>Xc&R*y|7@{^I)C3tJlzaU74b^ z9vhEjE)Lo20Z*)U3q4>Rpym5oAs~Ge#^%dg_tcaBxHi6vq z+zI2l-sgtc0Ep)w^5xI0<9;b#5tVv+b-ICdx=GQYvKH{d3g2$YXywJ-zTe_@6|uG# z8pmgF-W45+xOqt7t_AaCjj)OM2uSp$wP#Y+nNJp-wvj7hB5s@)5{@4cxOS46cioVf z?%TCzS$8q>#>OGSa!*_QzF|yCmCXfSV|hhC9QTGwjz~3k;zyxu#z2KY>m8LYSGqH_ zwSzTRxy+7HZr^?BgyJjh7w75REm|HzBf;mV)j%i;>NXxE1qS!9Z)XxFs zv)WC(qP+u12vQ~Mn753+sH$2CD75R@8!&%bUx}<}wegV2s-h=M5mBzSoV z{d2{TyfdS^SXaQGE-*YLD83aAMa>wW6g{GzLGUMv0mD1ZxHFX~(0n4@o#9Q9y&}f{ zS}Pi@Qn3pyDY6@XvpfTBbMpZR_^Q@3jbc8|kU4SRgc5~;5Gf+XQ<*?{hu&d8>d1*~ z!$kq)LRHb&4Vv=GdT3D15=TUGzeb4fP#p)Ed!xMhe-CK^IS;Bdlc+o?NirkjDFuHh z`2x5#!0w1com8)o8cKI_?ypqW1C^U084I`@mHG$VO%ciDSef}GPkQAcKyM3mSs>QR z41Es&^W$5iS{pWg1udW)(x&u>-7hvW1EYA=&Txt<&EYcCPFGh;nK)q4fu86T*$SyS z6?&BT6-{J7Vq0N{T+n=Ki_H9cMs2`-1+;MY@A+Um>irL_3hss(MLSZ+`Ojb=y@NbyvhVN%FY&=fp5rVf{(6X zBQJbU10o^r`T6v#bnee1H}<{@+(u_Ax2^&Ve2%xNj1pZ#^0ytH!Y!=9PB}(T@^CaB zwmTK$PK?gVPaK0p8VI>*;Qc1$%_>snBHu~2Bss0oPofUuNPFSfQ{nb=Ve&hGv-RsqVCw-trp_b>DpOPuw!FQ& zTl>a{%DReLq-bF9ai0`hyABB89YI?;>BTblLdChlIn)uoCfu#` z0;WHoe62LQ3TU29C@-evj?npN@Emx}{dL+1!2>vZzTJNICnL*gyU*Hbl82;Zd2)WE zbbx7s4hIzl?nluoFFI6I=N_jEF#SKK`bT$Px5_5dVu7T`vIKsQM|w7@L8T z;7`#vhEj1)G7vO_J_~-q`PJFr4x;|#m=zYkx@J49oBN+b;>Cu1;d6nPX<0zbALAeO zW;Xf>iPTSiQtqg9?LX*2plEd}I|HY*(gfZ3*I`nOP>W2%{SAtMB(3=Gh;c@#)WbB3 z_xUD~g9_S66pA5&Gm|%;SwCN-z60#uZVFy2$Bj4=qB_bTZ0h`fm4z=ZI%L|eV#`^? z%pJ7d7G(DJSqsZ+eW9iJM=7NMnKjy( z$OduA6jGmzc&VMZ3mO4GPks9#S*M@`6DJ!sRkv5duG_fYZShPvVGpvEf1--|G)E&< zv8(n8IW{lrb@$8ARIdBRa)3(P+|Wa{v{r z_3P115OhHmp0V_=OzA|$}IK=_(Ca$s%ehE+B)$`{-DubIqZkrQWrq8l@!O5d(}73 z(XPAR-i=o{y^xSQ!mq+VMEMOhrt|#74A@mPZz!W(btMncNO+?Wbm+4Qj7SR6Y-{lh zeb`cc(bcTfW96g*09g zfiPUV2RCl4_WJP|CS_e4FQwwGmaS~}C16SzJ51usX5Rtv#9!~=*)fG;*j3Zz zKI|4dhB;exSB2c3Cp&`Zj}b_s79C&j>bBJ!!<|2@yQ4Rd{5fueGOb+gM_fRRNx|Wv z4BGt-Mv4Abfo`(c379mo4aJ@8{^#5^!IFcF(CVCl6GKD+AbN!{p2M(8HRvlZyfY@-0Egvl?h3;^$dV3OTThK2=W@t+JYDWQl*LPhp3 z1+38n7?Vxky($MwXW?7Zk$a9%N4tIn$K3wa9)~!ZI&zQb-0}3>3?%d zI4}56u>bjp0RZvgCWw0_%TTRQPNW6mngenSWxs3#y9XI?!zv{9u#<s>Ev~&3FU-sk-gxm1i=U z2O@ru(24U`$PneXg@~6=+lc^JCobHZLEOzo%wh>J+)mODV+`&!81A(g?Dx1|f^n2P z=;h~af4X_Bu7eO+Cjq(5R~XZ5bo>vFPV;qlH=lU^)bxzhxz0NhGmkM9t=Sj(USwy} zWUuYC!XNd1SU-r-KAdgAKE5IO$F=yM1dL7C*ct7^J(u+#lgHl$b5!a2($XrOf5JbR zzlD$A-~7LJbehMWrsWY*9{gTzp2jR)odSIspFO2K@99s5Xg`k1xmEJk7d3 zkdMM;{FtYd=XM0?M;Rxd*U3}j^hfn{aqGE zz4RsIb=n<_K>qg~4ad2DMVE>P-6M`)N8m@M=t5#GrUl1_dEp&w*q`k~OAX zB2~O>L^M#RCNNDFc#Il@3bK90HRmLaUyL?hP;jI%7d&r z-6Nw>SbTu%Z-sjYkO%Y^+|s;$NH9p$0)X?(GDdS`$b+ zX|Wah{D> zBmos{?~mar3itH(K!RFabf1GFTUOwXZuFgRf+N}sBW1yZvxjVR7#`l;Zlo! z4#w!atgYN5o5W){uCf!UZWF@x!a+oebA_fNyH9*M0`Bg)q;b5>7Te2^dB!5iq%?tV zhQ$@IiE)24FTuX;5&^*E3^M^Ltz+^pRLF{+t!AH`a~bRF&{!zW6iI5sAYkyD4B5jL zKi*nd3YRn$k&aLm=G!6=+h2Lo@od(NCz6)YP=2sNTnf0FO73e5mnbT z+t{*m#F|dwu#YQPq#(s{l8R@2L*k`4OV_@1aUNQlO5j|02pRuaK$5%qEykHv@fjy7 z2e|nTsNkrhf=X;nq#Lgq)WjWu?OOPK^Z3wFtqw-Meyih?*Qx<1_jUj0}HN`>`6}{DAQjebimorbhz;Q#E>x#}( zr-fW!0sUKn*rdtPJ5?QwX}Y>S6La6)peu_%@gQzV)}I3308F!+qV5i)k9{v`kRjdz z$%rdVOYcDx_#6WPgb(hZVC3xoVoy)9fQ3ue<#+o)pHyW@!#}*2=_Y9xR^kjnhp@i#O2iQfuyg1NS8#7ZYRBb3cO!ebu$zkkTcU2M8;tg z%~LiKhMXoUSjVZRQf_??H>L}@58NidM_Ae&+LXnf;G8i=ev0G@2bN@#ElqlHP2E6i zpur2}ia}{OWYeg>0&53!;gzIInj^-FZ>{aZ_1t(s&ayK}!Bx#xF5l++oYu&P!=X)a zoxFi=xVE_)!qFV%m4|xYMF#-vRqR8~=!u3EqeDnTh~3(L;!;-{BRF3N#CjcN$;*Fr)9bvwFcG4Na(&5R- zK@r-S2QY(sJq9n@>1+1woPqv9iDcRkvDt zV+L@+(pEX~p?oqtfY62IylIeExI@k@>X+Jk#(Gp7KtwsrYiHd@l_tA>%x>FAFYGcu z1*k0s4$|!<;hBY2LNF8A6MF35JL#BgmmPAT!_ko6}`mV{c& z(1@zJLb&3y4Uaf$5iQeotUJ?aaFwV2#6gG>j?Pn%Go6}emY2wU$fN>ci@fC}z67Ty zAwuqW(YXC%0WW$#bbGsyaC7o;X4>jpea{a8itka^SPS1vZEQux@92pG2*+iOF9I+D z4PYC(FJDZ;1{D--6f9k8V^;3)s-!x3GqN5i&z6U|uf$TBp$fC+@}vX2}fotjA*Ql zVjT4Skf%LGT^*!Knt6}~?h_Wi%H^CV$QtkRQX!N;NDBSniz(4>s@k*ULYCZ0S)V*8Nm{V<%bWo6A*jY*gfa+@HHvQ{=DZLy|l;%{!(;!(4T^% zEf65&iUdKPZB@O6vVmW%zHUo#Hf*@_B*WHXqhY?uUQb*mgaC;nk!@tGp36li+W_>` z>01D6$r!;%R&ye#uBFz^ts2Rchx)J#qP7Tnrwe+=BX>)xQz>bp0-$et*oGZ`Wzyso?Zo}y-18n~6udIy_>cgv)OW$QDH5r|^eGqrZJvmy zJ%+h)F>yG;Zp0RlhHUio(>I-kRk%foG0WJmpi;!!=JT$08evhx>6h`HMP2YZy^2dd zX%aX+dcIa@MN+=9(mVv4AFfs-fwh+Hy8cJi)tO*lMr7!;g+N1fZ5n!&l>Bmd_7j%6 zLKApXdwP@mOJOi9ACB)jV8#>l4t(L*h8~c zl8ZOQ&VFfL8QrV8hrASm`;oX%USZ-8_^H@f_PJ1TO0hFzB9@MK`FJEKtmrPMJ@pQu$_E^w>+g^fC1AR`HrAP_ysP6y8$*SI$wiqsfvC%0*I<8X_9yQBU%SR zcgvGtc^zVofDJMR*Pq7fTk)-NDDF>dG>NRTyUR~rJDr4Fdy`N$OZMG9X+z9wHpOIn zh=*i$HAC(0dW=6pH6b4XSsl7ucbL`#z(mDYCG7pSI%c@#QtTN}@GR zeH%J;EKc2XkF96z;3){S>!NyH(BH==JfkEVFoV@|1ry9{eq-DA7EtyKG_4E4Jg_jq zhzImmfjqJ-R4!8Lmkab zkuj4rE+UNwV3rOeyL+)SpbM6E?S>4(7ccKrR0#FZYu3Qvb&k!UnsCiK zy0GPBftQ?UPUto5_ir?>b2$&B8kvDiP-ed|qvM0U&?&Jmn|;I^sEg zOJRN>v_(EgKe`TtF`~}~TE%^I^g8|@*1l|D%&7{|U zgSersZel^|YiqYc1vMN!vvbA5SD5Y&%!TQc0a5+OH^=e{+d$E*u4sJZON)VP_iI=M zJ!ZE)5JOC$92AHT@|SUU+RGQ<9|ordL={&LAPiXw26#GVIcQGpn&e6y$;{kN7m;wXUzYI{ z_8Se#O(swdtd1{Bm=kP?hd_$KP|f3^#puD1bdH`dAU!x$5`CW zaUN<~lzN|jI=2w4uv2i9wpNEw2?M@Xddjc#h+di;fq%(2rE(hIBF_-fM#ECw4hN_` zqzZ*he&$d2z%>p!TtY3kE_7~R5dCXlx;<1d0t~J}ICefy%L&dY+`zRtiU?dz-th6}`+_<&C7QQRE5sHY;wj5r=sZy@n!~D#E1Grec#VeL^!E7sf zi+lWBSjthM!^~`XfUDCB*OnxPJ2~8FzBr?4Ybg4TWkbplB!x;5v=DZH^*>ad4q@nYYwMQEGIg?kt;MT^C33 z`-BAt%|t=5@?ZY1%eh7U#u8fBS;ax(Em6)e&1Kr&RD6xCub5{P6->9Z1qS=~jloXl zMXSa9Ja;lI>h|MmSx|t(ctr!&Mkty(@EK zEdg~Gu`rg#2iz8bZX6C^gtpsh8=T^?&A^zuI6vGKw$ClhMJe&rqd{9HoFL~=!tUle zAzLl*<}@v#*|;tPnUJRyW$IG&RuMuDx|O9YjGfEjpaUy}a-Uyo5@p*M1{bgXD@ zG8bqSzm6cQgK)aWVqs$z4o+pMhl-RIBb(Uo?h?5RG?a{eMD&qv-%;Ane%9mo)Mv~s zRTr?96jx5(;gv;BRY{-R2&HXro^DqP4DKuolB=|9(^kyn!}83ifN(eF2qGM3`<4p< zSZ+`naaDSY15^wbqE|;RaT>_Rg6Yl0b!zpSc#Ob40lH5R)ZkQg2qT2)se@QHyvw~A zdOe6CdT}rW0oLh$rBbtRh8~azkhc-wD*ofzuwOu6Z@9Y8s!sheQ02O-wyTZ)SW7q> z<|+)==3_u*!Yi6e^16l@!Gu*kxty%mfOl?l*^laC(HDoo!J5kdGHO8pca~z%`2tc!7B7 zXm-r(c-o~1IJAbcZ;}n%*u)1Wx%hz$pA3%fF66UyXDgOf#DNN_iO?@eVMu8+`+y8N zfDH+?N;s31;cBrrD`-;*Bi5OMu&IrQlJuhb`Ie22tx1 zJY(1O1Y0gHiu!u^ig85zbNJatSmCC~Equi(swpLTDqx>OxtjA=5j%M0a^k7s>J1Q| z6Y@q^?i#z*r@#x2NdsV}ta+80Ql~8DXNat}T162t9I6-p0Eu2$(QV&}K{>GV2&{tW z7dfRK(Bbe#G}zH)xAtOcad{W_ISdCQ+XNu(tJGrK3Rk^?aPHXSib!sqa+R{+~*rX}3QEn9{e zEEQ45N6c$T;J6(U#hky9SSXGdkqx(=;kbZ626hsdi6Q~&@*bk;8_cCPzHLWmMq+4_3>J&veZDrVgiNBDy=AS{{U>4SEz%Bt;xbwaQm3is%qL`W^(ag#PUy=~L_**z=@`>)m{JPbE6oVN#far(Vb05c zar{4l*Wsg>)dn#YYYRBKmXNk{#Gz=bqNpVheON=4RHS94}tC@*D9ph>FZZ0;o!pb?Jz?ONNbn`o?!tH#s zq85)K7b+5paK~zmD5kzVLMF(XPkuk_M`c#Q!=F$6+zQeE0KyWufV%1fma;&J=Y|zl z%x40z%&XDZzZi0O;e#M3R{RgaV=qsz(LrA#rYOMMY;jaIkucnV0*bKgKbe?+7a7|5 z;g3TUG*g@I6Du=BU?&cKzZ^z$0d*81E?y0M!C=_@!tpm09IkNyH<;~Bza36L595e0 z6P~E$r&x@fHjvc|p`T@~&00+5PhP9YcA^}|WC_##FxT}CNbyq%4tmn8}7ICQ0cOIMy36P&H@h!AX zMCDvBk!7YeK1gfC^dWRvpD;HU3G*ofHSF?0q6NqS&fyRlCU=b|+$@%}e=XxumS&W5 zPJK%X3M#cUORw^nz?OFr?(cD_i`%Hd!%!M62AKw%+yn#QIGTUdt+19Gw{0CDa*iJ=F~E-mPU2ZJm&tOJlf*iE=G9BRY0 z@huYMJQCJ8`P>4AS;(}Gbq&BE`VWoE15+&+_9Y!g--iqeErnG)_Cs7=VYqOG!CSQP zUgc*|yUrpmixxxfU8;@zOZ7eB@XUaybT|8g+FT5Oa9SaZi5C}c%v3&@0wIV%&f|lDkP{9 zu3S-Gam@L8If-hP51P}S92$gMhTFJsG0_jX(4pj(D@A`Yqc#6k$?{{To3dsHbuQ#n+5N-fN(Qld(gD-Lrk2rrTF zK{!F9r!OuY_Qii|@drSBLMgVymOTf2GftqS`d@2U`;?N@3eSSpa?a9D5eos%h}F+u zj%7;08C1=2xYXR@(;n2mSMn;9uk*ASAmMP3mlc%YxWGUh6hHyI60O~QM<#C!Q|F9K zpDA(E!t*ee#7EmP%yQ@A7LES^@)WeI{$d8H=2eZ=vW=$ujT-wWGo6rK9;+`#U8?@3 zB;{R1mB+fov3wDF`z6Kgm|{U4*?NcqQ*BIYkgce zpD@Y4sNlWJqUG3Ld_`aT6IIVr^|-as+~fH16`-Ts=Q7l~_CUkT3&&XV8(r+&(Z9IU zI8QKmIK;(gekOi3nBhc;W@=cJTTd?%%Oi4gXTD;a3~h^k?RJdIWD4%@GgT;Bza~pF zC5+d%mR>RKOZ+&MfH|puP#~q=kBm(qJk)pr#Y}2Ep;eEBL1vWUEL(hHBT){Gv4W<% z2MvGA8}~NG;abkI0h*csx480n;EN{DchNRl4l$?>b`Slxf2>FRb~9HN1Z?^O;YDrj+&rYKdrhBh(FMka1Fcb=w)_W)X(^Zdc!G)98F z^_W?N4xZrIyzdOr@isF|@57R>!d}`2*BYsUHCbIeQh^JRwifC96RLiDbuK!=FHEn# zm08xh{{S+TixuhAxZzZV%5Y*-Rs{T5tHOqU8x*{+e-x>?T%Ury3!mJ$uyUP@pb()W vl2xvEHO7K41q7g7XO_~x4a") + (format stream "~S" value)) + when more-p + do (princ #\Space stream)) + (format stream ")~%")) + +(defun function-designator-p (thing) + "Return true value if THING is a function or a symbol that has a function definition." + (or (functionp thing) + (and (symbolp thing) + (fboundp thing)))) + +(defmacro with-operator-defaulting ((default-operator) &body body) + "If OPERATOR is not a function designator, prepend it to ARGS and +bind OPERATOR to DEFAULT-OPERATOR. OPERATOR and ARGS are captured +from the expansion environment." + `(if (function-designator-p operator) + (progn ,@body) + (let ((operator ',default-operator) + (args (cons operator args))) + ,@body))) + +(defun http-assert (reply-slot-name operator &rest args) + (let ((reply-value (slot-value *last-reply* reply-slot-name))) + (with-operator-defaulting (equal) + (unless (apply operator reply-value args) + (signal 'assertion-failed + :reply-slot-name reply-slot-name + :reply-value reply-value + :operator operator + :args args + :reply *last-reply*))))) + +(define-condition header-assertion-failed (assertion-failed) + ((header-name :initarg :header-name :reader condition-header-name))) + +(defun http-assert-header (header-name operator &rest args) + (let ((header-value (cdr (assoc header-name (slot-value *last-reply* 'headers) :test #'string-equal)))) + (with-operator-defaulting (matches) + (unless (apply operator header-value args) + (signal 'header-assertion-failed + :reply-slot-name 'headers + :header-name header-name + :reply-value header-value + :operator operator + :args args + :reply *last-reply*))))) + +(defun http-assert-body (regex) + (http-assert 'body 'matches regex)) + +(defun matches (string regex) + (cl-ppcre:scan regex string)) + +(defun integer-equal (string integer) + (eql (parse-integer string) integer)) + +(defun http-request (url + &rest args + &key (protocol :http/1.1) + (method :get) + content + content-type + content-length + range + cookie-jar + basic-authorization + parameters + external-format-out + additional-headers) + (declare (ignore protocol method content content-type content-length cookie-jar basic-authorization + range parameters external-format-out additional-headers)) + (setf *last-reply* (make-instance 'http-reply)) + (with-slots (body status-code headers uri stream close) *last-reply* + (setf (values body status-code headers uri stream close) + (apply 'drakma:http-request + (format nil "~A~A" (script-context-base-url *script-context*) url) + args))) + (values)) diff --git a/deps/hunchentoot/test/script.lisp b/deps/hunchentoot/test/script.lisp new file mode 100644 index 0000000..6c87679 --- /dev/null +++ b/deps/hunchentoot/test/script.lisp @@ -0,0 +1,194 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*- + +;;; 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 :hunchentoot-test) + +(defun file-length-string (pathname) + (with-open-file (f pathname) + (princ-to-string (file-length f)))) + +(defun say (fmt &rest args) + (format t "; ") + (apply #'format t fmt args) + (terpri)) + +(defun test-hunchentoot (base-url &key (make-cookie-jar + (lambda () + (make-instance 'drakma:cookie-jar)))) + "Runs the built-in confidence test. BASE-URL is the base URL to use +for testing, it should not have a trailing slash. The keyword +arguments accepted are for future extension and should not currently +be used. + +The script expects the Hunchentoot example test server to be running +at the given BASE-URL and retrieves various pages from that server, +expecting certain responses." + (with-script-context (:base-url (format nil "~A/hunchentoot/test/" base-url)) + + (say "Request home page") + (http-request "") + (http-assert 'status-code 200) + (http-assert-header :content-type "^text/html") + + (say "Test cookies") + (let ((cookie-jar (funcall make-cookie-jar))) + (http-request "cookie.html" :cookie-jar cookie-jar) + (http-request "cookie.html" :cookie-jar cookie-jar) + (http-assert-body "(?msi)COOKIE-IN "pumpkin".*"barking"")) + + (say "Test session variables") + (let ((cookie-jar (funcall make-cookie-jar))) + (http-request "session.html" :cookie-jar cookie-jar + :method :post :parameters '(("new-foo-value" . "ABC") ("new-bar-value" . "DEF"))) + (http-request "session.html" :cookie-jar cookie-jar) + ;; These assertions assume that SESSION-VALUE returns the found alist value as second value + (http-assert-body "(?i)\(HUNCHENTOOT-TEST::FOO . "ABC"\)") + (http-assert-body "(?i)\(HUNCHENTOOT-TEST::BAR . "DEF"\)")) + + (say "Test malformed session cookie validation") + (dolist (session-id '("" "invalid-session-id" ":invalid-session-id" "invalid:session-id")) + (http-request "session.html" + :additional-headers (acons "Cookie" (format nil "hunchentoot-session=~A" session-id) nil)) + (http-assert 'status-code 200) + ;; session is empty + (http-assert-body "(?i)\(HUNCHENTOOT-TEST::FOO\)")) + + (say "Test GET parameters with foreign characters (Latin-1)") + (http-request "parameter_latin1_get.html" + :external-format-out :iso-8859-1 + :parameters (list (cons "foo" (format nil "H~Chner" #.(code-char 252)))) + :additional-headers '(("Content-Type" . "text/plain; charset=iso-8859-1"))) + (http-assert-header :content-type "(?i)text/html; charset=ISO-8859-1") + (http-assert-body "(72 252 104 110 101 114)") + (http-assert-body "(?i)"Hühner"") + + (say "Test POST parameters with foreign characters (Latin-1)") + (http-request "parameter_latin1_post.html" + :external-format-out :iso-8859-1 + :method :post :parameters (list (cons "foo" (format nil "H~Chner" #.(code-char 252))))) + (http-assert-header :content-type "(?i)text/html; charset=ISO-8859-1") + (http-assert-body "(72 252 104 110 101 114)") + (http-assert-body "(?i)"Hühner"") + + (say "Test GET parameters with foreign characters (UTF-8)") + (http-request "parameter_utf8_get.html" + :external-format-out :utf-8 + :parameters (list (cons "foo" (format nil "H~Chner" #.(code-char 252))))) + (http-assert-header :content-type "(?i)text/html; charset=UTF-8") + (http-assert-body "(72 252 104 110 101 114)") + (http-assert-body "(?i)"Hühner"") + + (say "Test POST parameters with foreign characters (UTF-8)") + (http-request "parameter_utf8_post.html" + :method :post + :external-format-out :utf-8 + :parameters (list (cons "foo" (format nil "H~Chner" #.(code-char 252))))) + (http-assert-header :content-type "(?i)text/html; charset=UTF-8") + (http-assert-body "(72 252 104 110 101 114)") + (http-assert-body "(?i)"Hühner"") + + (say "Test redirection") + (http-request "redir.html") + (http-assert 'uri (lambda (uri) + (matches (princ-to-string uri) "info.html\\?redirected=1"))) + + (say "Test authorization") + (http-request "authorization.html") + (http-assert 'status-code 401) + (http-request "authorization.html" + :basic-authorization '("nanook" "igloo")) + (http-assert 'status-code 200) + + (say "Request the Zappa image") + (http-request "image.jpg") + (http-assert-header :content-length (file-length-string #P"fz.jpg")) + (http-assert-header :content-type "image/jpeg") + (http-assert 'body (complement #'mismatch) (file-contents #P"fz.jpg")) + + (say "Request the Zappa image from RAM") + (http-request "image-ram.jpg") + (http-assert-header :content-length (file-length-string #P"fz.jpg")) + (http-assert-header :content-type "image/jpeg") + (http-assert 'body (complement #'mismatch) (file-contents #P"fz.jpg")) + + (say "Upload a file") + (http-request "upload.html" + :method :post :parameters '(("clean" . "doit"))) + (http-request "upload.html" + :method :post :parameters '(("file1" #P"fz.jpg"))) + (http-request "upload.html") + (http-assert-body (format nil "fz.jpg.*>~A Bytes" (file-length-string #P"fz.jpg"))) + + (say "Range tests") + (say " Upload file") + (let* ((range-test-file-size (* 256 1024)) ; large enough to have hunchentoot use multiple buffers when reading back data, should be aligned to 1024 + (range-test-buffer (make-array range-test-file-size :element-type '(unsigned-byte 8))) + (uploaded-file-url "files/?path=user-stream")) ; The uploaded file will appear under the name "user-stream" in hunchentoot + + (dotimes (i range-test-file-size) + (setf (aref range-test-buffer i) (random 256))) + + (flex:with-input-from-sequence (upload-stream range-test-buffer) + (http-request "upload.html" + :method :post :parameters `(("file1" ,upload-stream)))) + + (say " Request the uploaded file, verify contents") + (http-request uploaded-file-url) + (http-assert-header :content-length (princ-to-string range-test-file-size)) + (http-assert 'body (complement #'mismatch) range-test-buffer) + + (say " Verify responses to partial requests") + + (say " Request just one byte") + (http-request uploaded-file-url :range '(0 0)) + (http-assert 'status-code 206) + (http-assert 'body 'equalp (subseq range-test-buffer 0 1)) + (http-assert-header :content-range (format nil "bytes 0-0/~D" range-test-file-size)) + + (say " End out of range") + (http-request uploaded-file-url :range (list 0 range-test-file-size)) + (http-assert 'status-code 416) + (http-assert-header :content-range (format nil "bytes 0-~D/~A" (1- range-test-file-size) range-test-file-size)) + + (say " Request whole file as partial") + (http-request uploaded-file-url :range (list 0 (1- range-test-file-size))) + (http-assert 'status-code 206) + (http-assert 'body 'equalp range-test-buffer) + (http-assert-header :content-range (format nil "bytes 0-~D/~D" (1- range-test-file-size) range-test-file-size)) + + (say " Request something in the middle") + (let ((start-offset (/ range-test-file-size 4)) + (length (/ range-test-file-size 2))) + (http-request uploaded-file-url :range (list start-offset (1- length))) + (http-assert 'status-code 206) + (http-assert 'body 'equalp (subseq range-test-buffer start-offset length)) + (http-assert-header :content-range (format nil "bytes ~D-~D/~D" start-offset (1- length) range-test-file-size)))) + + + (values))) + diff --git a/deps/hunchentoot/test/test-certificate.crt b/deps/hunchentoot/test/test-certificate.crt new file mode 100644 index 0000000..95d8320 --- /dev/null +++ b/deps/hunchentoot/test/test-certificate.crt @@ -0,0 +1,13 @@ +-----BEGIN CERTIFICATE----- +MIIB3TCCAUYCCQCDg/PAAhv7kjANBgkqhkiG9w0BAQQFADAzMQswCQYDVQQGEwJE +RTEQMA4GA1UECBMHR2VybWFueTESMBAGA1UEAxMJbG9jYWxob3N0MB4XDTA5MDIx +NjEyMTgzMFoXDTEwMDIxNjEyMTgzMFowMzELMAkGA1UEBhMCREUxEDAOBgNVBAgT +B0dlcm1hbnkxEjAQBgNVBAMTCWxvY2FsaG9zdDCBnzANBgkqhkiG9w0BAQEFAAOB +jQAwgYkCgYEAxpUaQISfEDw3c7VSFsW+oKQViarjMmZNJL7ZWaZlsbVgROPohCRj +qmbS1yjQ0DZQWZK4PMyyXqT90OUIXSohGAB9O3M/etMpMYaRlws66o2mNx/R8bTZ +qGDQcXXRg1Ghsq2JnQsyhl4nTQXMn8KM/jLd6iT9XJd+O6AuWfOlticCAwEAATAN +BgkqhkiG9w0BAQQFAAOBgQCUW7a5BvL8Qoy5Mvd9cxUt8jnDm5KRiEgcmBIIlrVi +bLXmEQaRPQDoxGsrzi/LaUuMitT/kaGwhbdhfwZsjXI2QxuqpPYRhLnPBvn6q77u +e0/yXaPp6UnMnQNw2O8xLcUDeLbRrw9IBPeDUYYP0OaTkJvORwFJ4e6rdVyha4o7 +1A== +-----END CERTIFICATE----- diff --git a/deps/hunchentoot/test/test-handlers.lisp b/deps/hunchentoot/test/test-handlers.lisp new file mode 100644 index 0000000..56bb68b --- /dev/null +++ b/deps/hunchentoot/test/test-handlers.lisp @@ -0,0 +1,557 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*- + +;;; 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 :hunchentoot-test) + +(defvar *this-file* (load-time-value + (or #.*compile-file-pathname* *load-pathname*))) + +(defmacro with-html (&body body) + `(with-html-output-to-string (*standard-output* nil :prologue t) + ,@body)) + +(defun hunchentoot-link () + (with-html-output (*standard-output*) + (:a :href "http://weitz.de/hunchentoot/" "Hunchentoot"))) + +(defun menu-link () + (with-html-output (*standard-output*) + (:p (:hr + (:a :href "/hunchentoot/test" "Back to menu"))))) + +(defmacro with-lisp-output ((var) &body body) + `(let ((*package* (find-package :hunchentoot-test-user))) + (with-output-to-string (,var #+:lispworks nil + #+:lispworks :element-type + #+:lispworks 'lw:simple-char) + ,@body))) + +(defmacro info-table (&rest forms) + (let ((=value= (gensym)) + (=first= (gensym))) + `(with-html-output (*standard-output*) + (:p (:table :border 1 :cellpadding 2 :cellspacing 0 + (:tr (:td :colspan 2 + "Some Information " + (hunchentoot-link) + " provides about this request:")) + ,@(loop for form in forms + collect `(:tr (:td :valign "top" + (:pre :style "padding: 0px" + (esc (with-lisp-output (s) (pprint ',form s))))) + (:td :valign "top" + (:pre :style "padding: 0px" + (esc (with-lisp-output (s) + (loop for ,=value= in (multiple-value-list ,form) + for ,=first= = t then nil + unless ,=first= + do (princ ", " s) + do (pprint ,=value= s)))))))))) + (menu-link)))) + +(defun authorization-page () + (multiple-value-bind (user password) + (authorization) + (cond ((and (equal user "nanook") + (equal password "igloo")) + (with-html + (:html + (:head (:title "Hunchentoot page with Basic Authentication")) + (:body + (:h2 (hunchentoot-link) + " page with Basic Authentication") + (info-table (header-in* :authorization) + (authorization)))))) + (t + (require-authorization))))) + +(defparameter *test-image* + (load-time-value + (with-open-file (in (make-pathname :name "fz" :type "jpg" :version nil + :defaults *this-file*) + :element-type 'flex:octet) + (let ((image-data (make-array (file-length in) + :element-type 'flex:octet))) + (read-sequence image-data in) + image-data)))) + +(defun image-ram-page () + (setf (content-type*) "image/jpeg") + *test-image*) + +(let ((count 0)) + (defun info () + (with-html + (:html + (:head (:title "Hunchentoot Information")) + (:body + (:h2 (hunchentoot-link) " Information Page") + (:p "This page has been called " + (:b + (fmt "~[~;once~;twice~:;~:*~R times~]" (incf count))) + " since its handler was compiled.") + (info-table (host) + (acceptor-address *acceptor*) + (acceptor-port *acceptor*) + (remote-addr*) + (remote-port*) + (real-remote-addr) + (request-method*) + (script-name*) + (query-string*) + (get-parameters*) + (headers-in*) + (cookies-in*) + (user-agent) + (referer) + (request-uri*) + (server-protocol*))))))) + +(defun oops () + (with-html + (log-message* :error "Oops \(error log level).") + (log-message* :warning "Oops \(warning log level).") + (log-message* :info "Oops \(info log level).") + (error "Errors were triggered on purpose. Check your error log.") + (:html + (:body "You should never see this sentence...")))) + +(defun redir () + (redirect "/hunchentoot/test/info.html?redirected=1")) + +(defun forbidden () + (setf (return-code*) +http-forbidden+) + nil) + +(defun cookie-test () + (set-cookie "pumpkin" :value "barking") + (no-cache) + (with-html + (:html + (:head (:title "Hunchentoot cookie test")) + (:body + (:h2 (hunchentoot-link) + " cookie test") + (:p "You might have to reload this page to see the cookie value.") + (info-table (cookie-in "pumpkin") + (mapcar 'car (cookies-in*))))))) + +(defun session-test () + (let ((new-foo-value (post-parameter "new-foo-value"))) + (when new-foo-value + (setf (session-value 'foo) new-foo-value))) + (let ((new-bar-value (post-parameter "new-bar-value"))) + (when new-bar-value + (setf (session-value 'bar) new-bar-value))) + (no-cache) + (with-html + (:html + (:head (:title "Hunchentoot session test")) + (:body + (:h2 (hunchentoot-link) + " session test") + (:p "Use the forms below to set new values for " + (:code "FOO") + " or " + (:code "BAR") + ". You can later return to this page to check if +they're still set. Also, try to use another browser at the same +time or try with cookies disabled.") + (:p (:form :method :post + "New value for " + (:code "FOO") + ": " + (:input :type :text + :name "new-foo-value" + :value (or (session-value 'foo) "")))) + (:p (:form :method :post + "New value for " + (:code "BAR") + ": " + (:input :type :text + :name "new-bar-value" + :value (or (session-value 'bar) "")))) + (info-table (session-cookie-name *acceptor*) + (cookie-in (session-cookie-name *acceptor*)) + (mapcar 'car (cookies-in*)) + (session-value 'foo) + (session-value 'bar)))))) + +(defun parameter-test (&key (method :get) (charset :iso-8859-1)) + (no-cache) + (recompute-request-parameters :external-format + (flex:make-external-format charset :eol-style :lf)) + (setf (content-type*) + (format nil "text/html; charset=~A" charset)) + (with-html + (:html + (:head (:title (fmt "Hunchentoot ~A parameter test" method))) + (:body + (:h2 (hunchentoot-link) + (fmt " ~A parameter test with charset ~A" method charset)) + (:p "Enter some non-ASCII characters in the input field below +and see what's happening.") + (:p (:form + :method method + "Enter a value: " + (:input :type :text + :name "foo"))) + (case method + (:get (info-table (query-string*) + (map 'list 'char-code (get-parameter "foo")) + (get-parameter "foo"))) + (:post (info-table (raw-post-data) + (map 'list 'char-code (post-parameter "foo")) + (post-parameter "foo")))))))) + +(defun parameter-test-latin1-get () + (parameter-test :method :get :charset :iso-8859-1)) + +(defun parameter-test-latin1-post () + (parameter-test :method :post :charset :iso-8859-1)) + +(defun parameter-test-utf8-get () + (parameter-test :method :get :charset :utf-8)) + +(defun parameter-test-utf8-post () + (parameter-test :method :post :charset :utf-8)) + +;; this should not be the same directory as *TMP-DIRECTORY* and it +;; should be initially empty (or non-existent) +(defvar *tmp-test-directory* + #+(or :win32 :mswindows) #p"c:\\hunchentoot-temp\\test\\" + #-(or :win32 :mswindows) #p"/tmp/hunchentoot/test/") + +(defvar *tmp-test-files* nil) + +(let ((counter 0)) + (defun handle-file (post-parameter) + (when (and post-parameter + (listp post-parameter)) + (destructuring-bind (path file-name content-type) + post-parameter + (let ((new-path (make-pathname :name (format nil "hunchentoot-test-~A" + (incf counter)) + :type nil + :defaults *tmp-test-directory*))) + ;; strip directory info sent by Windows browsers + (when (search "Windows" (user-agent) :test 'char-equal) + (setq file-name (cl-ppcre:regex-replace ".*\\\\" file-name ""))) + (rename-file path (ensure-directories-exist new-path)) + (push (list new-path file-name content-type) *tmp-test-files*)))))) + +(defun clean-tmp-dir () + (loop for (path . nil) in *tmp-test-files* + when (probe-file path) + do (ignore-errors (delete-file path))) + (setq *tmp-test-files* nil)) + +(defun upload-test () + (let (post-parameter-p) + (when (post-parameter "file1") + (handle-file (post-parameter "file1")) + (setq post-parameter-p t)) + (when (post-parameter "file2") + (handle-file (post-parameter "file2")) + (setq post-parameter-p t)) + (when (post-parameter "clean") + (clean-tmp-dir) + (setq post-parameter-p t))) + (no-cache) + (with-html + (:html + (:head (:title "Hunchentoot file upload test")) + (:body + (:h2 (hunchentoot-link) + " file upload test") + (:form :method :post :enctype "multipart/form-data" + (:p "First file: " + (:input :type :file + :name "file1")) + (:p "Second file: " + (:input :type :file + :name "file2")) + (:p (:input :type :submit))) + (when *tmp-test-files* + (htm + (:p + (:table :border 1 :cellpadding 2 :cellspacing 0 + (:tr (:td :colspan 3 (:b "Uploaded files"))) + (loop for (path file-name nil) in *tmp-test-files* + for counter from 1 + do (htm + (:tr (:td :align "right" (str counter)) + (:td (:a :href (format nil "files/~A?path=~A" + (url-encode file-name) + (url-encode (namestring path))) + (esc file-name))) + (:td :align "right" + (str (ignore-errors + (with-open-file (in path) + (file-length in)))) + " Bytes")))))) + (:form :method :post + (:p (:input :type :submit :name "clean" :value "Delete uploaded files"))))) + (menu-link))))) + +(defun send-file () + (let* ((path (get-parameter "path")) + (file-info (and path + (find path *tmp-test-files* + :key 'first :test (lambda (a b) (equal a (namestring b))))))) + (unless file-info + (setf (return-code*) +http-not-found+) + (return-from send-file)) + (handle-static-file (first file-info) (third file-info)))) + +(defparameter *headline* + (load-time-value + (format nil "Hunchentoot test menu (see file ~A)" + (truename (merge-pathnames (make-pathname :type "lisp") *this-file*))))) + +(defvar *utf-8* (flex:make-external-format :utf-8 :eol-style :lf)) + +(defvar *utf-8-file* (merge-pathnames "UTF-8-demo.html" *this-file*) + "Demo file stolen from .") + +(defun stream-direct () + (setf (content-type*) "text/html; charset=utf-8") + (let ((stream (send-headers)) + (buffer (make-array 1024 :element-type 'flex:octet))) + (with-open-file (in *utf-8-file* :element-type 'flex:octet) + (loop for pos = (read-sequence buffer in) + until (zerop pos) + do (write-sequence buffer stream :end pos))))) + +(defun stream-direct-utf-8 () + (setf (content-type*) "text/html; charset=utf-8") + (let ((stream (flex:make-flexi-stream (send-headers) :external-format *utf-8*))) + (with-open-file (in (merge-pathnames "UTF-8-demo.html" *this-file*) + :element-type 'flex:octet) + (setq in (flex:make-flexi-stream in :external-format *utf-8*)) + (loop for line = (read-line in nil nil) + while line + do (write-line line stream))))) + +(defun stream-direct-utf-8-string () + (setf (content-type*) "text/html; charset=utf-8" + (reply-external-format*) *utf-8*) + (with-open-file (in (merge-pathnames "UTF-8-demo.html" *this-file*) + :element-type 'flex:octet) + (let ((string (make-array (file-length in) + :element-type #-:lispworks 'character #+:lispworks 'lw:simple-char + :fill-pointer t))) + (setf in (flex:make-flexi-stream in :external-format *utf-8*) + (fill-pointer string) (read-sequence string in)) + string))) + +(define-easy-handler (easy-demo :uri "/hunchentoot/test/easy-demo.html" + :default-request-type :post) + (first-name last-name + (age :parameter-type 'integer) + (implementation :parameter-type 'keyword) + (meal :parameter-type '(hash-table boolean)) + (team :parameter-type 'list)) + (with-html + (:html + (:head (:title "Hunchentoot \"easy\" handler example")) + (:body + (:h2 (hunchentoot-link) + " \"Easy\" handler example") + (:p (:form :method :post + (:table :border 1 :cellpadding 2 :cellspacing 0 + (:tr + (:td "First Name:") + (:td (:input :type :text + :name "first-name" + :value (or first-name "Donald")))) + (:tr + (:td "Last name:") + (:td (:input :type :text + :name "last-name" + :value (or last-name "Duck")))) + (:tr + (:td "Age:") + (:td (:input :type :text + :name "age" + :value (or age 42)))) + (:tr + (:td "Implementation:") + (:td (:select :name "implementation" + (loop for (value option) in '((:lispworks "LispWorks") + (:allegro "AllegroCL") + (:cmu "CMUCL") + (:sbcl "SBCL") + (:openmcl "OpenMCL")) + do (htm + (:option :value value + :selected (eq value implementation) + (str option))))))) + (:tr + (:td :valign :top "Meal:") + (:td (loop for choice in '("Burnt weeny sandwich" + "Canard du jour" + "Easy meat" + "Muffin" + "Twenty small cigars" + "Yellow snow") + do (htm + (:input :type "checkbox" + :name (format nil "meal{~A}" choice) + :checked (gethash choice meal) + (esc choice)) + (:br))))) + (:tr + (:td :valign :top "Team:") + (:td (loop for player in '("Beckenbauer" + "Cruyff" + "Maradona" + ;; without accent (for SBCL) + "Pele" + "Zidane") + do (htm + (:input :type "checkbox" + :name "team" + :value player + :checked (member player team :test 'string=) + (esc player)) + (:br))))) + (:tr + (:td :colspan 2 + (:input :type "submit")))))) + (info-table first-name + last-name + age + implementation + (loop :for choice :being :the :hash-keys :of meal :collect choice) + (gethash "Yellow snow" meal) + team))))) + + +(defun menu () + (with-html + (:html + (:head + (:link :rel "shortcut icon" + :href "/hunchentoot/test/favicon.ico" :type "image/x-icon") + (:title "Hunchentoot test menu")) + (:body + (:h2 (str *headline*)) + (:table :border 0 :cellspacing 4 :cellpadding 4 + (:tr (:td (:a :href "/hunchentoot/test/info.html?foo=bar" + "Info provided by Hunchentoot"))) + (:tr (:td (:a :href "/hunchentoot/test/cookie.html" + "Cookie test"))) + (:tr (:td (:a :href "/hunchentoot/test/session.html" + "Session test"))) + (:tr (:td (:a :href "/hunchentoot/test/parameter_latin1_get.html" + "GET parameter handling with LATIN-1 charset"))) + (:tr (:td (:a :href "/hunchentoot/test/parameter_latin1_post.html" + "POST parameter handling with LATIN-1 charset"))) + (:tr (:td (:a :href "/hunchentoot/test/parameter_utf8_get.html" + "GET parameter handling with UTF-8 charset"))) + (:tr (:td (:a :href "/hunchentoot/test/parameter_utf8_post.html" + "POST parameter handling with UTF-8 charset"))) + (:tr (:td (:a :href "/hunchentoot/test/redir.html" + "Redirect \(302) to info page above"))) + (:tr (:td (:a :href "/hunchentoot/test/authorization.html" + "Authorization") + " (user 'nanook', password 'igloo')")) + (:tr (:td (:a :href "/hunchentoot/code/test-handlers.lisp" + "The source code of this test"))) + (:tr (:td (:a :href "/hunchentoot/test/image.jpg" + "Binary data, delivered from file") + " \(a picture)")) + (:tr (:td (:a :href "/hunchentoot/test/image-ram.jpg" + "Binary data, delivered from RAM") + " \(same picture)")) + (:tr (:td (:a :href "/hunchentoot/test/easy-demo.html" + "\"Easy\" handler example"))) + (:tr (:td (:a :href "/hunchentoot/test/utf8-binary.txt" + "UTF-8 demo") + " \(writing octets directly to the stream)")) + (:tr (:td (:a :href "/hunchentoot/test/utf8-character.txt" + "UTF-8 demo") + " \(writing UTF-8 characters directly to the stream)")) + (:tr (:td (:a :href "/hunchentoot/test/utf8-string.txt" + "UTF-8 demo") + " \(returning a string)")) + (:tr (:td (:a :href "/hunchentoot/test/upload.html" + "File uploads"))) + (:tr (:td (:a :href "/hunchentoot/test/forbidden.html" + "Forbidden \(403) page"))) + (:tr (:td (:a :href "/hunchentoot/test/oops.html" + "Error handling") + " \(output depends on " + (:a :href "http://weitz.de/hunchentoot/#*show-lisp-errors-p*" + (:code "*SHOW-LISP-ERRORS-P*")) + (fmt " \(currently ~S))" *show-lisp-errors-p*))) + (:tr (:td (:a :href "/hunchentoot/foo" + "URI handled by") + " " + (:a :href "http://weitz.de/hunchentoot/#*default-handler*" + (:code "*DEFAULT-HANDLER*"))))))))) + +(setq *dispatch-table* + (nconc + (list 'dispatch-easy-handlers + (create-static-file-dispatcher-and-handler + "/hunchentoot/test/image.jpg" + (make-pathname :name "fz" :type "jpg" :version nil + :defaults *this-file*) + "image/jpeg") + (create-static-file-dispatcher-and-handler + "/hunchentoot/test/favicon.ico" + (make-pathname :name "favicon" :type "ico" :version nil + :defaults *this-file*)) + (create-folder-dispatcher-and-handler + "/hunchentoot/code/" + (make-pathname :name nil :type nil :version nil + :defaults *this-file*) + "text/plain")) + (mapcar (lambda (args) + (apply 'create-prefix-dispatcher args)) + '(("/hunchentoot/test/form-test.html" form-test) + ("/hunchentoot/test/forbidden.html" forbidden) + ("/hunchentoot/test/info.html" info) + ("/hunchentoot/test/authorization.html" authorization-page) + ("/hunchentoot/test/image-ram.jpg" image-ram-page) + ("/hunchentoot/test/cookie.html" cookie-test) + ("/hunchentoot/test/session.html" session-test) + ("/hunchentoot/test/parameter_latin1_get.html" parameter-test-latin1-get) + ("/hunchentoot/test/parameter_latin1_post.html" parameter-test-latin1-post) + ("/hunchentoot/test/parameter_utf8_get.html" parameter-test-utf8-get) + ("/hunchentoot/test/parameter_utf8_post.html" parameter-test-utf8-post) + ("/hunchentoot/test/upload.html" upload-test) + ("/hunchentoot/test/redir.html" redir) + ("/hunchentoot/test/oops.html" oops) + ("/hunchentoot/test/utf8-binary.txt" stream-direct) + ("/hunchentoot/test/utf8-character.txt" stream-direct-utf-8) + ("/hunchentoot/test/utf8-string.txt" stream-direct-utf-8-string) + ("/hunchentoot/test/files/" send-file) + ("/hunchentoot/test" menu))))) diff --git a/deps/hunchentoot/test/test-key-no-password.key b/deps/hunchentoot/test/test-key-no-password.key new file mode 100644 index 0000000..a4291c5 --- /dev/null +++ b/deps/hunchentoot/test/test-key-no-password.key @@ -0,0 +1,15 @@ +-----BEGIN RSA PRIVATE KEY----- +MIICWwIBAAKBgQDGlRpAhJ8QPDdztVIWxb6gpBWJquMyZk0kvtlZpmWxtWBE4+iE +JGOqZtLXKNDQNlBZkrg8zLJepP3Q5QhdKiEYAH07cz960ykxhpGXCzrqjaY3H9Hx +tNmoYNBxddGDUaGyrYmdCzKGXidNBcyfwoz+Mt3qJP1cl347oC5Z86W2JwIDAQAB +AoGAJoJhneNaCUb0Je8ipSHhzrsjJhhKiMqH6TlNYvI+xFB9A78CpyV7Yl8gQfM7 +UzVFLamjKr8zU+FBC1Ju5co2sl4u3fPgXwuo5X36IVa03WdClXp0PQ7RsOXqi0Rx +d1maRkxPok7AnSMCAWNeLCgxVmCKzIWLKcvB8idK7evjGUkCQQDyoewf7ey1eNy7 +hv87E9E/gUQ/9A9rEhkKcRbwvEicB+OcxpZl6Br0Z6EJH39AlJe1ii81lSqfPd+h +6WE2uU+lAkEA0YXmYnCJdlcYAORLX3ewibVCikOJUIMt7smGVOK23ubmHh49+KUW +HT3xDPDRVmkmiYzqXZOY0pGUG37b4GAE2wJAXRPa1kDanp835kSaYtpuWjNHsFT7 +GTL/Ii9SApXoMNsh6QGRrpREyt96Olq34VlffYf+JksL57y/rogt/+VE9QJAV+vV +YmeQ92zSsMUb7+K83PyIAJcYjwWNB8/fI83DKURBOlA8dxNndTvh5ClF3vne5weP +7VabYXkfam5QfBYu0wJANPeIsAd8yUdZViiMOH6tE8DUlMy/p1N9Rz0eMSc4uUch +EB59djdHmSknY0JgVZJFybWFWKtbxSvcnrJq/hAcMQ== +-----END RSA PRIVATE KEY----- diff --git a/deps/hunchentoot/url-rewrite/packages.lisp b/deps/hunchentoot/url-rewrite/packages.lisp new file mode 100644 index 0000000..eff5edf --- /dev/null +++ b/deps/hunchentoot/url-rewrite/packages.lisp @@ -0,0 +1,38 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- + +;;; 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 #:url-rewrite + (:use :cl) + (:export #:*url-rewrite-tags* + #:*url-rewrite-fill-tags* + #:starts-with-scheme-p + #:add-get-param-to-url + #:rewrite-urls + #:url-encode)) \ No newline at end of file diff --git a/deps/hunchentoot/url-rewrite/primitives.lisp b/deps/hunchentoot/url-rewrite/primitives.lisp new file mode 100644 index 0000000..96dd185 --- /dev/null +++ b/deps/hunchentoot/url-rewrite/primitives.lisp @@ -0,0 +1,154 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- + +;;; 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 :url-rewrite) + +(declaim (inline peek-char*)) +(defun peek-char* () + "PEEK-CHAR with input stream bound to *STANDARD-INPUT* and returning +NIL on EOF." + (peek-char nil nil nil)) + +(declaim (inline whitespacep)) +(defun whitespacep (c) + "Checks whether C is a whitespace character." + (find c '(#\Space #\Tab #\Newline #\Linefeed #\Return #\Page))) + +(declaim (inline letterp)) +(defun letterp (c) + "Checks whether C is a character between A and Z +\(case-insensitive)." + (and (characterp c) + (or (char<= #\a c #\z) + (char<= #\A c #\Z)))) + +(declaim (inline name-char-p)) +(defun name-char-p (c) + "Checks whether C is a name constituent character in the sense of +HTML." + (and (characterp c) + (or (letterp c) + (digit-char-p c) + (char= c #\-) + (char= c #\.)))) + +(defun comment-start-p () + "Checks whether *STANDARD-OUTPUT* currently 'looks at' the string +\"--\". Will move the position within the stream by one unless the +first characters it sees is not a hyphen." + (unless (eql (peek-char*) #\-) + ;; if the first character isn't #\- we can return immediately + (return-from comment-start-p nil)) + ;; otherwise read the #\- so we can check the next character + (read-char) + (eql (peek-char*) #\-)) + +(defun read-while (predicate &key (skip t) (write-through t)) + "Reads characters from *STANDARD-INPUT* while PREDICATE returns a +true value for each character. Returns the string which was read +unless SKIP is true. Writes all characters read to *STANDARD-OUTPUT* +if WRITE-THROUGH is true. On EOF the string read so far is returned." + (let ((collector (or skip + (make-array 0 + :element-type 'character + :fill-pointer t + :adjustable t)))) + (handler-case + (loop while (funcall predicate (peek-char)) do + (let ((char (read-char))) + (when write-through + (write-char char)) + (unless skip + (vector-push-extend char collector))) + finally (return (and (not skip) collector))) + (end-of-file () + (and (not skip) collector))))) + +(defun read-until (string &key (skip t) (write-through t)) + "Reads characters from *STANDARD-INPUT* up to and including STRING. +Returns the string which was read \(excluding STRING) unless SKIP is +true. Writes all characters read to *STANDARD-OUTPUT* if +WRITE-THROUGH is true. On EOF the string read so far is returned." + (let* ((length (length string)) + (offsets + ;; we first check whether some substring which starts + ;; STRING can be found again later in STRING - this is + ;; necessary because we only peek one character ahead + (cond ((gethash string *find-string-hash*)) + (t (setf (gethash string *find-string-hash*) + ;; the resulting array of offsets is + ;; cached in *FIND-STRING-HASH* so we can + ;; use it again in case READ-UNTIL is + ;; called with the same STRING argument + (loop with offsets = (make-array length + :initial-element nil) + for i from 1 below length + ;; check if STRING starting from 0 + ;; has something in common with + ;; STRING starting from I + for mismatch = (mismatch string string + :start1 i :test #'char=) + when (> mismatch i) + ;; if this is the case remember the + ;; length of the match plus the + ;; character which must follow in + ;; OFFSETS + do (push (cons (char string (- mismatch i)) + (1+ (- mismatch i))) + (svref offsets i)) + finally (return offsets)))))) + (collector (or skip + (make-array 0 + :element-type 'character + :fill-pointer t + :adjustable t)))) + (handler-case + (loop for i = 0 then (cond (match (1+ i)) + ;; if there is an offset (see above) + ;; we don't have to start from the + ;; beginning of STRING + ((cdr (assoc c (svref offsets i)))) + (t 0)) + for c = (peek-char) + for match = (char= c (char string i)) + while (or (not match) (< (1+ i) length)) do + (cond (skip (read-char)) + (t (vector-push-extend (read-char) collector))) + when write-through do + (write-char c) + finally (if write-through + (write-char (read-char)) + (read-char)) + (unless skip + ;; decrement the fill pointer because collector now also + ;; contains STRING itself + (decf (fill-pointer collector) (1- length))) + (return (and (not skip) collector))) + (end-of-file () + (and (not skip) collector))))) + diff --git a/deps/hunchentoot/url-rewrite/specials.lisp b/deps/hunchentoot/url-rewrite/specials.lisp new file mode 100644 index 0000000..ee987c8 --- /dev/null +++ b/deps/hunchentoot/url-rewrite/specials.lisp @@ -0,0 +1,66 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- + +;;; 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 :url-rewrite) + +(defvar *url-rewrite-tags* + '(("a" . "href") + ("area" . "href") + ("frame" . "src") + ("img" . "src") + ("input" . "src") + ("form" . "action") + ("iframe" . "src")) + "The tag/attribute combinations where URL-rewriting should happen.") + +(defvar *url-rewrite-fill-tags* + '(("form" . "action")) + "The tag/attribute combinations where URL-rewriting should +optionally add an attribute.") + +(defvar *find-string-hash* + (make-hash-table :test #'equal) + "Hash tables used internally by READ-UNTIL to cache offset arrays.") + +;; stuff for Nikodemus Siivola's HYPERDOC +;; see +;; and + +(defvar *hyperdoc-base-uri* "http://weitz.de/url-rewrite/") + +(let ((exported-symbols-alist + (loop for symbol being the external-symbols of :url-rewrite + collect (cons symbol + (concatenate 'string + "#" + (string-downcase symbol)))))) + (defun hyperdoc-lookup (symbol type) + (declare (ignore type)) + (cdr (assoc symbol + exported-symbols-alist + :test #'eq)))) diff --git a/deps/hunchentoot/url-rewrite/url-rewrite.lisp b/deps/hunchentoot/url-rewrite/url-rewrite.lisp new file mode 100644 index 0000000..7670467 --- /dev/null +++ b/deps/hunchentoot/url-rewrite/url-rewrite.lisp @@ -0,0 +1,293 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- + +;;; 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 :url-rewrite) + +(defun starts-with-scheme-p (string) + "Checks whether the string STRING represents a URL which starts with +a scheme, i.e. something like 'https://' or 'mailto:'." + (loop with scheme-char-seen-p = nil + for c across string + when (or (char-not-greaterp #\a c #\z) + (digit-char-p c) + (member c '(#\+ #\- #\.) :test #'char=)) + do (setq scheme-char-seen-p t) + else return (and scheme-char-seen-p + (char= c #\:)))) + +(defun url-encode (string) + "URL-encode a string." + (with-output-to-string (s) + (loop for c across string + do (cond ((or (char<= #\0 c #\9) + (char<= #\a c #\z) + (char<= #\A c #\Z) + (find c "$-_.!*'()," :test #'char=)) + (write-char c s)) + ((char= c #\Space) + (write-char #\+ s)) + (t (format s "%~2,'0x" (char-code c))))))) + +(defun add-get-param-to-url (url name value) + "URL is assumed to be a http URL. The pair of NAME and VALUE will be +added as a GET parameter to this URL. Assumes that there's no other +parameter of the same name. Only checks if #\? is part of the string +to decide how to attach the new parameter to the end of the string." + ;; possible bug: doesn't check for #\? which is written as, say, + ;; "&x3f;" - also, is there any other way a question mark could be a + ;; legitimate part of a URL? + (concatenate 'string + url + (if (find #\? url :test #'char=) + "&" + "?") + name + "=" + (url-encode value))) + +(defun rewrite-urls (rewrite-fn &optional (test-fn (complement #'starts-with-scheme-p))) + "Reads an \(X)HTML document from *STANDARD-INPUT* and writes it back +to *STANDARD-OUTPUT*. Any attribute value which is in one of the +positions denoted by *URL-REWRITE-TAGS* is rewritten by REWRITE-FN if +it passes the test denoted by the optional function TEST-FN which +defaults to the complement of STARTS-WITH-SCHEME-P. + +This function aims to yield correct results for correct \(X)HTML input +and it also tries hard to never signal an error although it may warn +if it encounters syntax errors. It will NOT detect any possible error +nor is there any warranty that it will work correctly with faulty +input." + (loop + ;; read (and write back) until we see a #\< which is a candidate + ;; for a tag or a markup declaration + (read-until "<") + ;; get next char without reading it + (let ((peek-char (peek-char*))) + (cond ((null peek-char) + ;; stop if EOF + (return-from rewrite-urls)) + ((char= peek-char #\!) + ;; we've seen ") + ;; "" is nothing special, just write the + ;; char and go back to the start of the loop + (write-char (read-char))) + ((letterp peek-char) + ;; a letter, so this should be something like + ;; - we just check for names and + ;; delimited strings separated by whitespace + ;; until we see the next #\> + (read-name) + (skip-whitespace) + (block parameter-loop + (loop + (let ((peek-char (peek-char*))) + (cond ((null peek-char) + ;; stop if EOF + (warn "EOF in markup declaration") + (return-from rewrite-urls)) + ((char= peek-char #\>) + ;; a #\> ends the markup + ;; declaration - write it back + ;; and exit the loop + (write-char (read-char)) + (return-from parameter-loop)) + ((or (letterp peek-char) + (find peek-char '(#\' #\") :test #'char=)) + ;; a delimiter or a letter, so + ;; we expect a delimited string + (read-delimited-string) + (skip-whitespace)) + ((comment-start-p) + ;; a comment - skip it and write it back + (skip-comment)) + (t + ;; something else - this is an error + ;; so we warn and exit the loop + (warn "Unexpected character ~S in markup declaration" + peek-char) + (return-from parameter-loop))))))) + ((comment-start-p) + ;; we've seen "